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

 
 *  uli 03.01.91 : moduniquename move to idtab.c
 *  BB  17.01.91 : #include "import.h"
 *  BB  19.01.91 : LINT_ARGS-switch in function-definitions
 *                 static (= 'local') at function-declarations removed
 *                 descriptions of local and global functions are now
 *                      included directly above their definition
 *  BB  21.01.91 : igenconst has changed, constants are already evaluated
 *                      by decl.c, thus another check and evaluation in
 *                      igenconst is not neccessary.
 *  BB  22.01.91 : paramkind returns now a character-value
 *                 functions and procedures as parameters are now possible
 *                 new local functions :
 *                      igenoper evaluates Operator-declarations
 *                      igenfupa handles functions in parameterlists
 *                 interface-syntax changed :
 *                      ')' and ';' in parameter-lists added.
 *  uli 4.2.91 : objmain added.
 *  uli 4.3.91 : export: compare of interface file corrected.
 *  uli 06.03.91 : export: del_extension replaced by prognam
 *  uli 16.04.91 : export: errornumber 30002 changed to 9459.
 *  uli 06.05.91 : "on_verbose or not os_verbose"
 *  uli 07.05.91 : igenconst: cLParD and cLParU added.
 *  uli 13.05.91 : igenconst: cMMinus and cCall added.
 *  uli 02.07.91 : export : tempfilename and del_temp added.
 *  uli 24.07.91 : export : intfile opened with "w+b".
 *  uli 18.09.91 : export : "interface has changed" with "!!"
 *  BB  11.12.91 : dynamic strings in table, C-name length is variable now
 *  uli 04.02.92 : TIMER requested.
 *  uli 06.04.92 : igenerate: case cBEGIN: no null char behind iroutname
 *  LS  14.08.92 : change interface file comparison, so that the comparison
                   will also work under IBM-CMS.
 *  PJ  19.08.92 : Change type export, so that any hidden types will be
                   exported to avoid problems with importing of forward
                   referencing types
*/
 
#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 "import.h"
 
#include           "expor.t"
#include "export.h"
 
#include           "implemen.t"

 
/*---------------------------------------------------------------------------*/
 
local   char *  tempfilename = "modmod.tmp" ; /* used, when tmpfile failed */

local   FILE *  intfile = (FILE*)0;       /* pointer to Interface-file */
local   FILE *  lnkfile = (FILE*)0;       /* used by linklist()/reverse() */
 
local   binptr  elid;
local   binptr  eltyp;                    /* 2 buffers for binptr */
 
local   char    err_string[255];
 
/*---------------------------------------------------------------------------*/
 
#define bb_local local
   /* function-declarations with 'static' are sensless, */
   /* 'static' is correct at function-definitions.      */
 
#ifdef LINT_ARGS
 
bb_local   void     igenerate    (binptr);
bb_local   void     igenconst    (binptr);
bb_local   void     igentype     (binptr);
bb_local   void     igenoper     (binptr);
bb_local   void     igenparam    (binptr);
bb_local   void     igenfupa     (binptr);
bb_local   char     paramkind    (binptr);
bb_local   void     igenid       (binptr);
bb_local   void     igencodid    (binptr);
bb_local   void     igenopCid    (opptr);
bb_local   void     igenopPid    (opptr);
bb_local   void     igensym      (binptr);
bb_local   void     igenint      (longint);
bb_local   void     igenchar     (char);
bb_local   void     igenbyte     (char);
bb_local   void     igenstr      (char *);
bb_local   void     igenline     (void);
 
bb_local   void     reverse      (iniptr);
 
#else
 
bb_local   void     igenerate    ( );
bb_local   void     igentype     ( );
bb_local   void     igenconst    ( );
bb_local   void     igenfunc     ( );
bb_local   void     igenproc     ( );
bb_local   void     igenoper     ( );
bb_local   void     igenparam    ( );
bb_local   void     igenfupa     ( );
bb_local   char     paramkind    ( );
bb_local   void     igenid       ( );
bb_local   void     igencodid    ( );
bb_local   void     igenopCid    ( );
bb_local   void     igenopPid    ( );
bb_local   void     igensym      ( );
bb_local   void     igenint      ( );
bb_local   void     igenchar     ( );
bb_local   void     igenbyte     ( );
bb_local   void     igenstr      ( );
bb_local   void     igenline     ( );
 
bb_local   void     reverse      ( );
 
#endif
 
/*---------------------------------------------------------------------------*/
/*---------------------------------------------------------------------------*/
 
 
 
#ifdef LINT_ARGS                                            /*---------------*/
global void export (void)                                   /*  e x p o r t  */
#else
global void export ()
#endif
BEGIN (export)
  FILE   *oldfile;
  int     c,d;
  modptr  itself;
  char   *s;
  int     len;
  boolean time_err = false;
  boolean del_temp = false;   /* "has to delete temp. file */
 
#ifdef TIMER
  time_in (0);
