build.c

Go to the documentation of this file.

/*
 
  $Id: build.c 1372 2017-02-03 09:09:13Z coelho $
 
  Copyright 1989-2016 MINES ParisTech.
 
  This file is part of NewGen.
 
  NewGen is free software: you can redistribute it and/or modify it under the
  terms of the GNU General Public License as published by the Free Software
  Foundation, either version 3 of the License, or any later version.
 
  NewGen is distributed in the hope that it will be useful, but WITHOUT ANY
  WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  License for more details.
 
  You should have received a copy of the GNU General Public License along with
  NewGen.  If not, see <http://www.gnu.org/licenses/>.
 
*/
 
/*
 
  This file manages the building of the "data dictionary" (i.e. the Domains
  table) and the generation of the specification file.
 
*/
#ifdef HAVE_CONFIG_H
    #include "config.h"
#endif
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <stdarg.h>
 
#include "genC.h"
#include "newgen_include.h"
 
 
/* INLINE[] gives, for each inlinable (i.e., unboxed) type, its NAME,
   its initial VALUE and its printing FORMAT (for each language which can
   be a target. */
 
struct inlinable {
  string name;
  string C_value;
  string C_format;
  string Lisp_value;
  string Lisp_format;
};
 
static char *keywords[] = {
    "external",
    "import",
    "tabulated",
    "from",
    "persistant",
    NULL
} ;
 
int Current_op, Current_start ;
 
/* Warning: this table knows about the actual values used for AND_OP 
   and OR_OP. */
 
static char *Op_names[] = {
  "-- shouldn't appear --",
  "x",
  "+",
  "->"
  } ;
 
/* Have we seen a user error somewhere ? */
 
int error_seen ;
 
/* FATAL generates a fatal error by printing (according to FORMAT)
   the given MSG. If there already is a user error, let's suppose that's
   her fault ! */
 
__attribute__((__noreturn__)) void
fatal(char * fmt, ...)
{
    va_list args;
    va_start(args, fmt);
    fprintf( stderr, "\nNewgen Fatal Error -- " ) ;
    vfprintf( stderr, fmt, args) ;
    va_end(args);
 
    abort() ;
}
 
/* USER generates a user error (i.e., non fatal) by printing the given MSG
   according to the FMT.
 */
__attribute__((__noreturn__)) void
user(char * fmt, ...)
{
  va_list args;
  va_start(args, fmt);
 
  fprintf( stderr, "\nNewgen User Error -- " ) ;
  vfprintf( stderr, fmt, args ) ;
  fflush(stderr);
 
  va_end(args);
  error_seen++ ;
 
  // it seems that the parser may go on in a loop on some syntax errors...
  // probably some issue in "genspec_lex.c"
  abort();
}
 
/* CHECK_NOT_KEYWORD checks if S isn't a reserved word. */
 
void check_not_keyword(char *s)
{
  char **sp ;
 
  for( sp = keywords ; *sp != NULL ; sp++ ) {
    if( strcmp( s, *sp ) == 0 ) {
            user( "Trying to use the reserved word %s\n", s ) ;
    }
  }
}
 
/* INIT initializes global data structures. */
 
