/*
 *  MODULE  :   import.c
 *              handles import of modules
 *
 *              this module is one part of the former module.c
 *              ( the other part is export.c, the cut was done on
 *                January 17th, 1991 by B.B. )
 *
{*  last modification:	14.08.92  15:37   }

 
 *  BB  19.01.91 : LINT_ARGS-switch in function-definitions
 *                 'idname' changed to indnamrec/idnamptr
 *                 'local' (= static) at function-declarations deleted
 *                 descriptions of local and global functions
 *  BB  22.01.91 : skipdecl skips unused function-declarations
 *                 functions and procedures as parameters are now possible
 *                 new local functions :
 *                      evaloper evaluates Operator-declarations
 *                      evalfupa handles functions in parameterlists
 *                 interface-syntax changed :
 *                      ')' and ';' in parameter-lists added.
 *  BB  24.01.91 : function code_init added.
 *  uli 06.03.91 : filename replaced by prognam()
 *  uli 07.03.91 : constnode: "c, c, " deleted in call of sprintf
 *                 cast "(char)c" added whenever %c in format in sprintf
 *  uli 06.05.91 : "on_verbose or not os_verbose"
 *  uli 08.05.91 : rconstype added.
 *  uli 14.05.91 : idfset() must have constant right side.
 *  uli 08.08.91 : getid excepts '*' in C-name.
 *  BB  11.12.91 : dynamic strings in table, C-name length is variable now
 *  uli 17.12.91 : MAX_NAMELENGTH replaced by SYM_SIZE,
		   NAMElength by namelength.
 *  uli 04.02.92 : TIMER requested.
 *  PJ  30.07.92 : casepart : It is now possible to import RECORDs with
                              variants.
                   typenode & basic interface file reading routines :
                     if TESTMODE is defined each i/o-action on the interface
                     file will be displayed. Useful for debugging purposes.
 *  PJ  04.08.92 : module list restriction for DEMOVERSION implemented
 *  PJ  14.08.92 : CASE_SENSITIV replaced by CASE_SENSITIV from defs.h
 *  PJ  30.03.95 : Casts for ANSI-Compatibility inserted
*/
 
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include <time.h>
#include           "impor.t"
 
#include "error.h"
#include "sysutil.h"        /* import finish */
#include "scan.h"
#include "symtab.h"
#include "idtab.h"
#include "optab.h"
#include "blktab.h"
#include "bintab.h"
#include "option.h"
 
#include           "expor.t"
#include "import.h"
 
#include           "implemen.t"


/* PJ 30.07.92
/* If you want to check input from the interface file in "typenode" :

     #define TESTMODE

   currently off */

 
/*---------------------------------------------------------------------------*/
 
#define dump_import     false
 
#define getpath(ini)    ini->md->path
#define getname(ini)    ini->md->name
 
/*
 * the following types und variables are used only in this module
*/
 
typedef struct idnamrec * idnamptr;             /* These data are used as    */
typedef struct idnamrec {                       /* buffers when reading      */
	  char pname[SYMSIZE];              /* names of identifiers out  */
	  char cname[SYMSIZE];              /* of the interface-file.    */
        } idnamrec;
 
global  modptr  modlist  = NULL;        /* These data are used for creating  */
global  modptr  modlast  = NULL;        /* two linear lists carrying all     */
global  iniptr  initlist = NULL;        /* modules which are to be imported. */
global  iniptr  initlast = NULL;
 
local   FILE *  intfile = NULL;           /* pointer to Interface-file       */
local   int     i_line  = 0;              /* line-numbers in interface-file  */
local   char    errtext[255];             /* buffer for error-messages       */
 
local   boolean Nooverload = false;      /* Flags which have to be set in    */
local   boolean ArrayType  = false;      /* idtab while importing a module.  */
local   boolean DescType   = false;      /* These variables are initialized  */
local   boolean HasDyn     = false;      /* with 0 and set by functions with */
                                                    /* Side-effects globally */
local   boolean Hide_TypeName  = false;
local   boolean Hide_TypeDecl  = false;
local   boolean Hide_EnumNames = false;
 
local   boolean Module_Not_Found = false;
 
/*---------------------------------------------------------------------------*/
 
#define bb_local  local
   /* function-declarations with 'static' are sensless, */
   /* 'static' is correct at function-definitions.      */
   /* 'bb_local' should be deleted. */
 
#ifdef LINT_ARGS
 
bb_local   modptr   yetused      (char *);
bb_local   void     insinit      (modptr);
#ifdef CHECK
bb_local   void     moddump      (modptr);
bb_local   void     initdump     (iniptr);
#endif
 
bb_local   int      next         (FILE *);
bb_local   char    *getstr       (FILE *);
bb_local   idnamptr getid        (void);
 
bb_local   binptr   lidnode      (idkind,symctype);
bb_local   binptr   ridnode      (symctype);
bb_local   binptr   lidrout      (idkind,symctype);
bb_local   binptr   constnode    (void);
bb_local   binptr   typenode     (void);
bb_local   binptr   typecode     (void);
bb_local   binptr   parlist      (void);
 
bb_local   binptr   constpart    (void);
bb_local   binptr   varpart      (void);
bb_local   binptr   casepart     (void);
 
bb_local   void     skipdecl     (void);
bb_local   void     evaloper     (void);
 
bb_local   void     poolput      (idptr);
bb_local   idptr    poolget      (idptr);
bb_local   void     poolcheck    (char*);
 
#else
 
bb_local   modptr   yetused      ( );
bb_local   void     insinit      ( );
#ifdef CHECK
bb_local   void     moddump      ( );
bb_local   void     initdump     ( );
#endif
 
bb_local   int      next         ( );
bb_local   char    *getstr       ( );
bb_local   idnamptr getid        ( );
 
bb_local   binptr   lidnode      ( );
bb_local   binptr   ridnode      ( );
bb_local   binptr   lidrout      ( );
bb_local   binptr   constnode    ( );
bb_local   binptr   typenode     ( );
bb_local   binptr   typecode     ( );
bb_local   binptr   parlist      ( );
 
bb_local   binptr   constpart    ( );
bb_local   binptr   varpart      ( );
bb_local   binptr   casepart     ( );
 
bb_local   void     skipdecl     ( );
bb_local   void     evaloper     ( );
 
bb_local   void     poolput      ( );
bb_local   idptr    poolget      ( );
bb_local   void     poolcheck    ( );
 
#endif

/* PJ 30.07.92 */
#ifdef TESTMODE
#define fread(fileptr)  chfgetc(fileptr)
#define backchar(chr,fileptr) chungetc(chr,fileptr)
#else
#define fread(fileptr)  fgetc(fileptr)
#define backchar(chr,fileptr) ungetc(chr,fileptr)
#endif

#ifdef TESTMODE

#ifdef LINT_ARGS
local int chfgetc( FILE *fileptr )
#else
local int chfgetc( fileptr )
  FILE *fileptr;
#endif
{ int c;

  c = fgetc( fileptr );
  printf( "\nINTERFACE-IMPORT-TEST : " );
  if ( c == EOF ) printf( "End of interface file !" );
  else
  { if ( c <= (int) ' ' ) printf( "read non-printable char %d", c );
    else
      printf( "read char %c", c );
  }
  printf( "\n" );
  return( c );
}


#ifdef LINT_ARGS
local void chungetc( int chr, FILE *fileptr )
#else
local void chungetc( chr, fileptr )
  int  chr;
  FILE *fileptr;
#endif
{ ungetc( chr, fileptr );
  printf( "\nINTERFACE-IMPORT-TEST : Giving back " );
  if ( chr == EOF ) printf( "EOF !" );
  else
  { if ( chr <= (int) ' ' ) printf( "non-printable char %d", chr );
    else
      printf( "char %c", chr );
  }
  printf( "\n" );
  return;
}

#endif

/* END PJ 30.07.92 */

 
/*---------------------------------------------------------------------------*/
/*---------------------------------------------------------------------------*/
 
/* yetused() : searches in the modlist for the module-name modname. If the
 * ----------  name is found, the module is yet used. In this case, the 
 * (valid) pointer to the struct modrec (modptr temp) will be returned, 
 * else the return-value is NULL. (next-pointer in the last element of the
 * list modlist has the value NULL.)
*/
#ifdef LINT_ARGS                                          /*-----------------*/
local modptr yetused (char *modname)                      /*  y e t u s e d  */
#else
local modptr yetused (modname)
  char * modname;
#endif
BEGIN (yetused)
 
  register char *s1;      /* pointers to first and second string to compare */
  register char *s2;      /* strcmp() is always case-sensitive. So I can't  */
  register int   len;     /* use it !!  len contains number of equal chars. */

  modptr temp = modlist;
 
  while (temp) {
    s1  = modname;
    s2  = temp->name;
    len = 0;

    if (CASE_SENSITIVE) 
      while ((*s1 != '\0') and (*s2 != '\0')) {
        if (*s1 != *s2)
          break;
        s1++; s2++; len++;
      }
    else 
      while ((*s1 != '\0') and (*s2 != '\0')) {
        if (tolower(*s1) != tolower(*s2))
          break;
        s1++; s2++; len++;
      } 

    if (*s1 == *s2)           /* strings are equal, module was yet used. */
      return (temp);          /* return-value is non-NULL modptr temp.   */

    /*
     * module-names should differ in the first namelength-2 characters.
     * if they do not, we are quite sure that moduniquename() created 
     * equal names for different functions. create an error-message !
     * (namelength == 0 means: any possible length, no name-cut.)
     *
     * "Too many leading insignificant characters: ....."
    */
    if ((namelength != 0) and (len > namelength-3)) {
      char errmess[3*FILENAME_MAX];
      sprintf (errmess, "%s %s ; %d", modname, temp->name, namelength-2);
      errput (4108, temp->nampos, errmess);
    }

    temp = temp->next;               /* compare with next element in modlist */
  }

  return (NULL);        /* end of modlist ==> no matching module-name found. */
 