#endif
 
  itself = (modptr) malloc(sizeof(struct modrec));
  if (itself == NULL)   
    memerror (pos) ;

  len = strlen (s = prognam());
  itself->name = (char*) malloc (len+1);
  if (itself->name != NULL)
    strcpy (itself->name, s);
  else
    memerror (pos);

  len = strlen (s = modfnam(s));
  itself->path = (char*) malloc (len+1);
  if (itself->path != NULL)
    strcpy (itself->path, s);
  else
    memerror (pos);
 
  oldfile = fopen (itself->path, "rb");
 
  if (not(oldfile)) {             /* old interface doesn't exist */
    if (on_verbose or not os_verbose) {
      printf ("exporting module %s\n", prognam());
      printf ("old interface-file not found\n");
    }
    intfile = fopen (intfnam(),"wb");
    if (intfile) {
      igenerate (binroot);        /* igen..   means output to interface-file */
      fclose (intfile);
      intfile = (FILE*)0;
      if (on_verbose or not os_verbose)
        printf ("Interface-file %s created\n", intfnam());
    }
    else {
      dskerror (pos, intfnam ());
      /*
       *  "Error in writing file ... --  Probably disk is full.
       *               Compilation aborted."
       */
    }
  }
  else {                          /* old interface found */
 
    if (on_verbose or not os_verbose) {
      printf ("exporting module %s\n", prognam());
      printf ("reading old interface-file %s\n", itself->path);
    }
 
    intfile = tmpfile ();
    if (not intfile) {  /* tmpfile failed */
      intfile = fopen (tempfilename, "w+b");
      if  (intfile)   del_temp = true ; /* named temp. file created */
       else {
	 dskerror (pos, tempfilename);
	 /*
	  *   "Error in creating temporary interface-file. Compilation aborted."
	  */
	 fclose (oldfile);
	 return ;
       }
    }

    igenerate (binroot);
 
    while ((c=fgetc(oldfile)) != '='  &&  c != EOF)
      do_nothing;                             /* skip modname */
    for (c=0; c<4; c++)                       /* get time of old file */
      fscanf (oldfile, "%d.", &(itself->time[c]));
    if (initlist) {
      initlast = initlist;                    /* saving initlist */
      while (initlist && not(time_err)) {
	if (initlist->md->direct)
	  time_err = timecheck (itself, initlist->md);
	initlist = initlist->next;
      }
      initlist = initlast;
    }
 
    rewind (intfile);
    while ((c=fgetc(intfile)) != '\n'  &&  c != EOF)   /* skip first line */
      do_nothing;                                      /* in both files : */
    while ((c=fgetc(oldfile)) != '\n'  &&  c != EOF)   /* name of module  */
      do_nothing;                              /* and time of last change */
 
    do {
      if ((c=fgetc(intfile)) != (d=fgetc(oldfile)))      break;
    } while (c != EOF and d != EOF);

    /* L.S. 14.08.92 :  Additonal scan for IBM-CMS systems.
                        Scan trailing zeros in input record
                        until EOF is found.
                        Does not affect other systems.       */

    if ( c != d && c == EOF )
    {     /* scan old interface file until EOF or d != '\0' */
      while ( ( d = fgetc( oldfile ) ) == '\0' );
    }

    /* END L.S. 14.08.92 */
 
    if ( c != d ) {
					  /* Different contents */
      if (on_verbose or not os_verbose)
	printf ("!! Interface has changed !!\n");
      fclose (oldfile);
      oldfile = fopen (intfnam(), "wb");
      if (oldfile) {
	rewind (intfile);
	while ((c=fgetc(intfile))!=EOF)
	  fputc (c, oldfile);
	fclose (oldfile);
	fclose (intfile);
	intfile = (FILE*)0;
	if  (del_temp)  remove (tempfilename) ;
	if (on_verbose or not os_verbose)
	  printf ("Interface-file %s updated\n", intfnam());
      }
      else {
	dskerror (pos, intfnam ());
	/*
	 *  "Error in writing file ... --  Probably disk is full.
	 *               Compilation aborted."
	 */
      }
    }
    else if (time_err) {
      if (on_verbose or not os_verbose) {
	printf ("Interface has not changed\n");
      }
      fclose (oldfile);
      oldfile = fopen (intfnam(), "wb");
      if (oldfile) {
	rewind (intfile);
	while ((c=fgetc(intfile))!=EOF)
	  fputc (c, oldfile);
	fclose (oldfile);
	fclose (intfile);
	intfile = (FILE*)0;
	if  (del_temp)  remove (tempfilename) ;
	if (on_verbose or not os_verbose)
	  printf ("Timestamp: Interface-time updated\n");
      }
      else {
	dskerror (pos, intfnam ());
	/*
	 *  "Error in writing file ... --  Probably disk is full.
	 *               Compilation aborted."
	 */
      }
    }
    else {
      if (on_verbose or not os_verbose)
	printf ("Interface has not changed\n");
 
      fclose (intfile);
      if  (del_temp)  remove (tempfilename) ;
      intfile = fopen (intfnam(), "rb");
      if (not intfile) {        /* no interface-file in output-directory */
	if (on_verbose or not os_verbose)
	  printf ("writing interface-file to output-directory\n");
	intfile = fopen (intfnam(), "wb");
	if (intfile) {
	  rewind (oldfile);
	  while ((c=fgetc(oldfile))!=EOF)
	    fputc (c, intfile);
	}
	else {
	  dskerror (pos, intfnam ());
	  /*
	   *  "Error in writing file ... --  Probably disk is full.
	   *               Compilation aborted."
	   */
	}
      }
      fclose (oldfile);
      fclose (intfile);
      oldfile = (FILE*)0;
      intfile = (FILE*)0;
    }
  }
 
#ifdef TIMER
  time_out (0, "export");
#endif                                                      /*  e x p o r t  */
END  /* export */                                           /*---------------*/
 
 
/*
 * to_export() : returns whether an identifier has to be exported or not.
 * ------------  function is used by module.c and by generate.c :
 * return = TRUE : output to Header-file
 *                 AND to interface-file
 * if false : output to C-code-file
 *            NOT to interface-file
*/
#ifdef LINT_ARGS                                        /*-------------------*/
global boolean  to_export (binptr p)                    /* t o _ e x p o r t */
#else
global boolean  to_export (p)
  binptr p;