void init(void)
{
    struct gen_binding *bp ;
    struct inlinable *ip ;
 
    /* FC: formats are directly inlined in genClib...
     */
    struct inlinable Inline[] = {
      {UNIT_TYPE_NAME, "U", "U", ":unit", "U"},
      {"bool", "1", "B%d", "newgen:gen-true", "~S"},
      {"char", "#\\a", "#\\%c", "#\\space", "~C"},
      {"int", "0", "%d", "0", "~D"},
      {"float", "0.0", "%f", "0.0", "~F"},
      {"string", "\"\"", "\"%s\"", "\"\"", "~S"},
      {NULL, "-- HELP --", "-- HELP --", "-- HELP --", "-- HELP --"},
    } ;
 
    for( bp = Domains ; bp < &Domains[ MAX_DOMAIN ] ; bp++ ) {
        bp->name = NULL ;
        bp->compiled = 0 ;
        bp->size = 0 ; 
        bp->tabulated = NULL;
        bp->domain = NULL ;
        bp->inlined = NULL ;
    }
 
    for( ip = Inline, bp = Domains ; ip->name != NULL ; ip++, bp++ ) {
        bp->name = ip->name ;
        bp->compiled = 1 ;
        bp->inlined = ip ;
    }
 
    /* Tabulated_bp hack is statically allocated here. */
    {
      static union domain d ;
      bp->name = "Name for tabulated domain" ;
      bp->domain = &d ;
      d.ba.type = ARRAY_DT ;
      d.ar.constructor = "Constructor for tabulated domain" ;
      d.ar.element = (struct gen_binding *) NULL ;
      d.ar.dimensions = (struct intlist *) NULL;
      Tabulated_bp = bp ;
    }
    
    Current_op = UNDEF_OP ;
    Current_start = -1 ;
    error_seen = 0 ;
}
 
static int max_domain = -1 ;
 
int max_domain_index()
{
  return max_domain;
}
 
/* LOOKUP checks whether a given NAME is in the Domains table. If not, the
   ACTION says whether this is an error or it should be introduced. If this
   is for a new gen_binding, look in the current allocation range, else from
   beginning */
 
struct gen_binding * lookup(char * name, int action)
{
    struct gen_binding *bp ;
 
    //bp = (action == NEW_BINDING) ? Tabulated_bp+Current_start+1 : Domains ;
    bp = Domains + ((action == NEW_BINDING) ? Current_start : 0);
 
    for( ; bp < &Domains[ MAX_DOMAIN ] ; bp++ ) {
        if( bp->name == NULL ) {
            if( action == NEW_BINDING )
                    break ;
        }
        else if( strcmp( bp->name, name ) == 0 ) break ;
    }
    switch( action ) {
    case NEW_BINDING:
        if( bp == &Domains[ MAX_DOMAIN ] )
                fatal( "lookup: Domains overflow on %s -- new\n", name ) ;
 
        break;
    case OLD_BINDING:
        if( bp == &Domains[ MAX_DOMAIN ] )
                user( "Unknown domain <%s>\n", name ) ;
 
        break ;
    default:
        fatal( "lookup: Unknown type %s\n", i2a( action )) ;
    }
    if( max_domain < bp-Domains ) {
        max_domain = bp-Domains ;
    }
    return( bp ) ;
}
 
/* NEW_BINDING introduces a new pair (NAME, VAL) in the Domains table. 
   Redeclaration is allowed if this is to overwrite a previous IMPORT
   definition. Note that we could (should ?) check that this new gen_binding
   isn't a new (and incompatible) IMPORT definition. */
 
struct gen_binding * new_binding(char * name, union domain * val)
{
    struct gen_binding * bp;
 
    if( Read_spec_mode && val->ba.type ==  IMPORT_DT ) {
        bp = lookup(name, OLD_BINDING);
    }
    else {
        bp = lookup(name, NEW_BINDING);
    }
    if( bp->domain == NULL ) {
#ifdef DBG_BINDING
        (void)fprintf(stderr, "Introducing %s at index %d\n", 
                      name, bp-Domains ) ;
#endif
        bp->domain = val ;
        bp->name = name ;
    }
    else
    {
        if( val->ba.type == IMPORT_DT || 
            (Read_spec_mode && val->ba.type == EXTERNAL_DT )) {
        }
        else 
            user( "Redeclaration skipped: <%s>\n", name ) ;
        free(val);
    }
 
    return( bp ) ;
}
 
/* PRINT_DOMAINLIST prints, in the OUT stream, the List of domains, bound
   together by an OPerator. */
 