END  /*yetused*/                                          /*  y e t u s e d  */
                                                          /*-----------------*/
 
/* insinit() : inserts a module md into the initlist.
 * ----------
*/
#ifdef LINT_ARGS                                          /*-----------------*/
local void insinit (modptr md)                            /*  i n s i n i t  */
#else
local void insinit (md)
  modptr md;
#endif
BEGIN (insinit)
  iniptr temp;
 
  if (not(md->inited)) {
    temp = (iniptr) malloc(sizeof(struct inirec));
    if (temp != (iniptr) 0) {
      if (initlist) {
        initlast->next = temp;
        initlast = temp;
      }
      else {
        initlist = temp;
        initlast = temp;
      }
      md->inited = true;
      temp->md   = md;
      temp->next = (iniptr) 0;
      temp->initrout = false;
      temp->initname = NULL;
    }
    else   memerror (pos) ;
  }
 
END  /*insinit*/                                          /*  i n s i n i t  */
                                                          /*-----------------*/
 
/*
 * next() : returns the first character of the next line in the
 * -------  interface-file f. This character is used by the switch
 * statement in some functions (e.g. import()).
*/
#ifdef LINT_ARGS                                              /*-------------*/
local int next (FILE *f)                                      /*   n e x t   */
#else
local int  next (f)
  FILE *f;
#endif
BEGIN (next)
  int i;
 
  while ((i=fgetc(f)) != '\n' and i != EOF)
    do_nothing;
  i_line++;
 
  return (i==EOF ? i : fgetc(f) );
 
END  /* next */                                               /*   n e x t   */
                                                              /*-------------*/
 
/*
 * getstr() : reads a string containing characters, digits, underscores
 * ---------  and signs out of the interface-file f. getstr() is used to
 * get names and strings containing integral constants. The string is
 * put into the static char g_str[], so neither getstr() nor the calling
 * function has to concern about allocating or freeing memory or about
 * copying and saving the string from the stack. The return-value
 * is g_str, so assignment to char-pointers in the calling function
 * may be done and also nested calls in functions with char-pointers
 * as parameters.
 * NOTE : the contents of g_str must be saved before the next invocation
 *        of getstr().
*/
#ifdef LINT_ARGS                                            /*---------------*/
local char *getstr (FILE *f)                                /*  g e t s t r  */
#else
local char *getstr (f)
  FILE *f;
#endif
BEGIN (getstr)
  int  c;
  int  i=0;
  static char g_str[SYMSIZE];      /* used as buffer by getstr()      */
 
  while ((c=fread(f))=='_' or isalnum(c) or c=='+' or c=='-')
    g_str[i++] = (char)c;
  g_str[i] ='\0';
  backchar(c,f);                  /* neccesary for next time reading  */
 
  return (g_str);
 
END  /* getstr */                                           /*  g e t s t r  */
                                                            /*---------------*/
 
/*
 * getid() : gets the complete name of an identifier, that means PASCAL-name
 * --------  and C-name from the interface-file.
 * Identifiers have the following syntax :
 *      - Pascal-Name   (Literals, Digits, '_')
 *      - List of Flags (optional)
 *      - '='           (indicates start of C-Name)
 *      - C-Name        (optional, only if different to Pascal-Name)
*/
#ifdef LINT_ARGS                                            /*---------------*/
local idnamptr getid (void)                                 /*   g e t i d   */
#else
local idnamptr getid ()
#endif
BEGIN (getid)
  int  c;
  int  i;
  static idnamrec id;
 
  HasDyn = false;                 /* initialize Flags of Flaglist with FALSE */
 
  i=0;
  while ((c=fread(intfile))=='_' or isalnum(c))       /* first alpha-numeric */
    id.pname[i++]=c;                               /* string is PASCAL-name. */
  id.pname[i]='\0';                             /* PASCAL-name is completed. */
 
  if (c == FlagIndicator) {        /* last read char is '=' or FLagIndicator */
    while ((c=fread(intfile)) != '=') {         /* The '=' ends Flag-List.   */
      if (c == HasdynFlag)                      /* if Flag was found, global */
        HasDyn = true;                          /* Variable is set TRUE.     */
    }
  }                                             /* last read char is now '=' */
 
  c = fread(intfile);                           /* read next char after '='  */
  if (c=='_' or isalpha(c)) {           /* first char in C-name (no digits!) */
    i = 0;                              /* C-name (runtime-name) is different*/
    id.cname[i++] = c;                                /* to the PASCAL-name. */
    while ((c=fread(intfile))=='_'
			or c=='*' or isalnum(c))     /* if existing, second */
      id.cname[i++] = c;                           /* alphanumeric string is */
    id.cname[i]='\0';                           /* C-name. End it with '\0'. */
    backchar(c,intfile);                 /* c is used by next reading function */
  }
  else {                               /* C-name equals PASCAL-name and was  */
    strcpy (id.cname, id.pname);       /* not exported. copy PASCAL-name.    */
    backchar(c,intfile);                 /* c is used by next reading function */
  }
 
  if ((c=fread(intfile)) !=  '=')     /* '=' is used to end alpha-string */
    backchar(c,intfile);                /* c is used by next reading function */
 
  return ((idnamptr) &id);
 
END  /* getid */                                            /*   g e t i d   */
                                                            /*---------------*/
 
             /*-----------------------------------*/
             /* ...node : creating special binptr */
             /*-----------------------------------*/
 
/*
 * lidnode() : is used to create an idnode on the left side of a declaration,
 * ----------  that means, the identifier is not yet declared, therefore an
 * idtab-entry has to be created.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local binptr lidnode (idkind ik, symctype sc)               /* l i d n o d e */
#else
local binptr lidnode (ik,sc)
  idkind   ik;
  symctype sc;
#endif
BEGIN (lidnode)
  int      c;
  idnamptr n;
  idptr    ip = (idptr) 0;
  binptr   bp,ne;
  symctype dummy = cIdent ;
 
  if ((c=fread(intfile)) < 31) {
    backchar (c, intfile);
    bp = ridnode (cIdent);
    poolget (binid(bp));        /* test forward-declaration; only coded */
  }                             /* identifiers may be forward-declarated */
  else {
    backchar (c, intfile);
    n = getid ();
 
#ifdef OLD
    if (Hide_TypeName or Hide_EnumNames) {
      int i = 0;
      while ((c=(n->pname)[i]) != '\0') {
        (n->pname)[i] = tolower(c);
        i++;
      }
    }
    ip = idins (symcins(n->pname,&dummy), ik);
#endif
 
    if (Hide_TypeName or Hide_EnumNames)
      ip = idcreate (symcins(n->pname,&dummy), ik);
    else
      ip = idins (symcins(n->pname,&dummy), ik);
 
    bp = binidcreate (sc, ip);
    idsetbin  (ip, bp);
    idsetcsym (ip, symins(n->cname));
    idfset    (ip, imported) ;
    if (HasDyn)   idfset (ip,hasdyn  ) ;
  }
  if ((c=fread(intfile)) == ',') {        /* idlist found */
    ne = lidnode (ik,sc);
    binappend (bp,ne);
  }
  else {
              /* ':' trennt typnamen bzw variablennamen und declarationen,
                 ')' beendet Definition Aufzaehlungstypen. ansonsten Fehler */
    if (c != ':'  &&  c != ')') {
      sprintf (errtext,
               "lidnode : \':\' expected, %c = ord(%d) found (line %d)",
               (char)c, c, i_line);
      errput (9451, pos, errtext);
      /*
       *  "lidnode : ':' expected, ... found (line-nunmber of interface-file)"
       */
    }
  }
  return (bp);
 
END  /* lidnode */                                          /* l i d n o d e */
                                                            /*---------------*/
 
/*
 * reccomp() : is used to create declaration of record-components.
 * ----------  Record-components are cCsymbol-, cRecelem- or cIdlist-nodes.
 * Only cRecelem- or cIdlist-nodes are created. If more than one record-
 * component is found in the interface-file, a recursive call is done.
 * symtab-entries are created for each component.
 * The type of the record-components is evaluated and appended on the
 * right side of the last record-component.
 * the list of the record-components with their type on the end of the
 * list is returned.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local binptr reccomp (void)                                 /* r e c c o m p */