#endif
BEGIN (to_export)
 
  return (id_is (binid(p), is_global)
       || op_is (binop(p), is_global));
                                                        /* t o _ e x p o r t */
END /* to_export */                                     /*-------------------*/
 
 
 
/*
 * igenerate() : scans the bintab tree and creates the interface-entries
 * ------------  or calls other routines for tree- and interface-handling.
 * The subtrees are scanned recursively, or where possible in loops.
 * igenerate is called by decl.c with the root of the bintab-tree as argument,
 * scans the whole tree and controls the complete generation of the interface-
 * file. When igenerate returns, the interface-file is completed.
 * igenerate handles the bintab-tree similiar to generate() in generate.c
 * to_export() indicates whether a declaration has to be exported or not,
 * thus this function is used to decide, if the subtree is scanned.
 *
 * In general Interface-Entries have the following form :
 * - a single character indicating the kind of entry : (T)ype, (V)ariable,
 *                                 (F)unction, (C)onstant, (P)rocedure, ...
 * - the PASCAL-name of the identifier as an uppercase-string
 * - the '=' (assign-) character
 * - the C-name of the identifier
 * - the ':' character and the value / declaration  or
 * - the '(' character and the list of parameters
 * Each entry is ended by the newline-character ('\n').
 *
 * c.f module.dok for detailed informations.
 *
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenerate (binptr p)                         /* i g e n e r a t e */
#else
local void igenerate (p)
  binptr p;