void
print_domainlist( out, l, op )
     FILE *out ;
     struct domainlist *l ;
     int op ;
{
  if( l == NULL )
    fatal( "print_domainlist: null", "" ) ;
 
  for( ; l->cdr != NULL ; l = l->cdr ) {
    print_domain( out, l->domain ) ;
    (void)fprintf( out, " %s ", Op_names[ op ] ) ;
  }
  print_domain( out, l->domain ) ;
}
      
void
print_persistant( out, dp )
FILE *out ;
union domain *dp ;
{
    if( dp->ba.persistant ) {
        (void)fprintf( out, "persistant " ) ;
    }
}
 
/* PRINT_DOMAIN prints on the OUT stream a domain denoted by the DP pointer.
   This is done before the compilation so (STRUCT BINDING *) members are
   still strings. */
 
void print_domain(FILE * out, union domain * dp)
{
    if (!dp) {
        fprintf(out, " NULL union domain");
        return;
    }
 
    switch( dp->ba.type ) {
    case EXTERNAL_DT:
        break ;
    case IMPORT_DT:
        (void)fprintf( out, " from \"%s\"", dp->im.filename ) ;
        break ;
    case BASIS_DT:
        (void)print_persistant( out, dp ) ;
#ifdef DBG_DOMAINS
        (void)fprintf( out, "%s:%s (%d)", 
                      dp->ba.constructor, dp->ba.constructand->name,
                      dp->ba.constructand-Domains ) ;
#else
        (void)fprintf(out, "%s:%s", 
                      dp->ba.constructor, dp->ba.constructand->name );
#endif
        break ;
    case LIST_DT:
        print_persistant( out, dp ) ;
        (void)fprintf(out, "%s:%s*", 
                      dp->li.constructor, dp->li.element->name ) ;
        break ;
    case SET_DT:
        print_persistant( out, dp ) ;
        (void)fprintf(out, "%s:%s{}", 
                      dp->se.constructor, dp->se.element->name ) ;
        break ;
    case ARRAY_DT: {
        struct intlist *ilp ;
 
        print_persistant( out, dp ) ;
        (void)fprintf(out, "%s:%s", 
                      dp->ar.constructor, dp->ar.element->name ) ;
 
        for( ilp = dp->ar.dimensions ; ilp != NULL ; ilp = ilp->cdr ) 
                (void)fprintf( out, "[%d]", ilp->val ) ;
 
        break ;
    }
    case CONSTRUCTED_DT:
        print_domainlist( out, dp->co.components, dp->co.op ) ;
        break ;
    default:
        fatal( "print_domain: switch on %s\n", i2a( dp->ba.type )) ;
    }
}
 
/* PRINT_DOMAINS prints on the OUT stream the Domains table. Inlined domains
   aren't printed. */
 
void
print_domains(FILE * out)
{
    struct gen_binding *bp ;
 
    for( bp = Domains ; bp < &Domains[ MAX_DOMAIN ] ; bp++ ) {
        if( bp->name == NULL || bp == Tabulated_bp ) continue ;
 
        if( !IS_INLINABLE( bp )) {
 
          /* if( (dp=bp->domain)->ba.type==CONSTRUCTED_DT && dp->co.op==OR_OP)
             (void)fprintf( out, "--NEWGEN-FIRST %d\n", dp->co.first ) ; */
 
            (void)fprintf( out, 
                    (IS_EXTERNAL( bp ) ? "external %s" : 
                     IS_IMPORT( bp ) ? "import %s" :
                     IS_TABULATED( bp ) ? "tabulated %s = " :
                     "%s = "), 
                    bp->name ) ;
            print_domain( out, bp->domain ) ;
            (void)fprintf( out, ";\n" ) ;
        }
    }
}
 
/* RECONNECT replaces the (STRUCT BINDING *) members of the DP domain
   which are, on entry, strings by their effective values, i.e. pointers
   in the Domains table which have the corresponding names. 
 
   FIRST members for OR_OP (checked with OP) domains are updated. */
 
static int current_first ;
 