#else
local binptr reccomp ()
#endif
BEGIN (reccomp)
  int     c;
  symptr  syp;
  idptr   id;
  binptr  list;
  binptr  p;
 
  syp = symins(getstr(intfile));
 
  if ((c=fread(intfile)) == '=') {      /* identifier found */
    id = idcreate (syp, IDNONE);
    syp = symins(getstr(intfile));
    idsetcsym (id, syp);
    list = binidcreate (cIdlist, id);
  }
  else {                                /* Symbol found */
    backchar (c, intfile);
    list = binsycreate (syp);
  }
 
  if ((c=fread(intfile)) == ',') {      /* idlist found */
    p = reccomp ();
    binappend (list, p);
  }
  else if (c == ':') {                  /* type declaration found */
    p = typenode ();
    binrlink (list, p);
  }
  else {
    sprintf (errtext,
             "reccomp : unexpected, char ord(%d) found (line %d)",  c, i_line);
    errput (9451, pos, errtext);
    /*
     *  "reccomp : unexpected char ... found"
     */
  }
 
  return (list);
 
END  /* reccomp */                                          /* r e c c o m p */
                                                            /*---------------*/
 
 
/*
 * ridnode() : is used to create an idnode on the right side of a declaration,
 * ----------  that means, the identifier is already declared, an existing
 * idtab-entry has to be found.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local binptr ridnode (symctype sc)                          /* r i d n o d e */
#else
local binptr ridnode (sc)
  symctype sc;
#endif
BEGIN (ridnode)
  int      c;
  idptr    id;
  binptr   p;
  idnamptr n;
  symctype dummy = cIdent ;
 
  c = fread (intfile);
  if (c < 31) {                 /* identifier is coded; new version */
    id = id_decod ((c=fread(intfile)));
    if (not(id)) {
      sprintf (errtext, "unexpected byte-code ord(%d) in line %d", c, i_line);
      errput (4102, pos, errtext);
      /*
       *   "type 'name' is not yet declared."
       */
    }
    return (idbin (id));
  }
  else {                        /* identifier was exported as a string */
    backchar (c, intfile);        /* if it was imported from another module. */
    n = getid ();
    id = idfnd (symcins(n->pname,&dummy));
    if (not(id)) {
      errput (4102, pos, n->pname);
      /*
       *  "type 'name' is not yet declared."
       */
      return ((binptr) 0);
    }
    else {                      /* The first incidence of this identifier is */
      id_setcode (id);          /* a string. All following incidences will */
                                /* be coded. ---> make entry in id_cod_tab */
      p = bincreate (sc);
      binupid (p,id);
      return (p);
    }
  }
/*
  p = bincreate (sc);
  binupid (p,id);
  return (p);
*/
 
END  /* ridnode */                                          /* r i d n o d e */
                                                            /*---------------*/
 
/*
 * lidrout() : is used to create the idnode on the left side of the
 * ----------  definition of a routine. This function is similar to
 * idnode(), except that there is only one identifier and no idlist
 * allowed as name of a function or procedure and that the next
 * character in the interface-file is not ':' but '(' indicating the
 * start of the parameter-list.
 * The identifier is not yet declared, an idtab-entry has to be created.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local binptr lidrout (idkind ik, symctype sc)               /* l i d r o u t */
#else
local binptr lidrout (ik,sc)
  idkind   ik;
  symctype sc;
#endif
BEGIN (lidrout)
  idnamptr  n;
  idptr     id;
  binptr    p;
 
  n = getid ();
  id = idcreate (symcins(n->pname,&sc), ik);
  idsetcsym (id, symins(n->cname));
  idfset (id,imported) ;
  if (HasDyn)   idfset (id,hasdyn  ) ;
  p = bincreate (sc);
  binupid (p,id);
 
  return (p);
 
END  /* lidrout */                                          /* l i d r o u t */
                                                            /*---------------*/
 
/*
 * constnode() : creates a bintab-subtree defining a constant.
 * ------------  The type of this constant may be boolean, integer,
 * character, real or string. The data for the constant-definition
 * are taken out of the interface-file.
 * return-value is the node on the root of the subtree.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local binptr constnode (void)                           /* c o n s t n o d e */
#else
local binptr constnode ()
#endif
BEGIN (constnode)
  int     c;
  binptr  p;
  char   *str;
  int     len;
 
  if ((c=fread(intfile)) == ':') {           /* delimiter not yet deleted */
    sprintf (errtext,
             "constnode : \':\' found, should have been deleted (line %d)",
             i_line);
    errput (9451, pos, errtext);
    /*
     *  "constnode : ':' found, should have been deleted (line-number)
     */
  }
 
  switch (c) {
 
    case 'b' :
      p = bincreate (cBcon);
      binupvalue (p, (longint) fread(intfile));
    break;
 
    case 'i' :
      p = bincreate (cIcon);
      binupvalue (p, (longint)  atol(getstr(intfile)));
    break;
 
    case 'c' :
      p = bincreate (cCcon);
      binupvalue (p, (longint) fread(intfile));
    break;
 
    case 'r' :
    case 's' :
      if (c=='r')
        p = bincreate (cRcon);
      else
        p = bincreate (cScon);
 
      len = fread(intfile);
      str = (char*) malloc (len+1);
      if (not str)    memerror (pos) ;
      p88_fgets (str, len+1, intfile);
      binupcharp (p, str) ;
    break;
 
    default :
      sprintf (errtext, "constnode : unexpected char ord(%d)", c);
      errput (9455, pos, errtext);
      /*
       *   "error occured in constnode"
       */
    break;
  }
 
  return (p);
 
END  /* constnode */                                    /* c o n s t n o d e */
                                                        /*-------------------*/
 
/*
 * constpart() : creates a bintab-subtree defining the constant-part
 * ------------  of a record-declaration.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local binptr constpart (void)                           /* c o n s t p a r t */
#else
local binptr constpart ()
#endif
BEGIN (constpart)
  int    c;
  binptr p;
  binptr l;
  binptr r;
 
  if ((c=fread(intfile)) == '?') {           /* empty constpart of record is */
    backchar (c, intfile);                     /* possible only if varpart of  */
    return (NULL);                           /* record exists (is not empty) */
  }
 
  /* ELSE */
 
  backchar (c, intfile);
  p = reccomp ();                                  /* first record-component */
 
  while ((c=fread(intfile)) == ';') {        /* separator only between comps */
    if (binsymc(p) != cSemicolon) {             /* only one component so far */
      l = p;
      p = bincreate (cSemicolon);                      /* initialize list of */
      binlside  (p, l);                           /* record-components. p is */
      binappend (p, r=reccomp());                    /* father of this list. */
    }
    else {
      bininsert (r, l=bincreate (cSemicolon));      /* insert next component */
      binappend (l, r=reccomp());                     /* into existing list. */
    }
  }         /* while : end of constant part */
 
  if (c == '?'  or  c == '!') {        /* '!' means end of record, '?' means */
    backchar (c, intfile);                  /* start of variant part. both are */
  }                                       /* needed or deleted by varpart(). */
  else if (c == ')') {
    backchar (c, intfile);               /* ')' ends subrecords of case-labels */
  }                                       /* in the variant parts of records */
  else {
    sprintf (errtext,
             "constpart : unexpected char ord(%d) (line %d)", c, i_line);
    errput (9455, pos, errtext);
    /*
     *   "error occured in constpart ..."
     */
  }
 
  return (p);
 
END  /* constpart */                                    /* c o n s t p a r t */
                                                        /*-------------------*/
 
/*
 * varpart() : creates a bintab-subtree defining the variant-part
 * ----------  of a record-declaration.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local binptr varpart (void)                                 /* v a r p a r t */
#else
local binptr varpart ()
#endif
BEGIN (varpart)
  int    c;
  symptr syp;
  binptr p;
  binptr l;
  binptr r;
 
  if ((c=fread(intfile)) == '!') {               /* '!' means end of record. */
    return (NULL);                                 /* variant-part is empty. */
  }
  else if (c != '?') {                   /* '?' means start of variant-part. */
    backchar (c, intfile);             /* an error occured if '?' isn't found. */
    sprintf (errtext,
             "varpart : unexpected char ord(%d) (line %d)", c, i_line);
    errput (9455, pos, errtext);
    /*
     *   "error occured in varpart ..."
     */
    return (NULL);
  }
 
  /* ELSE */
 
  p = bincreate (cCASE);
  syp = symins(getstr(intfile));        /* get C union-id */
  l = bincreate (cCsymbol);
  binupsym (l,syp);
  binlside (p, l);
  if ((c=fread(intfile)) == '=') {     /* '=' starts Tagfield */
          /* evaluate tag-field, not yet implemented */
  }
  /* if no tag-field is specified, the second '?' was read */
 
  binappend (p, r=casepart());
 
  while ((c=fread(intfile)) != '!' and c != EOF) {   /* '!' is end of record */
    backchar (c, intfile);
    bininsert (r, l=bincreate(cSemicolon));
    binappend (l, r=casepart());
  }
 
  return (p);
 
END  /* varpart */                                          /* v a r p a r t */
                                                            /*---------------*/
 