#endif
BEGIN (igenerate)
 
  switch (binsymc(p))  {
 
    case cMODULE :              /* this is the root-node of the bintab-tree. */
    {                           /* All initialisation has to be done here.   */
      time_t     t;             /* Also all output which may be done only    */
      time_t    *tp;            /* once.                                     */
      struct tm  i_time;
      struct tm *i_tp;
 
      code_reset ();            /* reset code-table for identifiers */
 
      if (id_is(binid(binleft(p)),stdmodule))
        igenbyte ('#');
      igenstr (prognam());
 
      igenstr ("  it=");                /* generate time into interface */
      tp = &t;                          /* time is used for checking    */
      time (tp);                        /* dependencies, e.g. timestamp */
      i_tp = localtime(tp);
      i_time.tm_year = i_tp->tm_year;
      i_time.tm_yday = i_tp->tm_yday;
      i_time.tm_hour = i_tp->tm_hour;
      i_time.tm_min  = i_tp->tm_min ;
      igenint  ((long int) i_time.tm_year);
      igenbyte ('.');
      igenint  ((long int) i_time.tm_yday);
      igenbyte ('.');
      igenint  ((long int) i_time.tm_hour);
      igenbyte ('.');
      igenint  ((long int) i_time.tm_min );
      igenbyte ('.');
 
      igenbyte (ACTUAL_VERSION);          /* one BYTE correspondending  */
      igenline ();              /* to the actual version-number of PXSC */
 
      if (initlist) {           /* initlist is the list of all the modules, */
        iniptr inibuf;          /* which are used by the actual module.     */
 
        inibuf = initlist;
        while (inibuf) {
          if (inibuf->md->direct) {
            if (inibuf->md->usglob)
              igenbyte ('U');
            else
              igenbyte ('u');
            igenstr  (inibuf->md->name);
            igenline ();
          }
          inibuf = inibuf->next;
        }
      }
 
#if 0
      if (idrconv || idruconv || idrdconv) {
        idptr rcid;
        char  rcbyte;
        int   i;
 
        for (i=1; i<=3; i++) {
          switch (i) {
            case 1 : rcid=idrconv;  rcbyte='='; break;  /* '*' not possible, */
            case 2 : rcid=idruconv; rcbyte='>'; break;  /* because '*' is */
            case 3 : rcid=idrdconv; rcbyte='<'; break;  /* FlagIndicator */
          }
          if (rcid && id_is(rcid,imported) == false) {
            igenbyte ('R');
            igenbyte (rcbyte);
            igenstr  (symtab(idsym (rcid)));   /* Real-conversion is defined */
            if (id_is(rcid,hasdyn) == true) {
              igenbyte (FlagIndicator);
              igenbyte (HasdynFlag);
            }
            igenbyte ('=');                     /* and was not imported. -->  */
            igenstr  (symtab(idcsym(rcid)));    /* Real-conversion is defined */
            igenline ();                        /* in the actual module and   */
          }                                     /* will be exported.          */
        }
      }
#else
      if (idrconv && id_is(idrconv,imported) == false) {
        igenbyte ('R');
        igenbyte ('=');
        igenstr  (symtab(idsym (idrconv)));     /* Real-conversion is defined */
        if (id_is(idrconv,hasdyn) == true) {
          igenbyte (FlagIndicator);
          igenbyte (HasdynFlag);
        }
        igenbyte ('=');                         /* and was not imported. -->  */
        igenstr  (symtab(idcsym(idrconv)));     /* Real-conversion is defined */
        igenline ();                            /* in the actual module and   */
      }                                         /* will be exported.          */
 
      if (idruconv && id_is(idruconv,imported) == false) {
        igenbyte ('R');
        igenbyte ('>');
        igenstr  (symtab(idsym (idruconv)));     /* Real-conversion is defined */
        if (id_is(idruconv,hasdyn) == true) {
          igenbyte (FlagIndicator);
          igenbyte (HasdynFlag);
        }
        igenbyte ('=');                         /* and was not imported. -->  */
        igenstr  (symtab(idcsym(idruconv)));     /* Real-conversion is defined */
        igenline ();                            /* in the actual module and   */
      }                                         /* will be exported.          */
 
      if (idrdconv && id_is(idrdconv,imported) == false) {
        igenbyte ('R');
        igenbyte ('<');
        igenstr  (symtab(idsym (idrdconv)));     /* Real-conversion is defined */
        if (id_is(idrdconv,hasdyn) == true) {
          igenbyte (FlagIndicator);
          igenbyte (HasdynFlag);
        }
        igenbyte ('=');                         /* and was not imported. -->  */
        igenstr  (symtab(idcsym(idrdconv)));     /* Real-conversion is defined */
        igenline ();                            /* in the actual module and   */
      }                                         /* will be exported.          */
#endif
 
      if (binsymc(binright(p)) == cBlkptr)
        igenerate (binright(binright(p)));
      else
        igenerate (binright(p));
    }
    igenstr ("END.");
    igenline ();
    break;
 
    case cBlkptr:
    /*igenerate (binleft (p));  /* not used, left of blkptr is nil */
      igenerate (binright(p));
    break;
 
    case cBEGIN :
      igenerate (binleft(p));   /* left are declarations */
 
      {        /* initialization-routine must be generated always */
        char *s;
        igenbyte ('I');
        s = iroutname(prognam());
        do {
          igenbyte (*s);
        } while (*(++s) != '\0'); /* 6.4.82: ++s instead of s++ */
        igenline ();
      }
    break;
 
    case cSemicolon :
      do {
        igenerate (binleft(p));
        p = binright (p);
      } while (binsymc(p) == cSemicolon);
      igenerate (p);
    break;
 
    case cUSE :                 /* 'use' and 'use global' already evaluated */
    case cGLOBAL :              /* flags in modlist are used for export */
      break;
 
    case cCONST :
      if (to_export(binleft(p))) {
        igenbyte ('C');
        igenid (binleft(p));
        igenbyte (':');
        igenconst (binright(p));
        igenline ();
      }
    break;
 
    case cTemptype :
    case cTYPE :
      if  (binsymc(binleft(p)) == cTemptype)
        igenbyte ('L');
      else if (id_is(binid(binleft(p)), globalglobal))
        igenbyte ('G');
      else if (id_is(binid(binleft(p)), is_global   ))
        igenbyte ('T');
      else
        /* PJ 19.08.92 : Export hidden type in any case ! */
        igenbyte( 'L' );

      /* Old version : Export hidden type only if it's "usedglobal"

      else if (id_is(binid(binleft(p)), usedglobal  ))
        igenbyte ('L');
      else
        break;

        End of old version
      */
 
      igencodid (binleft(p));
      igenbyte (':');
      igentype( binright( p ) );
      igenline ();
    break;
 
    case cVAR :
      if (to_export(binleft(p))) {
        igenbyte ('V');
        elid = binleft(p);
        igenid (elid);
        elid = binright(elid);
        while (binsymc(elid) == cIdlist) {
          igenbyte (',');
          igenid (elid);
          elid = binright(elid);
        }
        igenbyte (':');
        igentype( binright( p ) );
        igenline ();
      }
    break;
 
    case cPROCEDURE :
      if (binsymc (binright(p)) == cFORWARD)
        break;
      if (binsymc(binleft(p)) == cOpptr) {
        p = binleft(p);
        if (to_export(p))  {
          igenoper (p);
          igenline ();
        }
      }
      else if (to_export(binleft(p))) {
        igenbyte ('P');
        igenid (binleft(p));
        igenparam (idparlist(binid(binleft(p))));
        igenline ();
      }
    break;
 
    case cFUNCTION :
      if (binsymc (binright(p)) == cFORWARD)
        break;
      p = binleft(p);                   /* binleft(p) is cColon */
      if (to_export(binleft(p))) {      /* binleft(cColon) is idptr */
        igenbyte ('F');
        igenid (binleft(p));
        igenparam (idparlist(binid(binleft(p))));
        igenbyte (':');
        igencodid (binright (p));       /* result-type is identifier, */
        igenline ();                    /* nested types are not allowed. */
      }
    break;
 
    case cOPERATOR :
      if (binsymc (binright(p)) == cFORWARD)
        break;
      p = binleft(binleft(p));          /* binsymc(p) is now cOpptr */
      if (to_export(p)) {
        igenoper (p);
        igenline ();
      }
    break;
 
  } /* switch */
                                                        /* i g e n e r a t e */
END     /* igenerate */                                 /*-------------------*/
 
 
/*
 * igenconst() : is used to scan bintab-subtrees defining constants, and
 * ------------  is called e.g. to evaluate array-ranges and declarations
 * of constants.
 * real- and string-constants are exported as follows :
 * - one byte containing the length of the string or the amount of digits
 *       forming the real-constant.
 * - a string containing the constants
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenconst (binptr p)                         /* i g e n c o n s t */
#else
local void igenconst (p)
  binptr p;
#endif
BEGIN (igenconst)
 
  switch (binsymc(p)) {
 
    case cBcon:
      igenbyte ('b');
      igenbyte ((char) binvalue(p));
    break;
 
    case cIcon:
      igenbyte ('i');
      igenint  (binvalue(p));
    break;
 
    case cCcon:
      igenbyte ('c');
      igenbyte ((char) binvalue(p));
    break;
 
    case cRcon:
      igenbyte ('r');
      igenbyte ((char) strlen(bincharp(p)));
      igenstr  (bincharp(p));
    break;
 
    case cLParD :  case cLParU:  case cMMinus:  case cCall:
      igenbyte ('r');
      igenbyte ((char) 0);   /* do not write rounded or signed constant */
      igenstr  ("");
    break;
 
    case cScon:
      igenbyte ('s');
      igenbyte (strlen(bincharp(p)));
      igenstr  (bincharp(p));
    break;
 
    default:
      if (sym_is [binsymc(p)].identifier)
        igenconst (unname(p));
      else {
        strcpy (err_string, "igenconst");
        errput (9455, binpos(p), err_string);
        /*
         *   "error occured in igenconst"
         */
      }
    break;
 
  } /* switch */
                                                        /* i g e n c o n s t */