void reconnect(int op, union domain * dp)
{
    struct domainlist *dlp ;
 
    if( op == OR_OP ) current_first++ ;
 
    switch( dp->ba.type ) {
    case EXTERNAL_DT:
    case IMPORT_DT:
        return ;
    case BASIS_DT:
        dp->ba.constructand = lookup( (char *)dp->ba.constructand, OLD_BINDING ) ;
        break;
    case LIST_DT:
        dp->li.element = lookup( (char *)dp->li.element, OLD_BINDING ) ;
        break ;
    case SET_DT:
        dp->se.element = lookup( (char *)dp->se.element, OLD_BINDING ) ;
        break ;
    case ARRAY_DT:
        dp->ar.element = lookup( (char *)dp->ar.element, OLD_BINDING ) ;
        break ;
    case CONSTRUCTED_DT: 
        if( dp->co.op == OR_OP && !Read_spec_mode ) 
                dp->co.first = current_first ;
 
        for( dlp = dp->co.components ; dlp != NULL ; dlp = dlp->cdr ) {
            reconnect( dp->co.op, dlp->domain ) ;
        }
        return ;
    default:
        fatal( "reconnect: switch on %s\n", i2a( dp->ba.type )) ;
    }
}
 
/* COMPILE reconnects the Domains table (for not compiled types -- note that
   an inlined type is already compiled). */
 
void compile(void)
{
  int i;
  current_first = 0;
  
  for(i=0; i<MAX_DOMAIN; i++)
  {
    struct gen_binding * bp = &Domains[i];
    
    if( bp->name == NULL || bp->compiled || bp == Tabulated_bp )
      continue ;
    
    reconnect( -1, bp->domain ) ;
    bp->compiled = (bp->domain->ba.type != EXTERNAL_DT ) ;
    
    if( IS_TABULATED( bp )) {
      union domain *dp = NULL;
      
      if( !(bp->domain->ba.type == CONSTRUCTED_DT &&
            (dp=bp->domain->co.components->domain)->ba.type == BASIS_DT &&
            strcmp( dp->ba.constructand->name, "string" ) == 0)) {
        user( "compile: tabulated first %s domain isn't string\n",
              dp->ba.constructand->name ) ;
      }
    }
    
    /* set size of domain. */
    if (bp->domain->ba.type == BASIS_DT ||
        bp->domain->ba.type == ARRAY_DT ||
        bp->domain->ba.type == SET_DT ||
        bp->domain->ba.type == LIST_DT ||
        bp->domain->ba.type == CONSTRUCTED_DT)
      bp->size = gen_size(i);
  }
 
#ifdef DBG_COMPILE
  print_domains( stderr ) ;
#endif
}
 
/* GEN_WRITE_SPEC prints the Domains table in the given FILENAME. */
 
void gen_write_spec(char * filename)
{
    extern int fclose();
    FILE *id ;
 
    if( (id = fopen( filename, "w" )) == NULL ) {
        user( "Cannot open spec file %s in write mode\n", filename ) ;
        return ;
    }
    print_domains( id ) ;
 
    if( fclose( id )) 
      user( "Cannot close spec file %s\n", filename ) ;
}
 
/* BUILD (in fact, the "main" function) parses the specifications and generates
   the manipulation functions. */
 
/*ARGSUSED*/
int build(int argc, char * argv[])
{
  init();
  genspec_parse();
  compile();
  
  if (error_seen == 0) {
    if (argc<3)
      user("not enough arguments provided, need 3, got %d!", argc);
    gencode(argv[1]);
    gen_write_spec(argv[2]);
    return 0;
  }
  return 1;
}
 
/* ALLOC is an "iron-clad" version of malloc(3). */
 
char * alloc(int size)
{
    char * p;
 
    if( (p=malloc( (unsigned)size )) == NULL && size != 0)
            fatal( "alloc: No more memory for %s bytes\n", i2a( size )) ;
  
    return p;
}