/*
 * casepart() : creates a bintab-subtree defining the variant-part
 * -----------  of a record-declaration.
*/
#ifdef LINT_ARGS                                          /*-----------------*/
local binptr casepart (void)                              /* c a s e p a r t */
#else
local binptr casepart ()
#endif
BEGIN (casepart)
  int    c;
  symptr syp;
  binptr bp;
  binptr l;
  binptr r;
 
  syp = symins(getstr(intfile));                /* struct-id as C-symbol */
 
  if ((c=fread(intfile)) == '=') {              /* next is case-label */
    if ((c=fread(intfile)) == '(') {            /* else-part found */
      bp = bincreate (cELSE);
    }
    else {                                      /* evaluate case-label */
      errput (9456, pos, NULL);
      /*
       *   "case-labels in the interface-file are not yet implemented."
       */
 
      bp = bincreate (cColon);
      if (c == ':') {
        constnode ();
        if ((c=fread(intfile)) != ',')
          backchar (c, intfile);
        constnode ();
      }
      else {
        constnode ();
      }
      if ((c=fread(intfile)) != '(')            /* '(' ends case-label and */
        backchar (c, intfile);                    /* starts record-data */
    }
  }
  else if (c == '(') {                         /* no case-label was exported */
    bp = bincreate (cColon);
  }
  else {
    sprintf (errtext, "%c = ord(%d) (in casepart, line %d)",
		 (char)c, c, i_line);
    errput (9457, pos, errtext);
    /*
     *   "unexpected character ... (in casepart, line-number) in interface-file"
     */
  }
 
  l = bincreate (cCsymbol);
  binupsym (l,syp);
  binlside (bp, l);
 
  /* PJ 30.07.92 :
     There was an error in export.c ( or in the interface file documentation ).
     If the variant consists of more than one component, the binary tree
     contained a RECORD node and export produced a "&"-Character which
     could not be processed by "constpart".
     Therefore the following change :  IF a "&"-character is found, call
     typenode instead of constpart to process the record entry.
  */
  c = fread( intfile );
  backchar( c, intfile );
  r = ( c == '&' ) ? typenode( ) : constpart( );       /* END PJ 30.07.92 */
  binappend (bp, r);
 
  if ((c=fread(intfile)) != ')')  {
    backchar (c, intfile);
 
    sprintf (errtext,
             "casepart : \')\' expected, %c = ord(%d) found (line %d)",
             (char) c, c, i_line);
    errput (9451, pos, errtext);
    /*
     *  "casepart : '(' expected, ... found (line-number)"
     */
  }
 
  return (bp);
 
END  /* casepart */                                       /* c a s e p a r t */
                                                          /*-----------------*/
 
 
 
/*
 * typenode() : creates a bintab-subtree defining data-types.
 * -----------  This function is used to evaluate type- and variable-
 * declarations, types of function-parameters and return-values.
 * If the declaration is nested, typenode() will be called
 * recursively.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local binptr typenode (void)                            /*  t y p e n o d e  */
#else
local binptr typenode ()
#endif
BEGIN (typenode)
  int     c;
  binptr  p;
  binptr  r;
  binptr  l;
  binptr  t;
 
  switch (c=fread(intfile)) {
 
    case '#' :      /* size of */
      sprintf (errtext, "typenode (sizeof) : not yet implemented");
      errput (9451, pos, errtext);
      /*
       *  "typenode (sizeof) : not yet implemented"
       */
    break;
 
    case '(' :      /* enumeration */
      {
        register binptr  bp;
        register int     value;
 
        if (Hide_TypeDecl)
          Hide_EnumNames = true;
 
        p = bincreate (cLParent);
        r = lidnode (IDCONST, cIdlist);
        binappend (p,r);
 
        Hide_EnumNames = false;
 
        value = 0;           /* assign values to all enumeration constants */
        do {
          idsetdatyp (binid (r), p) ;
          idsetvalue (binid (r), bp = bincreate (cIcon));
          binupvalue (bp, (long) value);
          value++;
        } while  (binsymc (r=binright(r)) == cIdlist) ;
      }
    break;
 
    case '^' :      /* pointer */
      {
        int      c;
        idnamptr n;
        idptr    id;
        symctype sc = cIdent;
 
        c = fread (intfile);
        if (c < 31) {
          id = id_decod (fread (intfile));
          r = binidcreate (cIdent, id);
        }
        else {
          backchar (c, intfile);
          n = getid ();
 
          id = idins (symcins (n->pname, &sc), IDTYPE);
          r = binidcreate (cIdent, id);
 
          idsetbin  (id, r);
          idsetcsym (id, symins(n->cname));
	  idfset    (id,imported) ;
	  if (HasDyn)   idfset (id,hasdyn  ) ;
 
          id_setcode (id);      /* make entry in id_code_tab */
          poolput (id);
        }
        p = bincreate (cArrow);
        binrlink (p,r);
      }
    break;
 
    case '}' :      /* set */
      p = bincreate (cSET);
      r = typenode ();
      binrlink (p, r);
    break;
 
    case '|' :      /* file */
      p = bincreate (cFILE);
      r = typenode ();
      binrlink (p, r);
    break;
 
    case ':' :      /* subrange */
      p = bincreate (cTill);
      l = constnode ();
      binlside (p,l);
      if ((c=fread(intfile)) != ',') {
        sprintf (errtext,
	   "typenode (subrange) : \',\' expected, %c = ord(%d) found (line %d)",
                 c, c, i_line);
        errput (9451, pos, errtext);
        /*
  typenode (subrange) ',' expected, ... found (line-number of interface-file)
         */
      }
      r = constnode ();
      binappend (p,r);
    break;
 
    case '[' :      /* array, dynamic or static */
 
    { boolean dyna;
 
      if ((c=fread(intfile)) == '[') {       /* dynamic */
        dyna = true;
      }
      else {                            /* static */
        backchar (c,intfile);
        dyna = false;
      }
      p = bincreate (dyna ? cDYNAMIC : cARRAY);
      l = typenode ();    /* array-range */
      if (l or not(dyna))
        binlside (p,l);
      r = p;
      while ((c=fread(intfile)) != ']' and c != EOF)  {
                                           /* ']' means end of array */
        if (c!=';') {                      /* ';' is delimiter */
          backchar (c,intfile);
 
          sprintf (errtext,
		   "typenode (array) : \';\' expected, %c = ord(%d) found (line %d)",
                   (char) c, c, i_line);
          errput (9451, pos, errtext);
          /*
           *  "typenode (array) ';' expected, ... found (line-nunmber)"
           */
        }
        l = bincreate(dyna ? cDYNAMIC : cARRAY);
        t = typenode ();                  /* no range only allowed for */
        if (t or not(dyna))               /* dynamic arrays. */
          binlside (l,t);                 /* append array-range left */
        binappend (r,l);                  /* append new array-node right */
        r = l;
      }
      binrlink (r,typenode());           /* append array-type right */
    }
    break;
 
    case '&' :      /* record */
      p = bincreate(cRECORD);
      l = constpart ();
      r = varpart ();
      if (l) binlside  (p, l);
      if (r) binappend (p, r);
    break;
 
    case '*' :
      p = (binptr) 0;
    break;
 
    default :
      if (c < 31  or  isalpha(c)) {
        backchar (c, intfile);
        p = typecode ();
      }
      else {
        p = (binptr) 0;   /* b_stop */
 
        sprintf (errtext, "%c = ord(%d) (typenode, line %d)",
		 (char)c, c, i_line);
        errput (9457, pos, errtext);
        /*
         *  "unexpected char ... (typenode, line-number) in interface-file."
         */
      }
    break;
 
  }  /* switch */
 
  return (p);
 
END  /* typenode */                                     /*  t y p e n o d e  */
                                                        /*-------------------*/
 
/*
 * typecode() : creates a bintab-subtree containing a type-declaration.
 * -----------  typecode() evaluates only non-nested named simple types,
 * e.g. the type of the return-value of functions. All other declarations,
 * which are harder to handle, are evaluated by typenode().
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local binptr typecode (void)                            /*  t y p e c o d e  */
#else
local binptr typecode ()
#endif
BEGIN (typecode)
 
  return (ridnode (cIdent));       /* cIdent only used for changing */
 
END  /* typecode */                                     /*  t y p e c o d e  */
                                                        /*-------------------*/
 