END  /* igenconst */                                    /*-------------------*/
 
 
 
/*
 * igentype() : generates the right sides of type-declarations.
 * -----------  Each predefined PASCAL-SC type is coded by a single
 * printable character :
 *   '|'   means FILE
 *   '^'   means ARROW or pointer
 *   '['   means ARRAY   (if next character is another '[', the ARRAY
 *                           is dynamic, else its a static ARRAY)
 *   '&'   means RECORD
 *   '}'   means SET
 *   ...
 *
 * The not-printable characters (0..31) are used to indicate the export
 * of coded named types. Not-coded Identifiers (forward-references) are
 * exported as a string which contains the PASCAL-name.
*/

#ifdef LINT_ARGS                   /*-------------------*/
local void igentype( binptr typ )  /*  i g e n t y p e  */
#else
local void igentype( typ )
  binptr  typ;
#endif
BEGIN (igentype)
 
if  (typ == NIL) return ;
switch (binsymc(typ)) {
 
  case cSemicolon :
    do {  /* repeat */
      igentype( binleft( typ ) );
      typ = binright(typ);
      igenbyte (';');
    } while (binsymc(typ) == cSemicolon);
    igentype( typ );
  break;
 
  case cTemptype :
    igencodid (typ);
  break;
 
  case cIdlist  :
  case cCsymbol :
  case cRecelem :
 
    if (binsymc(typ) == cIdlist)
      igenid (typ);
    else
      igensym (typ);
 
    while ((binsymc(typ=binright(typ)) == cIdlist)
        or (binsymc(typ) == cCsymbol)
        or (binsymc(typ) == cRecelem))  {
      igenbyte (',');
      if (binsymc(typ) == cIdlist)
        igenid (typ);
      else
        igensym (typ);
    }
    igenbyte (':');
    igentype( typ );
  break;
 
  case cLParent :
    igenbyte ('(');
    typ=binright(typ);
    igenid (typ);
    do {
      igenbyte (',');
      typ=binright(typ);
      igenid (typ);
    } while (binsymc(binright(typ)) == cIdlist);
    igenbyte (')');
  break;
 
  case cFILE :
    igenbyte ('|');
    igentype( binright( typ ) );
  break;
 
  case cArrow :
    igenbyte ('^');
    igentype( binright( typ ) /* , FALSE */ );
  break;
 
  case cArry :
    if (id_is (binid(typ), dynamic)
    or binsymc(iddatyp(binid(typ)))==cDYNAMIC) {
      igenid (typ);
    }
    else {
      igenstr  ("[***");        /* b_stop ??? */
      igentype( unname( binleft( typ ) ) );            /* Index-range */
      eltyp = binright(typ);
      while (binsymc(eltyp) == cARRAY) {
        igenbyte (';');
        igentype( unname( binleft( eltyp ) ) );
        eltyp = binright(eltyp);
      }
      igenbyte (']');
      igentype( eltyp );
    }
  break;
 
  case cARRAY :
    igenbyte ('[');
    igentype( unname( binleft( typ ) ) );            /* Index-range */
    eltyp = binright(typ);
    while (binsymc(eltyp) == cARRAY) {
      igenbyte (';');
      igentype( unname( binleft( eltyp ) ) );
      eltyp = binright(eltyp);
    }
    igenbyte (']');
    igentype( eltyp );
  break;
 
  case cRECORD :
    igenbyte ('&');
    igentype( binleft( typ ) ); /* constant part of record declaration */
    if (binright(typ))
      igentype( binright( typ ) );   /* variant part of record declaration */
    igenbyte ('!');                  /* a call of igentype to generate the */
  break;                             /* variant part is possible because   */
                                     /* the case-statement is not exported */
  case cCASE :
    igenbyte ('?');
    igensym (binleft(typ));     /* left is cSymbol of C-union-id */
    igenbyte ('?');
    while (binsymc(typ=binright(typ)) == cSemicolon) {
      if (binsymc(binleft(typ)) == cColon) {
        igensym (binleft(binleft(typ)));  /* left is cSymbol of C-struct-id */
        igenbyte ('(');
        igentype( binright( binleft( typ ) ) ); /* const-part of 'sub'-record */
        igenbyte (')');
      }
      else if (binsymc(binleft(typ)) == cELSE) {
        igensym (binleft(binleft(typ)));  /* left is cSymbol of C-struct-id */
        igenbyte ('=');
        igenbyte ('(');
        igentype( binright( binleft( typ ) ) ); /* const-part of 'sub'-record */
        igenbyte (')');
      }
      else {
	sprintf(err_string, "%s (%d)", symptext[binsymc(typ)], binsymc(typ));
        errput (9452, pos, err_string);
        /*
         *  "unexpected case-label ... found"
         */
      }
    }
    if (binsymc(typ) == cColon) {
      igensym (binleft(typ));  /* left is cSymbol of C-struct-id */
      igenbyte ('(');
      igentype( binright( typ ) );    /* const-part of 'sub'-record */
      igenbyte (')');
    }
    else if (binsymc(typ) == cELSE) {
      igensym (binleft(typ));  /* left is cSymbol of C-struct-id */
      igenbyte ('=');
      igenbyte ('(');
      igentype( binright( typ ) );    /* const-part of 'sub'-record */
      igenbyte (')');
    }
    else {
      sprintf(err_string, "%s (%d)", symptext[binsymc(typ)], binsymc(typ));
      errput (9452, pos, err_string);
      /*
       *  "unexpected case-label ... found"
       */
    }
  break;
 
  case cTill :
    {
      binptr temp = binleft(typ);
 
      if (binsymc(temp) == cCall) {
        do_nothing;
      }
      else {
        igenbyte (':');
        igenconst (temp);
      }
 
      temp = binright (typ);
 
      if (binsymc(temp) == cCall) {
        do_nothing;
      }
      else {
        igenbyte (',');
        igenconst (temp);
      }
    }
  break;
 
  case cDYNAMIC :
    igenstr ("[[");                           /* Different to static */
    if (binleft(typ))
      igentype( binleft( typ ) );                /* Index-Grenzen */
    else
      igenbyte ('*');
    eltyp = binright(typ);
    while (binsymc(eltyp) == cDYNAMIC) {
      igenbyte (';');
      if (binleft(eltyp))
        igentype( binleft( eltyp ) );
      else
        igenbyte ('*');
      eltyp = binright(eltyp);
    }
    igenbyte (']');
    igentype( eltyp );
  break;
 
  case cSET :
    igenbyte ('}');
    igentype( binright( typ ) );        /* b_stop igentype */
  break;
 
  case cOPERATOR :
    errput (9453, pos, NULL);           /* b_stop ??? */
    /*
     *  "an Operator is not a type"
     */
  break;
 
  case cNosym :
    strcpy (err_string, "cNosym");
    errput (9454, pos, err_string);
    /*
     *  "igentype : cNosym found"
     */
  break;
 
  default :
    if (sym_is [binsymc(typ)].identifier)
      igencodid (typ);
    else {
      strcpy (err_string, symptext[binsymc(typ)]);
      errput (9454, pos, err_string);
      /*
       *  "igentype : ... found"
       */
    }
  break;
 
}  /* switch */
                                                        /*  i g e n t y p e  */