/*
 * parlist() : creates a bintab-subtree containing the argument- or
 * ----------  parameter-list of a function, procedure or Operator.
 *
 * 'V'  : PASCAL and C : parameter is called by (V)alue
 * 'R'  : PASCAL and C : parameter is called by (R)eference
 * 'L'  : PASCAL : va(L)-parameter, has to be copied in C
 * 'F'  : parameter is a (F)unction
 * 'P'  : parameter is a (P)rocedure
 *
 * parlist has side-effects on Nooverload !!!   (may be set to TRUE)
 * the global variable Nooverload must be initialized by the calling function,
 * because parlist() may be called recursively, so that initialisations in
 * nested calls would delete prior informations.
*/
#ifdef LINT_ARGS                                          /*-----------------*/
local binptr parlist (void)                               /*  p a r l i s t  */
#else
local binptr parlist ()
#endif
BEGIN (parlist)
  int    c;
  binptr list  = NULL;
  binptr param = NULL;
  binptr last  = NULL;
  binptr p, q;
 
  if ((c=fgetc(intfile)) != '(') {
    sprintf (errtext,
	    "parlist : \'(\' expected, unexpected char ord(%d) found (line %d)",
              c, i_line);
    errput (9451, pos, errtext);
    /*
     *  "parlist : '(' expected, ... found (line-number)"
     */
  }
 
  while ((c=fgetc(intfile)) != ')' and c != EOF) {
    switch (c) {
 
      case 'V' :                              /* call by (V)alue - parameter */
      case 'L' :
        p = typecode ();
        param = binidcreate (cIdlist, binid(p));
      break;
      case 'R' :                          /* call by (R)eference - parameter */
        p = typecode ();
        param = binidcreate (cVarparam, binid(p));
      break;
      case 'F' :                                  /* parameter is (F)unction */
        Nooverload = true;
        param = bincreate (cFUNCTION);
        q = bincreate (cColon);
        binlside (param, q);              /* append cColon left on cFUNCTION */
        p = parlist();                           /* evaluate sub-parlist and */
        if (p)                                     /* append it on left side */
          binlside (q, p);                                      /* of cColon */
        p = typecode();                          /* evaluate result-type and */
        binrlink (q, p);                 /* append it on cColon's right side */
      break;
      case 'P' :                                 /* parameter is (P)rocedure */
        Nooverload = true;
        param = bincreate (cPROCEDURE);
        p = parlist();                           /* evaluate sub-parlist and */
        if (p)                                     /* append it on left side */
          binlside (param, p);                              /* of cPROCEDURE */
      break;
 
      default  :
        sprintf (errtext, "parlist : unexpected char ord(%d) (line %d)",
		 c, i_line);
        errput (9455, pos, errtext);
        /*
         *   "error occured in parlist : ..."
         */
      break;
 
    }   /* switch */
 
    if ((c=fgetc(intfile)) != ';')
      ungetc (c, intfile);
 
    if (list)    binappend (last, param);
    else         list = param;
 
    last = param;
  }               /* end while */
 
  if ((c=fgetc(intfile)) != ':') {                 /* if result-type doesn't */
    ungetc (c, intfile);                            /* exist, put back char. */
  }                               /* result-type is evaluated by the caller. */
 
  return (list);
 
END  /* parlist */                                        /*  p a r l i s t  */
                                                          /*-----------------*/
 
/*
 * timecheck() : compares the date and time of the last change in two
 * ------------  module's interface-files. In order to ensure that
 * any changes in the interface of a module (e.g. type- and variable-
 * declarations, parameter lists and result-types) are recognized by
 * other modules using this module, the date and time of the last
 * changes are compared. If the latest change of the used module
 * was done after the last compilation of the using module, the
 * using module has to be recompiled. These dependencies are checked
 * in this function.
 * timecheck returns TRUE if the used module is older than the using
 * module. Else the return-value is FALSE.
 *
 * P.S.: the date and time in the interface-file of the actually compiled
 *       module will be changed only if any changes in global data occure
 *       or if a used module is more recent.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
global boolean timecheck (modptr user, modptr used)     /* t i m e c h e c k */
#else
global boolean timecheck (user, used)
  modptr user;
  modptr used;
#endif
BEGIN (timecheck)
  int      time_diff;
  boolean  time_err;
 
  time_err = false;
 
  time_diff = (user->time[0] - used->time[0]);
  if (time_diff < 0)
    time_err = true;
  else if (time_diff == 0) {
    time_diff = (user->time[1] - used->time[1]);
    if (time_diff < 0)
      time_err = true;
    else if (time_diff == 0) {
      time_diff = (user->time[2] - used->time[2]);
      if (time_diff < 0)
        time_err = true;
      else if (time_diff == 0) {
        if (user->time[3] < used->time[3])
          time_err = true;
      }
    }
  }
 
  return (time_err);
 
END   /* timecheck */                                   /* t i m e c h e c k */
                                                        /*-------------------*/
 
/*
 * insmod() : inserts a module into the modlist.
 * ---------
*/
#ifdef LINT_ARGS                                            /*---------------*/
global modptr insmod (char *modname,                        /*  i n s m o d  */
                      boolean glob, boolean direct)
#else
global modptr insmod (modname, glob, direct)
  char    *modname;
  boolean  glob;        /* imported with 'use global' , only in modules  */
  boolean  direct;      /* module explicitely used by actual pascal-file */
#endif
BEGIN (insmod)
  modptr  temp;
  modptr  mp;
  FILE *  mdfile;
  int     c;
  char    mdnam[20];
  char   *s;
  int     len;
#ifdef DEMOVERSION
#define MAXMODULES  15
  static modrec modarray[ MAXMODULES ];
  static int    modcount = 0;
  static modptr ma_ptr = &modarray[ 0 ];
#endif
 
  temp=yetused(modname);
  if (temp) {
    if (glob)      temp->usglob = true;
    if (direct)    temp->direct = true;
    if (direct)    temp->nampos = pos;
    if (not(temp->inited)) {
      errput (451, pos, temp->name);
      /*
       *   "warning : CIRCLE-USE !!  module uses itself, may cause an error !!"
       */
    }
    insinit (temp);
  }
  else {
#ifdef DEMOVERSION
    if ( modcount < MAXMODULES )
    { temp = ma_ptr++;
      modcount++;
    }
    else
    { char  nstr[ 5 ];
      sprintf( nstr, "%d", MAXMODULES );
      errput( 9460, pos, &nstr );
                   /* "demo version allows only MAXMODULES modules
                       to be imported."                             */
      exit( -999 );
    }
#else
    temp = (modptr) malloc(sizeof(struct modrec));
#endif
    if (temp) {
      if (modlist) {
        modlast->next = temp;
        modlast = temp;
      }
      else {                                    /* First call of insmod() */
        Module_Not_Found = false;               /* initilisation of global */
        modlist=temp;                           /* data : Module_Not_Found, */
        modlast=temp;                           /* modlist, modlast */
      }
      len = strlen (modname);
      temp->name = (char*) malloc (len+1);
      if (temp->name != NULL)
        strcpy (temp->name, modname);
      else
        memerror (pos);

      len = strlen (s = modfnam(modname));
      temp->path = (char*) malloc (len+1);
      if (temp->path != NULL)
        strcpy (temp->path, s);
      else
        memerror (pos);

      temp->next   = (modptr) 0;
      temp->usglob = glob;
      temp->inited = false;
      temp->direct = direct;
      temp->nampos = pos;
 
      mdfile = fopen(temp->path, "rb");
      if (mdfile) {
        while ((c=fgetc(mdfile)) != '='  &&  c != EOF)
          do_nothing;
        for (c=0; c<4; c++)
          fscanf (mdfile, "%d.", &(temp->time[c]));
 
        if ((c=fgetc(mdfile)) == '\n') {
          temp->version = 1;
          ungetc (c, mdfile);
        }
        else {
          temp->version = c;
        }
 
        while ((c=next(mdfile))=='u' or c=='U') {
          if (c=='u') {
            mp = insmod (strcpy (mdnam, getstr(mdfile)), false, false);
          }
          else {     /* c=='U' */
            mp = insmod (strcpy (mdnam, getstr(mdfile)), true , false);
          }
 
          if (timecheck(temp,mp)) {
            errput (4105, pos, temp->name) ;
            /*
             *   "timestamp error !!!"
             *   "interface of module %s has changed ",  mp->name);
             *    "after last change of module %s\n\n", temp->name);
             */
          }
 
        }
        fclose (mdfile);
        mdfile = (FILE*)0;
        insinit (temp);
      }
      else {
        Module_Not_Found = true;
        errput (30003, pos, modname);
        /*
         *  "Cannot open Module xxx. "
         */
      }
    }
    else   memerror (pos) ;
  }
 
  return ((modptr) temp);
                                                            /*  i n s m o d  */
END  /*insmod*/                                             /*---------------*/
 
/*
 * import() : this function controls the import of the data in the
 * ---------  interface-files of all the modules in the modlist.
 * The order in which the modules have to be imported is given by
 * the order the modules are found in initlist.
*/
#ifdef LINT_ARGS                                            /*---------------*/
global void import (void)                                   /*  i m p o r t  */
#else
global void import ()
#endif
BEGIN (import)
  int     c;
  binptr  p, datyp;
  binptr  l, r;
  modptr  modul;
  boolean to_import;
  char    buffer[512];
  char   *s;
 
  modul = yetused (prognam());
  if (modul != NULL) {
    errput (451, modul->nampos, prognam());
    /*
     *  "warning : CIRCLE-USE !!  module uses itself, may cause an error !!"
     */
  }
 
  if (Module_Not_Found) {
    fprintf (stdout, "Compilation aborted \n");
    fprintf (stderr, "Compilation aborted \n");
    finish (-10);
  }
  /* ELSE */

#ifdef TIMER 
  time_in (0);