END   /* igentype */                                    /*-------------------*/
 
/*
 * igenfupa() : evaluates functions (and procedures) in parameterlists.
 * -----------  igenfupa is called by igenparam(). The only difference
 * between function-definitions and functions in parameterlists is the
 * missing function-name in parameterlists.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenfupa (binptr p)                          /*  i g e n f u p a  */
#else
local void igenfupa (p)
  binptr p;
#endif
BEGIN (igenfupa)
 
  igenparam (binleft(p));                /* p = cColon or cPROCEDURE */
                                         /* binleft(p) is the parameterlist. */
  if (binsymc(p) == cColon) {
    igenbyte (':');
    igencodid (binright (p));            /* result-type is an identifier */
  }
                                                        /*  i g e n f u p a  */
END   /* igenfupa */                                    /*-------------------*/
 
 
/*
 * igenoper() : evaluates Operator-declarations.
 * -----------
 * only three different kinds of Operators are possible :
 * - assign-Operator :
 *       Operator-symbol and priority equals Standart-assign
 *       always dyadic, left parameter is var-parameter
 *       no result
 *       only C-symbol, no PASCAL-symbol
 * - named Operator :
 *       PASCAL-symbol is identifier
 *       PASCAL- and C-symbol are to be exported
 *       priority must be declared via changing Operator's
 *       symcode to standart-Operator with same priority
 * - symbolic Operators :
 *       only C-symbol, no PASCAL-symbol
 *       Operator-symbol and priority are equal to a standart-Operator
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenoper (binptr p)                          /*  i g e n o p e r  */
#else
local void igenoper (p)
  binptr p;
#endif
BEGIN (igenoper)
  opptr   op;
  binptr  par1;
  binptr  par2;
 
  igenbyte ('O');                      /* 'O' indicates Operator-declaration */
  op = binop (p);
 
  if (opsymc(op) == cAssign) {        /* Assign-Operator, symbol always ':=' */
    igenbyte ('a');                   /* has no PASCAL-symbol, only C-symbol */
    igenopCid (op);                   /* is written onto the interface-file. */
  }
  else if (oppsym(op) != symNIL) {            /* Operator's PASCAL-symbol is */
    igenbyte ('i');                                      /* an (i)dentifier. */
    igenbyte (opsymc(op) - cAssign);    /* opsymc(op) indicates the priority */
    igenopPid (op);                   /* Operator has PASCAL- and C-symbol,  */
    igenbyte ('=');                   /* both are written onto the interface */
    igenopCid (op);
 
                         /* opsymc() returns Operator's priority, which must */
                         /* be the standart-Operator with the same priority. */
                              /* if the initial symcode cIdent is unchanged, */
                                                /* no priority was declared. */
    if (opsymc(op) == cIdent) {
      errput (4101, binpos(p), symtab(oppsym(op)));
      /*
       *  "no priority declared for Operator ..."
      */
    }
  }
  else if (sym_is [opsymc(op)].Operator) {           /* Operator's symbol is */
    igenbyte ('o');                           /* standart (o)perator-symbol, */
    igenbyte (opsymc(op) - cAssign);        /* which indicates the priority. */
    igenopCid (op);                         /* Operator has only a C-symbol. */
  }
 
  p = binright (p);                       /* p points now to the parameters. */
 
  if ((binsymc(p) == cIdlist)                      /* dyadic Operator, both  */
  and (binsymc(binright(p)) == cIdlist)) {         /* parameters of the same */
    par1 = binright(binright(p));              /* type. The right son of the */
    par2 = par1;                          /* second cIdlist-node is the type */
  }
  else if (binsymc(p) == cSemicolon) {      /* dyadic Operator, cSemicolon's */
    par1 = binright(binleft(p));          /* left and right son are cIdlist. */
    par2 = binright(binright(p));      /* their right sons define the types. */
  }
  else {                                                 /* monadic Operator */
    par1 = binright(p);                 /* binsymc(p) is cIdlist, it's right */
    par2 = NULL;                    /* son defines the type. Only one param. */
  }
                              /* varpl indicates var-parameter on Operator's */
                              /* left side, varpr on Operator's right side.  */
  igenbyte ('(');                                /* starts the parameterlist */
  if (par2)
    igenbyte (op_is(op,varpl) ? 'R' : 'V');       /* call by Reference/Value */
  else
    igenbyte (op_is(op,varpr) ? 'R' : 'V');       /* call by Reference/Value */
                                                  /*  for monadic Operator   */
  igencodid (par1);                               /* type of first parameter */
  if (par2) {
    igenbyte (';');                                   /* parameter separator */
    igenbyte (op_is(op,varpr) ? 'R' : 'V');       /* call by Reference/Value */
    igencodid (par2);                            /* type of second parameter */
  }
  igenbyte (')');                                  /* ends the parameterlist */
 
  if (opsymc(op) != cAssign) {                /* Assign is the only Operator */
    igenbyte (':');                                       /* without result. */
    igencodid (opresult(op));
  }
                                                        /*  i g e n o p e r  */
END   /* igenoper */                                    /*-------------------*/
 
 
 
/*
 * igenparam() : evaluates parameterlists of functions, procedures and
 * ------------  Operators. Only the kind and the type of the parameters
 * are exported, not their actual name.
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenparam (binptr p)                         /* i g e n p a r a m */
#else
local void igenparam (p)
  binptr p;
#endif
BEGIN (igenparam)
  int kind;
 
  igenbyte ('(');       /* start of parameterlist */
 
  if (p) {                              /* evaluate first parameter */
    kind = paramkind (p);
    if (kind == 'F')                    /* parameter is a (F)unction */
      igenfupa (binleft(p));            /* binleft = cColon */
    else if (kind == 'P')               /* parameter is a (P)rocedure */
      igenfupa (p);
    else                                /* parameter has a type. */
      igencodid (p);
  }
  while ((p=binright(p)) != NULL) {     /* all following parameters are */
    igenbyte (';');                     /* separated by Semicolons. */
    kind = paramkind (p);
    if (kind == 'F')                    /* parameter is a (F)unction */
      igenfupa (binleft(p));            /* binleft = cColon */
    else if (kind == 'P')               /* parameter is a (P)rocedure */
      igenfupa (p);
    else                                /* parameter has a type */
      igencodid (p);
  }
 
  igenbyte (')');       /* end of parameterlist */
                                                        /* i g e n p a r a m */
END  /* igenparam */                                    /*-------------------*/
 
 
/*
 * paramkind() : evaluates the kind of parameters, writes one character
 * ------------  indicating this kind directly onto the interface-file
 * and returns the indicator :
 * 'V'  : parameter is called by (V)alue
 * 'R'  : parameter is called by (R)eference
 * 'F'  : parameter is a (F)unction
 * 'P'  : parameter is a (P)rocedure
 * 'D'  : (D)efault, unknown kind
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local char paramkind (binptr p)                         /* p a r a m k i n d */
#else
local char paramkind (p)
  binptr p;
#endif
BEGIN (paramkind)
  char   kind;
 
  switch (binsymc(p)) {
    case cIdlist     : kind = 'V';      break;
    case cVarparam   : kind = 'R';      break;
    case cFUNCTION   : kind = 'F';      break;
    case cPROCEDURE  : kind = 'P';      break;
    default          : kind = 'D';      break;
  }
 
  igenbyte (kind);
 
  return (kind);
                                                        /* p a r a m k i n d */
END  /* paramkind */                                    /*-------------------*/
 
 
/*
 * igenid() : is used on identifiers which are exported as strings
 * ---------  without getting coded. (names of functions, procedures,
 * variables, ...) If these identifiers are not renamed (PASCAL-symbol
 * and C-symbol are identical) the symbol will be placed onto interface-
 * file only once. '=' indicates the end of the PASCAL-symbol. If the
 * C-symbol is different, the second string is written, else nothing.
*/
#ifdef LINT_ARGS                                            /*---------------*/
local void igenid (binptr id)                               /*  i g e n i d  */
#else
local void igenid (id)
  binptr id;
#endif
BEGIN (igenid)
 
  igenstr  (symtab(idsym(binid(id))));                /* write PASCAL-symbol */
  if (id_is(binid(id), hasdyn) == true) {
    igenbyte (FlagIndicator);
    igenbyte (HasdynFlag);
  }
  igenbyte ('=');                                     /* write delimiter     */
  if (idcsym(binid(id)) != idsym(binid(id))) {        /* different symbols ? */
    igenstr  (symtab(idcsym(binid(id))));             /*      write C-symbol */
  }
                                                            /*  i g e n i d  */
END  /* igenid */                                           /*---------------*/
 
 
/*
 * igencodid() : is used to export identifiers which are or have to become
 * ------------  coded. (esp. type-names)
 * id_getcode() returns the byte-code of an identifier or 0 if identifier
 * is not yet coded. An existing byte-code is put onto interface-file.
 *
*/
#ifdef LINT_ARGS                                        /*-------------------*/
local void igencodid (binptr p)                         /* i g e n c o d i d */
#else
local void igencodid (p)
  binptr p;