#endif

  code_init ();
 
  initlast = initlist;    /* saving initlist */
 
  while (initlist) {
    modul = initlist->md;
    initlist->initrout = false;
    to_import = modul->direct  or  modul->usglob;
    pos = modul->nampos;       /* if directly used, actual module's position */
         /* in use-clause else position of first module using actual module. */
 
    if (on_verbose or not os_verbose)
      printf ("importing module  %s \n", modul->path);
 
    if (modul->version < ACTUAL_VERSION) {
      sprintf (errtext, "*****  %s  %s  *****",
                "Please recompile module", modul->path);
      errput (9451, pos, errtext);
      errput (4106, pos, NULL);
      /*
       *   "*****  Please recompile module ...  *****"
       *   "interface-file was compiled with an older version of PXSC"
       */
    }
    else {
      intfile=fopen(modul->path, "rb");
      if (not(intfile)) {
        errput (30003, pos, modul->name);
        /*
         *  "Module ... not found. Compilation abort."
         */
      }
    }
 
    if (modul->version < ACTUAL_VERSION) {
      do_nothing;
    }
    else {
      i_line = 1;
      code_reset ();
 
      while ((c=next(intfile)) != EOF and c != 'E' /*"END."*/) {
 
        Hide_TypeName  = false;
        Hide_TypeDecl  = false;
        Hide_EnumNames = false;
 
        switch (c) {
 
/*-----*/ case 'u' : ;      /* 'use' and */
/* USE */ case 'U' : ;      /* 'global use' already evaluated */
/*-----*/ break;
 
/*----------*/
/* PRIORITY */   /* not explicitly exported. each Operator carries his own. */
/*----------*/
 
/*--------------*/
/* Real-konvert */
/*--------------*/
          case 'R' :
            { boolean error;
              symptr ps,cs;
              idnamptr id;
              int rcbyte;
              idptr rcid;
 
              switch (rcbyte=fgetc(intfile)) {
                case '=' : error = (idrconv  ? true : false);   break;
                case '>' : error = (idruconv ? true : false);   break;
                case '<' : error = (idrdconv ? true : false);   break;
                default  : ungetc (rcbyte, intfile);
                           rcbyte = '=';
                           error = (idrconv  ? true : false);   break;
              }
 
              if (error) {
                errput (1046, pos, (char*)0);
                /*
                 *   "Real constant conversion already defined."
                 */
              }
              else {
 
                id = getid();
                ps = symins (id->pname);
                cs = symins (id->cname);
 
                rcid = idcreate (ps, IDFUNCTION);
                idsetcsym (rcid, cs);
                idsetdatyp (rcid, binidcreate (cREAL, idtypfnd (sREAL))) ;
                idsetparlist (rcid, binidcreate (cIdlist, idCHAR)) ;
		idfset (rcid, imported) ;
		if (HasDyn)   idfset (rcid, hasdyn  ) ;
 
                switch (rcbyte) {
                  case '=' : idrconv  = rcid;    break;
                  case '>' : idruconv = rcid;    break;
                  case '<' : idrdconv = rcid;    break;
                }
              }
            }
          break;
 
/*-------*/
/* CONST */
/*-------*/
          case 'C' :
            l = lidnode (IDCONST, cIdent);
            r = constnode ();
            idsetvalue (binid(l), r);
 
            switch (binsymc(r))
             begin
               case cIcon:  datyp = integertype ;   break ;
               case cCcon:  datyp = chartype ;      break ;
               case cRcon:  datyp = rconstype ;     break ;
               case cBcon:  datyp = booleantype ;   break ;
               case cScon: /* ; case cS2con : ; case cS3con : ; case cS4con : */
                            datyp = r          ;    break ;
               default:     datyp = anytype ;       
             end /* switch symc */
            idsetdatyp (binid(l), datyp) ;
 
	    idfset (binid(l),imported) ;
            if (modul->usglob or modul->direct)
	      idfset (binid(l),is_global) ;
            else
	      idfset (binid(l),hidden) ;
 
            if (dump_import and on_dump) {
              p = bincreate (cCONST);
              binlside  (p,l);
              binappend (p,r);
              dump (p);
              printline ();
            }
          break;
 
/*--------*/        /* 'T' means :  global name = type          */
/*  TYPE  */        /* 'G' means :  global name = global type   */
/*--------*/        /* 'L' means :         name = type          */
 
          case 'T' :
          case 'G' :
          case 'L' :
 
            Hide_TypeName = (c=='L' ? true : false);
            l = lidnode (IDTYPE, cIdent);      /* left son = type identifier */
            id_setcode (binid (l));             /* make entry in id_code_tab */
            Hide_TypeName = false;
 
            Hide_TypeDecl = (c=='G' ? false : true);
            r = typenode ();                 /* right son = type-declaration */
 
            DescType  = ((binsymc(unname(r)) == cDYNAMIC     )
                      or (binsymc(unname(r)) == cDOTPRECISION)
                      or (binsymc(unname(r)) == cSTRING      ));
 
            ArrayType = ((binsymc(unname(r)) == cARRAY )
                      or (binsymc(unname(r)) == cSET   ));
 
            idsetbin   (binid(l), l);
            idsetdatyp (binid(l), unname(r));
 
	    idfset (binid(l), imported ) ;
	    if (ArrayType)   idfset (binid(l), arraytype) ;
                                                 /* set by typenode() */
	    if (DescType)    idfset (binid(l), desctype ) ;
                                                 /* set by typenode() */
 
            if (not(modul->usglob or modul->direct))
	      idfset (binid(l), hidden      ) ;
            else if (c=='G') {
	      idfset (binid(l), globalglobal) ;
	      idfset (binid(l), is_global   ) ;
            }
            else if (c=='T')
	      idfset (binid(l), is_global   ) ;
            else
	      idfset (binid(l), hidden      ) ;
 
            if (binsymc(r)==cDYNAMIC or id_is (binid(unname(r)), dynamic))
	      idfset (binid(l), dynamic     ) ;
 
            if (dump_import and on_dump) {
              p = bincreate (cTYPE);
              binlside (p,l);                /* l becomes left  son of p */
              binrlink (p,r);                /* r becomes right son of p */
              dump (p);
              printline ();
            }
          break;
 
/*-------*/
/*  VAR  */
/*-------*/
          case 'V' :
            l = lidnode (IDVAR, cIdlist);    /* left son = list of variables */
            r = typenode ();                 /* right son = type-declaration */
 
            if (dump_import and on_dump)
              p = l;    /* save l for dump */
 
            while (l) {                        /* update all members of list */
              idsetdatyp (binid(l), r);
	      idfset (binid(l), imported ) ;
	      if (ArrayType)   idfset (binid(l), arraytype) ;
                                                     /* set by typenode() */
	      if (DescType)    idfset (binid(l), desctype ) ;
                                                     /* set by typenode() */
              if (modul->usglob or modul->direct)
		idfset (binid(l), is_global) ;
              else
		idfset (binid(l), hidden   ) ;
 
              l = binright(l);
            }
 
            if (dump_import and on_dump) {
              l = p;    /* restore old l */
              p = bincreate (cVAR);
              binlside (p,l);
              binrlink (p,r);
              dump (p);
              printline ();
            }
          break;
 
/*----------*/
/* FUNCTION */
/*----------*/
          case 'F' :
            if (not (to_import)) {                /* skip unused declaration */
              skipdecl ();                         /* to ensure synchronity. */
            }
            else {
              l = lidrout (IDFUNCTION, cIdent);          /* functions-name */
 
              Nooverload = false;
              idsetparlist (binid(l), r=parlist());
 
              if (dump_import and on_dump)
                if (r)   binrlink (l,r);
 
              idsetdatyp (binid(l), r=typecode());       /* result-type */
 
	      idfset (binid(l), imported  ) ;
	      idfset (binid(l), is_global ) ;
	      if (Nooverload)   idfset (binid(l), nooverload) ;
 
              idroutins (l);
 
              if (dump_import and on_dump) {
                p = bincreate (cColon);
                binlside (p,l);
                l = p;
                p = bincreate (cFUNCTION);
                binlside (p,l);
                dump (p);
                printline ();
              }
            }
           break;
 
/*-----------*/
/* PROCEDURE */
/*-----------*/
          case 'P' :
            if (not (to_import)) {                /* skip unused declaration */
              skipdecl ();                         /* to ensure synchronity. */
            }
            else {
              l = lidrout (IDPROCEDURE, cIdent);
              Nooverload = false;
              idsetparlist (binid(l), r=parlist());
 
              if (dump_import and on_dump)
                if (r)  binrlink (l,r);
 
	      idfset (binid(l), imported  ) ;
	      idfset (binid(l), is_global ) ;
	      if (Nooverload)   idfset (binid(l), nooverload) ;
 
              idroutins (l);
 
              if (dump_import and on_dump) {
                p = bincreate (cPROCEDURE);
                binlside (p,l);
                dump (p);
                printline ();
              }
            }
          break;
 
/*----------*/
/* OPERATOR */
/*----------*/
          case 'O' :
            if (not (to_import)) {                /* skip unused declaration */
              skipdecl ();                         /* to ensure synchronity. */
            }
            else {
              evaloper ();             /* evaluates Operator-declaration */
            }
          break;
 
/*-----------*/
/* INIT-ROUT */
/*-----------*/
          case 'I' :
            initlist->initrout = true;
            if ((c=fgetc(intfile)) != '\n') {   /* function-name follows */
              s = buffer;
              do {
                *s++ = c;                       /* copy char into buffer */
                c = fgetc (intfile);            /* read next char */
              } while ((c!='\n') && (c!='\0') && (c!=EOF));
              *s = '\0';                      /* terminate string */
              ungetc (c, intfile);   /* write back last char (sync next()) */
            }
            else {                   /* function name wasn't exported */
              strcpy (buffer, iroutname(modul->name));  /* create name */
              ungetc (c, intfile);   /* write back the terminating newline */
            }
            initlist->initname = (char*) malloc (strlen(buffer)+1);
            if (initlist->initname != NULL)
              strcpy (initlist->initname, buffer);
            else
              memerror (pos);
          break;
 
/*---------------*/
/* other = error */
/*---------------*/
          default  :
            sprintf (errtext,
                     "%c = ord(%d) (import (default), line %d)",
		     (char)c, c, i_line);
            errput (9457, pos, errtext);
            /*
      unexpected char ... (import (default), line-number) in interface-file.
             */
          break;
        } /* switch (c) */
 
      } /* while (c!=EOF and c!='E') */
 
      if (c == 'E') {
        if ((fgetc(intfile) != 'N')
        or  (fgetc(intfile) != 'D')
        or  (fgetc(intfile) != '.'))
        errput (9458, pos, getname (initlist));
        /*
         *  "unexpected char in ... : 'E' found, "END." not found."
         */
      }
 
      poolcheck (getname(initlist)); /* check unsatisfied forward-references */
                                       /* module-name used in error-messages */
      fclose (intfile);
      intfile = (FILE*)0;
    }  /* if (intfile = fopen(modfnam(..)) */
 
    initlist = initlist->next;
  } /* while (modul) */
 
  initlist = initlast;                  /* restoring initlist */
  pos = binpos (bincurr);
 
#ifdef TIMER
  time_out (0, "import");
#endif                                                      /*  i m p o r t  */
END  /* import */                                           /*---------------*/
 
#if 0
#ifdef LINT_ARGS                                    /*-----------------------*/
local void hide_idname (idptr id)                   /* h i d e _ i d n a m e */
#else
local void hide_idname ()
idptr id;
#endif
BEGIN (hide_idname)
  if (id_is (id,hidden))
    idsetsym (id, symNIL);
                                                    /* h i d e _ i d n a m e */
END  /* hide_idname */                              /*-----------------------*/
#endif
 
 
/*
 * skipdecl() : skips unused declarations of functions, procedures and
 * -----------  Operators.
 * Since type-identifiers are coded, their code may be the newline-character
 * which normally indicates the end of a declaration. Thus a newline-character
 * may occure inside a parameterlist and not only on the end of a declaration.
 * If the declaration is imported, the situation is not critical, since the
 * newline-character is evaluated as a coded type. But if the function has
 * not to be imported, we have to ensure, that the complete declaration
 * is skipped and not only the actual line.
 * Another problem is, that functions and procedures are allowed as parameters
 * inside parameterlists. Thus the kind of parameters must be evaluated
 * and if neccessary skipdecl is called recursively.
 *
 * NOTE : all characters forming a parameterlist (this are ";:()") may also
 *        occure as coded identifiers, so it's not enough to skip until the
 *        next ')' but the skip-algorithm must be similiar to parameter-
 *        evaluating functions.
*/
#ifdef LINT_ARGS                                          /*-----------------*/
local void skipdecl (void)                                /* s k i p d e c l */
#else
local void skipdecl ()
#endif
BEGIN (skipdecl)
  int    c;
 
  if ((c=fgetc(intfile)) == 'o')        /* indicates that next byte is coded */
    fgetc (intfile);                          /* Operator-symbol : delete it */
  else                                  /* in recursive calls the first byte */
    ungetc (c, intfile);                        /* is '(', thus put it back. */
 
  while ((c=fgetc(intfile)) != '('  and  c != EOF)    /* first '(' indicates */
    do_nothing;                                   /* start of parameterlist. */
 
  while ((c=fgetc(intfile)) != ')'  and  c != EOF) {        /* ')' indicates */
    switch (c) {                             /* end of actual parameterlist. */
      case 'R' :
      case 'V' :                /* parameter is type-identifier, this may be */
      case 'L' :                /* a string or 2 bytes forming a byte-code.  */
        ridnode(cIdent);        /* ridnode scans this type and synchronizes  */
        break;                  /* id_code_table if neccessary. p not used.  */
      case 'F' :
      case 'P' :                /* parameter is function or procedure, their */
          skipdecl();           /* parameter-lists have also to be skipped.  */
        break;
    }
    if ((c=fgetc(intfile)) != ';')      /* ';' separates the parameters and  */
      ungetc (c, intfile);              /* must be deleted. */
  }
 
  if ((c=fgetc(intfile)) == ':') {      /*  indicates following result-type  */
    ridnode(cIdent);            /* ridnode scans this type and synchronizes  */
  }                             /* id_code_table if neccessary. p not used.  */
  else {
    ungetc (c, intfile);
  }
                                                          /* s k i p d e c l */
END  /* skipdecl */                                       /*-----------------*/
 
 
 
 
#ifdef LINT_ARGS                                          /*-----------------*/
local void evaloper (void)                                /* e v a l o p e r */
#else
local void evaloper ()
#endif
BEGIN (evaloper)
  int      c;
  opptr    op;                  /* used as parameter in opins() */
  symctype sc;                  /*          -- " --             */
  symptr   psym, csym;          /*          -- " --             */
  binptr   res, l, r;           /*          -- " --             */
  boolean  vl, vr;              /*          -- " --             */
  idnamptr opnam;
  symctype s;           /* sc must not be changed, thus s is a buffer for sc */
   /* unchanged sc is used as parameter in opins, symcins() changes symctype */
 
  switch (c = fgetc(intfile)) {
 
    case 'i' :                                 /* identifier, named Operator */
      /* PJ 30.03.95: Cast to symctype inserted */
      sc = (symctype) (fgetc (intfile) + cAssign);  /* symctype sc = priority */
      s = sc;                                          /* relativ to cAssign */
      opnam = getid();
      psym = symcins (opnam->pname, &s);
      if (s != sc && sc != cIdent) {
        errput (4103, pos, opnam->pname);
        /*
         *  "Operator ... already declared with different priority"
         */
      }
      s = cIdent;
      csym = symcins (opnam->cname, &s);
    break;
 
    case 'o' :                /* Operator, Operator-Symbol */
      /* PJ 30.03.95  cast to symctype inserted */
      sc = (symctype) (fgetc (intfile) + cAssign);
      psym = symNIL;
      s = cIdent;
      csym = symcins (getstr(intfile), &s);
    break;
 
    case 'a' :                /* assign, ZuweisungsOperator */
      sc = cAssign;
      psym = symNIL;
      s = cIdent;
      csym = symcins (getstr(intfile), &s);
    break;
  }
 
  if ((c=fgetc(intfile)) != '(') {    /* skip '(' */
    sprintf (errtext, "%c = ord(%d)  (line %d)", (char)c, c, i_line);
    errput (9457, pos, errtext);
    /*
     *     "unexpected char ... in interfacefile"
     */
  }
  if ((c=fgetc(intfile)) == 'V')
    vl = vr = false;                  /* call by Value */
  else
    vl = vr = true;                   /* call by Referene */
  l = ridnode (cIdlist);              /* first operand */
 
  if ((c=fgetc(intfile)) == ';') {
                                      /* dyadic Operator */
    if ((c=fgetc(intfile)) == 'V')
      vr = false;                     /* call by Value */
    else
      vr = true;                      /* call by Referene */
    r = ridnode (cIdlist);            /* second operand */
  }
  else {                              /* monadic Operator */
    ungetc (c, intfile);              /* put back the ')' */
    r  = l;                           /* only one operand */
    l  = (binptr) 0;                  /* operand is on the */
    vr = vl;                          /* right side */
    vl = false;
  }
 
  if ((c=fgetc(intfile)) != ')')    /* skip ')' */
    ungetc (c, intfile);
 
  if (sc != cAssign) {
    if ((c=fgetc(intfile)) != ':') {
      sprintf (errtext,
        "import (Operator) : \':\' expected, char ord(%d) found (line %d)",
         c, i_line);
      errput (9451, pos, errtext);
      /*
       *  "import (Operator) : ':' expected, ... found (line-nunmber)"
       */
    }
    res = typecode ();
  }
  else
    res = voidtype;
 
  op = opins (sc, psym, csym, res, l, r, vl, vr);
 
  DescType  = ((binsymc(unname(res)) == cDYNAMIC     )
            or (binsymc(unname(res)) == cDOTPRECISION)
            or (binsymc(unname(res)) == cSTRING      ));
 
  ArrayType = ((binsymc(unname(res)) == cARRAY )
            or (binsymc(unname(res)) == cSET   ));
 
  opfset (op, imported) ;
  if (HasDyn)     opfset (op, hasdyn   ) ;
  if (ArrayType)  opfset (op, arraytype) ;
  if (DescType)   opfset (op, desctype ) ;
 
  if (binsymc(res)==cDYNAMIC or id_is (binid(unname(res)), dynamic))
     opfset (op, dynamic     ) ;
 
  if (dump_import and on_dump) {
    res = bincreate (cOpptr);
    binupop (res, op);
    dump (res);
    printline ();
  }
 
END  /* evaloper */                                       /*-----------------*/
 
 
/*---------------------------------------------------------------------------*/
/*--------   DATA AND FUNCTIONS HANDLING FORWARD-DECLARATIONS   -------------*/
/*---------------------------------------------------------------------------*/
 
typedef struct poolrec * poolptr;       /* These data are used to create     */
typedef struct poolrec {                /* a linear list representing the    */
          idptr   id;                   /* pool of forward declarated        */
          poolptr next;                 /* type-identifiers.                 */
        } poolrec;
 