#endif
BEGIN (igencodid)
  int    c;
 
  if (binsymc(p) == cTemptype) {
    idptr  id;
 
    id = idfnd (binsym(p));
    if (not id) {
      id = idins (binsym(p), IDNONE);
      idfset (id, hidden) ;
    }
    if (not id) {
      printf ("error in creating idptr\n");
    }
    p = binidcreate (cIdent, id);
  }
 
  c = id_getcode (binid(p));
 
  if (c) {                    /* identifier is already coded */
    igenbyte (1);
    igenbyte (c);
  }
  else {                      /* forward-reference or imported types */
    igenid (p);               /* put identifier to interface-file as string, */
    id_setcode (binid(p));    /* make entry for next reference */
  }
                                                        /* i g e n c o d i d */
END  /* igencodid */                                    /*-------------------*/
 
 
 
 
 
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenopCid (opptr op)                         /* i g e n o p C i d */
#else
local void igenopCid (op)
  opptr op;
#endif
BEGIN (igenopCid)
 
  igenstr (symtab(opcsym(op)));
                                                        /* i g e n o p C i d */
END  /* igenopCid */                                    /*-------------------*/
 
 
 
 
#ifdef LINT_ARGS                                        /*-------------------*/
local void igenopPid (opptr op)                         /* i g e n o p P i d */
#else
local void igenopPid (op)
  opptr op;
#endif
BEGIN (igenopPid)
 
  igenstr (symtab(oppsym(op)));
                                                        /* i g e n o p P i d */
END  /* igenopPid */                                    /*-------------------*/
 
 
 
 
#ifdef LINT_ARGS                                            /*---------------*/
local void igensym (binptr sy)                              /* i g e n s y m */
#else
local void igensym (sy)
  binptr sy;
#endif
BEGIN (igensym)
 
  igenstr (symtab(binsym(sy)));
                                                            /* i g e n s y m */
END  /* igensym */                                          /*---------------*/
 
 
 
 
 
#ifdef LINT_ARGS                                            /*---------------*/
local  void igenstr (char *str)                             /* i g e n s t r */
#else
local  void igenstr (str)
  char *str;
#endif
BEGIN (igenstr)
 
  fprintf (intfile, "%s", str);
                                                            /* i g e n s t r */
END  /* igenstr */                                          /*---------------*/
 
 
 
#ifdef LINT_ARGS                                            /*---------------*/
local void igenint (long int i)                             /* i g e n i n t */
#else
local void igenint (i)
  long int i;
#endif
BEGIN (igenint)
 
  fprintf (intfile, "%ld", i);
                                                            /* i g e n i n t */
END  /* igenint */                                          /*---------------*/
 
 
#ifdef LINT_ARGS                                          /*-----------------*/
local void igenchar (char c)                              /* i g e n c h a r */
#else
local void igenchar (c)
  char c;
#endif
BEGIN (igenchar)
 
  igenbyte ('\'');              /* a single character c is exported as 'c' */
  igenbyte (c);                 /* the character ' is exported as '''' */
  if (c == '\'')
    igenbyte ('\'');
  igenbyte ('\'');
                                                          /* i g e n c h a r */
END  /* igenchar */                                       /*-----------------*/
 
 
#ifdef LINT_ARGS                                          /*-----------------*/
local void igenbyte (char b)                              /* i g e n b y t e */
#else
local void igenbyte (b)
  char b;
#endif
BEGIN (igenbyte)
 
  fputc ((char) b, intfile);
                                                          /* i g e n b y t e */
END  /* igenbyte */                                       /*-----------------*/
 
 
 
#ifdef LINT_ARGS                                          /*-----------------*/
local void igenline (void)                                /* i g e n b y t e */
#else
local void igenline ()
#endif
BEGIN (igenline)
 
  fputc ('\n', intfile);
                                                          /* i g e n b y t e */
END /* igenline */                                        /*-----------------*/
 
 
 
 
#ifdef LINT_ARGS                                          /*-----------------*/
local void reverse (iniptr p)                             /*  r e v e r s e  */
#else
local void reverse (p)
  iniptr p;
#endif
BEGIN (reverse)
 
  if (p) {
    reverse (p->next);
    fprintf (lnkfile, "%s\n", objfnam(p->md->path));
  }
                                                          /*  r e v e r s e  */
END  /* reverse */                                        /*-----------------*/
 
 
 
#ifdef LINT_ARGS                                          /*-----------------*/
global void linklist (void)                               /* l i n k l i s t */
#else
global void linklist ()
#endif
BEGIN (linklist)
 
  if (initlist) {
 
    lnkfile = fopen(lnkfnam(), "w");
    if (lnkfile) {
      fprintf (lnkfile, "%s\n", objmain()); /* object filename of main program */
      if (on_reverse) {
        reverse (initlist) ;
      }
      else {
        initlast = initlist;                /* saving initlist */
        while (initlist) {
          fprintf (lnkfile, "%s\n", objfnam(initlist->md->path));
          initlist = initlist->next;
        }
        initlist = initlast;                /* restoring initlist */
      }
      fclose (lnkfile);
    }
 
    else {
      dskerror (pos, lnkfnam());
      /*
       *   "Error in writing file ... --  Probably disk is full."
       *                   "Compilation aborted."
       */
    }
  }
                                                        /* l i n k l i s t */
END /* linklist */                                      /*-----------------*/
 
 
 
/*---------------------------------------------------------------------------*/
/*--------------         END OF MODULE  EXPORT.C        ---------------------*/
/*---------------------------------------------------------------------------*/
 
 