local poolptr pool = NULL;              /* pool for forward-declarations     */
 
/*---------------------------------------------------------------------------*/
 
/*
 * poolput() : inserts forward-declarated identifiers into the pool
 * ----------
*/
#ifdef LINT_ARGS                                            /*---------------*/
local void poolput (idptr id)                               /* p o o l p u t */
#else
local void poolput (id)
  idptr id;
#endif
BEGIN (poolput)
  poolptr newp;
 
  newp = (poolptr) malloc (sizeof (struct poolrec));       /* allocate memory */
  if (newp) {
    newp->id = id;                                      /* update new element */
    newp->next = pool;                                /* append existing list */
    pool = newp;                                      /* new is now the first */
  }                                           /* element of the actual list. */
  else
    memerror (pos);
                                                            /* p o o l p u t */
END  /* poolput */                                          /*---------------*/
 
/*
 * poolget() : searches in the pool for an identifier
 * ----------  if the identifier is found, it's entry is deleted and it's
 * idptr is returned, else NULL is returned.
 * Since the argument of poolget() is an existing idptr, returned out from
 * the id_code_table by id_decod(), which was previously inserted into the
 * pool by poolput(), it is enough to compare the values of the idptr in
 * the pool to get the result.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local idptr poolget (idptr id)                              /* p o o l g e t */
#else
local idptr poolget (id)
  idptr id;
#endif
BEGIN (poolget)
  idptr   idret;
  boolean found;
  poolptr actu;
  poolptr last;
 
  if (pool == NULL) {           /* pool is empty */
    return (NULL);
  }
  else {                        /* pool exists */
    idret = NULL;
    found = false;              /* initialize values */
    actu  = pool;               /* start with first element */
    last  = pool;               /* of the linear list. */
 
    while (actu  and  not found) {
      if (id == actu->id) {             /* if identifier was found, */
        found = true;                   /* idret is set to it's idptr. */
        idret = actu->id;
        if (actu == pool)               /* delete identifier which's forward- */
          pool = pool->next;            /* reference is satisfied out of the */
        else                            /* pool. */
          last->next = actu->next;
        free (actu);                    /* free used memory. */
      }
      else {                            /* last should always be the list- */
        last = actu;                    /* element before actu, which means */
        actu = actu->next;              /* last->next==actu. */
      }
    }
  }
 
  return (idret);
                                                            /* p o o l g e t */
END  /* poolget */                                          /*---------------*/
 
 
/*
 * poolcheck() : checks if all forward-references are satisfied.
 * ------------  the parameter module_name is used in error-messages.
 * for each identifier in the pool an error-message is done, the entry is
 * deleted. poolcheck is done separately for all imported modules.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void poolcheck (char *module_name)                /* p o o l c h e c k */
#else
local void poolcheck (module_name)
  char *module_name;
#endif
BEGIN (poolcheck)
  poolptr p;
 
  while (pool) {
    sprintf (errtext, "%s : %s", module_name, symtab(idsym(pool->id)));
    errput (4104, pos, errtext);
    /*
     *  "unsatisfied forward reference in module "
     *  "module_name : ", (symtab(idsym(pool->id))
     */
    p = pool;
    pool = pool->next;
    free (p);
  }
  pool = NULL;  /* re-initialize the pool */
                                                        /* p o o l c h e c k */
END  /* poolcheck */                                    /*-------------------*/
 
 
 
/*---------------------------------------------------------------------------*/
/*--------------    DATA AND FUNCTIONS FOR CODIFICATION    ------------------*/
/*---------------------------------------------------------------------------*/
 
#define PRESET_ANZ      21              /* Number of preset-type-identifiers */
 
local   idptr   id_code_table[256];       /* table with byte-codes for ids.  */
local   int     act_code;                 /* actual highest coded identifier */
 
/*---------------------------------------------------------------------------*/
 
 
#ifdef LINT_ARGS                                        /*-------------------*/
global void code_init (void)                            /* c o d e _ i n i t */
#else
global void code_init ()
#endif
BEGIN (code_reset)
  int  i;
 
  act_code = PRESET_ANZ;
 
  for (i=0; i<=255; i++)
    id_code_table[i] = (idptr) 0;
 
         /* initialisation of identifier-code-table with preset-identifiers */
  id_code_table[ 1] = idINTEGER     ;
  id_code_table[ 2] = idREAL        ;
  id_code_table[ 3] = idBOOLEAN     ;
  id_code_table[ 4] = idCHAR        ;
  id_code_table[ 5] = NULL; /* idLITERAL */
  id_code_table[ 6] = idSTRING      ;
  id_code_table[ 7] = idTEXT        ;
  id_code_table[ 8] = idDOTPRECISION;
  id_code_table[ 9] = idCOMPLEX     ;
  id_code_table[10] = idINTERVAL    ;
  id_code_table[11] = idCINTERVAL   ;
  id_code_table[12] = idRVECTOR     ;
  id_code_table[13] = idCVECTOR     ;
  id_code_table[14] = idIVECTOR     ;
  id_code_table[15] = idCIVECTOR    ;
  id_code_table[16] = idRMATRIX     ;
  id_code_table[17] = idCMATRIX     ;
  id_code_table[18] = idIMATRIX     ;
  id_code_table[19] = idCIMATRIX    ;
  id_code_table[20] = NULL; /* buffer */
  id_code_table[21] = NULL; /* buffer */
        /* end of preset-initialisation */
        /* 21 = PRESET_ANZ */
                                                        /* c o d e _ i n i t */
END /* code_init */                                     /*-------------------*/
 
 
#ifdef LINT_ARGS                                      /*---------------------*/
global void code_reset (void)                         /* c o d e _ r e s e t */
#else
global void code_reset ()
#endif
BEGIN (code_reset)
  int  i;
 
  for (i=PRESET_ANZ+1; i<=act_code; i++) {
    id_code_table[i] = (idptr) 0;
  }
  act_code = PRESET_ANZ;
 
                                                      /* c o d e _ r e s e t */
END /* code_reset */                                  /*---------------------*/
 
 
 
 
#ifdef LINT_ARGS                                      /*---------------------*/
global int id_setcode (idptr id)                      /* i d _ s e t c o d e */
#else
global int id_setcode (id)
  idptr id;
#endif
BEGIN (id_setcode)
  int  i;
 
  for (i=PRESET_ANZ+1; i<=act_code; i++) {
    if (id_code_table[i] == id)
      break;
  }
 
  if (i > act_code) {                   /* identifier was not found */
    id_code_table[++act_code] = id;
 
    if (act_code > 255) {
      printf ("too much identifiers for coding in 8 Bits\n");
      exit (-999);
    }
  }
  return (i);
                                                      /* i d _ s e t c o d e */
END /* id_setcode */                                  /*---------------------*/
 
 
 
 
#ifdef LINT_ARGS                                      /*---------------------*/
global int id_getcode (idptr id)                      /* i d _ g e t c o d e */
#else
global int id_getcode (id)
  idptr id;
#endif
BEGIN (id_getcode)
  int  i;
 
  for (i=1; i<=act_code; i++) {
    if (id_code_table[i] == id)
      break;
  }
 
  if (i <= act_code)    /* idptr was found */
    return (i);         /* valid values are : 1...act_code */
  else
    return (0);         /* 0 means : not found */
 
                                                      /* i d _ g e t c o d e */
END /* id_getcode */                                  /*---------------------*/
 
 
 
#ifdef LINT_ARGS                                        /*-------------------*/
global idptr id_decod (int nr)                          /*  i d _ d e c o d  */
#else
global idptr id_decod (nr)
  int nr;
#endif
BEGIN (id_decod)
 
  if (nr <= act_code)
    return (id_code_table[nr]);
  else
    return (NULL);
                                                        /*  i d _ d e c o d  */
END /* id_decod */                                      /*-------------------*/
 
 
 
/*---------------------------------------------------------------------------*/
/*--------------         END OF MODULE  IMPORT.C        ---------------------*/
/*---------------------------------------------------------------------------*/
 
 
 
 
#ifdef CHECK
 
local void moddump (md)
modptr md;
BEGIN (moddump)
 
  printf ("\n");
  while (md) {
    printf ("      modname:  %-8s ", md->name);
    printf (" usglob: %d   inited: %d", md->usglob, md->inited);
    printf ("\n");
    md = md->next;
  }
  printf ("\n");
 
END  /*moddump*/
 
 
 
local void initdump (ip)
iniptr ip;
BEGIN (initdump)
 
  printf ("\n");
  while (ip) {
    printf ("       init-modname: %-8s ", (ip->md)->name);
    printf ("\n");
    ip = ip->next;
  }
  printf ("\n");
 
END  /*initdump*/
 
 
#endif



#ifdef LINT_ARGS                                        /*-------------------*/
global char *iroutname (char *modname)                  /* i r o u t n a m e */
#else
global char *iroutname (modname)
  char *modname;
#endif
BEGIN (iroutname)
 
  static char buffer[FILENAME_MAX+1];
  register char *p;

  p = buffer;
  *p++ = *modname;
  *p++ = '0';
  *p++ = '0';

  while (*++modname) 
    *p++ = *modname;
  *p = '\0';

  if (namelength != 0)
    buffer[namelength] = '\0';

  return ((char*) buffer);

END  /* iroutname */
