/*  MODULE  :   generate.c
 *              generate  C-code
 *
{*  last modification:	11.11.92  16:52   }


 *  uli 19.11.90 : cTemptype and cTempused  added
 *  uli 22.11.90 : [ ] substituted by  cLBrack cRBrack
 *  uli 27.11.90 : cUntemp and VARUNTEMP  added
 *  uli 29.11.90 : VARFREE not called on mainlevel
 *  uli 03.01.91 : newname replaced by initname
		   module init.routine is (void) , if on_proto
		   (a_byte)  instead of  (byte)  will be generated
 *  uli 26.02.91 : generate: generated flag not set if forward
 *  uli 28.02.91 : genfuncdef: "initialize AS_name" only run till max
 *  uli 06.03.91 : requesting "hasdyn or imported",
		   ! has to be corrected in export.c and import.c
 *  uli 07.03.91 : generate: nonglobal mainlevel variables are static mow
 *  uli 07.03.91 : argdecl, bintabtrav and genptyp deleted.
 *  uli 07.03.91 : mergfin only called in genfin.
 *  uli 20.03.91 : genfuncdef: generate "extern", if forward and global
 *  uli 15.04.91 : genstring used when generating of "e_push"
 *  uli 16.04.91 : geninit: errorhandling improved.
 *      17.04.91 : a_local added.
 *  uli 29.04.91 : varlistloc: generates "d_init" instead of "=(d_otpr)0"
 *  uli 07.05.91 : gencdecl and gencasgn added.
 *  uli 08.05.91 : gencdecl: first declare REAL, if redefined.
 *  uli 13.05.91 : genpfree: hasdyn and dynamic will be checked.
 *  uli 21.05.91 : dclinam called to generate include directive.
 *  uli 29.05.91 : y_desc*  replaced by  y_dscp .
 *  uli 20.06.91 : genbody : assignment has no result
 *  uli 26.06.91 : genaddress: variable is right son of Arrow.
 *  uli 11.07.91 : gencdecl sets "generated" flag.
 *  uli 11.07.91 : generate "free" for all variables of main program.
 *  uli 18.07.91 : genfuncdef : parused-flag cleared, if displevel = 0.
 *  uli 18.07.91 : cast to (a_VOID) suppresses warnings of some C compilers
 *  uli 22.07.91 : genbody: cast (a_VOID) generated after ".adr = ".
 *  uli 30.07.91 : type_trav: variable "object" initialized.
 *                          : inner case cARRAY :
			      object == charptr1  or  object == charptr2
 *  uli 01.08.91 : gencdecl: unname surrounds rconstype .
 *  uli 15.08.91 : funcdef requests nogener flag.
 *  uli 15.08.91 : gen_init generates f_assg always, if non-main variable.
 *  uli 19.08.91 : funcdef : nogener replaced by nodecl.
 *  uli 18.09.91 : a_exit(a_RETC) added.
 *      21.08.91 : flag linkdispl invented to supress generation of
 *                 "..pred.." and "..adr.."
 *      21.08.91 : generated --> nodecl.
 *  uli 14.11.91 : initialisation : doesn't cut initname.
 *  uli 11.12.91 : type_trav : DYNAMIC : generate no ";" behind "for ()"
					 generate dim+1
    BB  11.12.91 : initname replaced by iroutname()
		   begin of initialisation changed.
 *  uli 13.12.91 : dnstructput : denesting of array var-parameters corrected.
 *  uli 03.01.92 : "return a_RETC" replaced by "return 0",
		   because a_RETC is a_intg now
 *  uli 10.01.92 : para_trav skips cCsymbol node after call of namechange
 *  uli 20.01.92 : defaulterr added.
 *  uli 22.01.92 : type_trav : cast (a_VOID) generated after "{ char *".
 * dima 27.01.92 : type_trav : Corrected records with dynamic components
 *  uli 17.02.92 : genbody: generate "return (a_VOID)", if array result.
 *  uli 30.04.92 : dntypeput: make names not unique, because already done by decl
 *  PJ  27.08.92 : should generate "p_init" instead of "f_init" due to conflict with
                   FORTRAN compilers  --> 11.11.92 : done
 * Dima 22.10.92 : type_trav: "or NEWINIT" is added for cDYNAMIC
 * Dima 22.10.92 : gen_init: Processing of full dynamic
                            (flexible) arrays is added
 *  PJ  30.03.95 : ctype.h included
 *  PJ  31.03.95 : type_trav: Changed assignments to weiter
                   Casts for ANSI compatibility added
 */

#undef  Error_Seek

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include           "impor.t"

#include "error.h"
#include "option.h"
#include "scan.h"
#include "symtab.h"
#include "idtab.h"
#include "optab.h"
#include "blktab.h"
#include "bintab.h"
#include "sysutil.h"
#include "module.h"
#include "genstm.h"
#include "std.h"

#include           "expor.t"
#include "generate.h"

#include           "implemen.t"

local FILE * buffer  = (FILE*)0;
local postype posnull= {0,0} ;  /* position of nodes created by generate */


local symptr *AS_name,    /* Type-names of structures */
	     AS_local,       /* Name of local structure. */
	     AS_temp,        /* Name of temporary variable used for saving */
			     /* a display variable. */
	     indexvar,       /* Nname of local index-variable. */
	     dnarray;
local boolean linkdispl;

local binptr charptr2,       /* Lokaler Character-Pointer. */
	     bina_VOID,
	     indirect;       /*   indirect  ->  .                        */
			     /*                / \                       */
			     /*               ^   membername             */
			     /*              /                           */
			     /*             )                            */
			     /*            / \                           */
			     /*           ^   name of pointer to record  */
			     /*          /                               */
			     /*      type                                */
			     /*                                          */
			     /* So genexpr (indirect) yields:            */
			     /*    ((type *) pointer)->membername;       */

local struct stack {
	    binptr binnode,     /* Name des Objektes oder */
				/* ein Komponententyp. */
		   membername;  /* Ist binnode vom Typ cRecord, dann   */
				/* zeigt membername auf ein Member.    */
	    struct stack *next;    /* Linked list! */
	 }
	   *top;                /* Zeigt auf den ersten unverarbeiteten */
				/* Eintrag im Stack.                    */

#ifdef LINT_ARGS

local   void    storage_class (boolean);
local   void    genfuncdef  (binptr);
local   boolean istempvar   (binptr p);
local   void    dnstructput (idptr id);
local   void    dntypeput   (binptr p);
local   void    genbody     (binptr p);
local   void    gen_init    (binptr, binptr, symctype);
local   void    gen_free    (binptr, symctype);
local   void    gen_vlcp    (binptr, symctype);
local   void    gen_temp    (binptr, symctype);
local   void    gen_utmp    (binptr, symctype);
local   void    varlistloc  (binptr,int);
local   void    swap        (binptr *, binptr *);
local   void    genaddress  (binptr);
local   void    type_trav   (binptr,struct stack *,int);
local   boolean genparinit  (binptr,binptr);
local   boolean genpfree    (binptr,binptr);
local   void    densubrout  (binptr);
local   boolean genarrydecl (binptr,binptr);

local   void    geninclude  (void);
local   void    initialisation (void);
			     /* Tells genline, that all source lines until */
			     /* at least line must be merged with code.    */
local   void     genPid      (binptr id);

#else

local   void    storage_class ();
local   void    genfuncdef  ();
local   boolean istempvar   ();
local   void    dnstructput ();
local   void    dntypeput   ();
local   void    genbody     ();
local   void    gen_init    ();
local   void    gen_free    ();
local   void    gen_vlcp    ();
local   void    gen_temp    ();
local   void    gen_utmp    ();
local   void    varlistloc  ();
local   void    swap        ();
local   void    genaddress  ();
local   void    type_trav   ();
local   boolean genparinit  ();
local   boolean genpfree    ();
local   void    densubrout  ();
local   boolean genarrydecl ();

local   void    geninclude  ();
local   void    initialisation ();
local   void    genPid      ( );

#endif

#if INTERMEDIATE
#ifdef LINT_ARGS
local void bintrkill  ( binptr bin)
#else
local void bintrkill (bin)
binptr bin;
#endif
{  if ( bin==NULL ) return;

   if ( binsymc (bin)==cRParent );
   else if ( binsymc (bin)==cAssign )
      bintrkill (binright (binleft (bin)));
   else
      bintrkill (binleft (bin));
   bintrkill (binright (bin));

   bin->father=bin->pt.left=bin->right=NULL;
   binkill (bin);
} /* bintrkill */
#endif



#ifdef LINT_ARGS
local void defaulterr (symctype s)
#else
local void defaulterr (s)
symctype s;
#endif
{	/* gen (" #");
	gen (symptext[s]);
	gen ("# ") */ ;
}



						/*-----------------------*/
#ifdef LINT_ARGS
local void dnstructput (  idptr id)
#else
local void dnstructput(id)                      /* d n s t r u c t p u t */
/* Generates member of denest-structure */
idptr id;
#endif
{  idkind kind;
   binptr typ = iddatyp(id) ;

   kind=idgetkind(id);
   if ( not id_is (id,innerused) ) return;

   if ( kind == IDVALPARAM or kind == IDVARPARAM or
	kind == IDPARAM ) {
       if ( kind == IDVARPARAM and id_is (id,arraytype) )
	{
	   do {
	     typ = binright(unname(typ));
	   } while (binsymc(unname(typ)) == cARRAY);
	 }
       gende_spec (typ);
       if ( kind == IDVARPARAM /* and not
	    id_is (id,arraytype) */ ) gen (" * ");
       gen (symtab (idcsym (id)));
       gen (";"); genline ();
       idfset(id,nodecl);
    } else
    if ( kind == IDVAR ) {
       binptr dummy=binidcreate(cIdent,id);
       /* gendecl (idbin(id),) fails because of cIdlist node ! */
       gendecl (dummy,iddatyp(id));
       binkill (dummy);
       idfset(id,nodecl);
    }

} /* dnstructput */

						/*-------------------*/
#ifdef LINT_ARGS
local boolean istempvar ( binptr p)
#else
local boolean istempvar(p)                      /* i s t e m p v a r */
binptr p;
#endif
{   symctype code;
    if ((code=binsymc(p))==cTempvar or
	code==cRegister or
	code==cTempused or
	code==cCsymbol) return true;
    else return false;
} /* istempvar */


						/*-------------------*/
#ifdef LINT_ARGS
local void dntypeput ( binptr p)
#else
local void dntypeput(p)                         /* d n t y p e p u t */
binptr p;
#endif
{
   idptr id;

   switch (binsymc(p)) {

     case cSemicolon:
	while (binsymc(binleft(p))==cSemicolon) p=binleft(p);

	while (binsymc(p)==cSemicolon) {
	   dntypeput (binleft(p));
	   p=binright (p);
	}
	if (p and not istempvar(p)) dntypeput (p);
	break;

     case cTYPE:
	 gen ("typedef ");

#ifdef OLD
	30.4.92
	 if ( binsymc (binleft (p))==cCsymbol  or
	      binsymc (binleft (p))==cTemptype )  /* Name is unique. */
#endif
	   { gendecl (binleft (p), binright (p));
	   }
#ifdef OLD
	30.4.92   already done by decl.c
	 else {
	    id=binid(binleft(p));      /* Make name unique. */
	    idsetcsym(id,uniquename("gt"));
	    p = binidcreate(cIdent,id) ;
	    binuppos (p, posnull) ;     /* enables merge */
	    gendecl(p,iddatyp(id));
	 /*   idfset(id,nodecl); */
	 }
#endif
	 break;

     default : ;   }
} /* dntypeput */

/*---------------------------------------------------*/

/*---------------------------------------------------*/



							  /*-----------------*/
#ifdef LINT_ARGS
global void geninit  ( void)
#else
global void geninit ()                                    /*  g e n i n i t  */
#endif
BEGIN (geninit)

  errline=0;
  dclfile=mrgfile=codfile=(FILE*)NULL;

  charptr1=bincreate(cArrow);
  binlside (charptr1,binsycreate (uniquename ("tp")));
  charptr2=bincreate(cArrow);
  binlside (charptr2,binsycreate (uniquename ("tp")));

  indirect=bincreate(cPoint);                     /* Build mini-tree */
  binlside (indirect,bincreate (cArrow));
  binlside (binleft (indirect), bincreate (cRParent));
  binlside (binleft (binleft (indirect)), bincreate (cArrow));

  indexvar=uniquename ("ix");

  if (on_terminal) codfile=stdout;
  else codfile = fopen(codfnam(),"w");
  if (not(codfile)) {
    errput (30002, pos, codfnam()) ;
    finish (-1) ;
    /* print ("not able to open outputfile "); */
  }
  buffer=codfile;
  if (on_merge) {
    mrgfile = fopen(srcfnam(),"r");
    if (not(mrgfile)) {
      errput (30005, pos, srcfnam()) ;
      /* print ("not able to open sourcefile "); */
    }
  }

  gen ("#include \"");
  gen (rtsfnam()) ;
  gen ("\"") ;
  genline ();

  if (ov_include and *ov_include) {
    gen ("#include \"");
    gen (ov_include), gen ("\"");
    genline ();
  }
  if (ov_real and *ov_real) {
    gen ("#include \"");
    gen (ov_real), gen("\"");
    genline ();
  }
  genline ();

   denestlevel = IDMAINLEVEL;
   disp_level = 0;

   bina_VOID = binsycreate (symins ("a_VOID"));
   AS_local  = uniquename("do");
   AS_temp   = uniquename("ds");
END /* geninit */                                         /*  g e n i n i t  */
							  /*-----------------*/

							  /*-----------------*/
#ifdef LINT_ARGS
global void genfin  ( void)
#else
global void genfin ()                                     /*   g e n f i n   */
#endif
BEGIN (genfin)

  mergfin ();

  if (codfile != stdout) {
    fclose (codfile);
    codfile = (FILE*)0;
  }

END  /* genfin */                                         /*   g e n f i n   */
							  /*-----------------*/


						    /*---------------------*/
#ifdef LINT_ARGS
global void gencdecl (void)                         /*   g e n c d e c l   */
#else
global void gencdecl()
#endif
		   /* generates declarations of the constant pool */
BEGIN (gencdecl)
  binptr p = bincpool ;

  if  (unname (rconstype) != realtype)  then   /* real is redefined */
   begin                              /* first declare real */
      gen ("typedef ");
      gendecl (rconstype, iddatyp (binid(rconstype)));
      idfset (binid(rconstype), nodecl) ;
   end

  while (binfather (p))   p = binfather (p) ;
  while (p)
   begin
     if  (binsymc(p) == cIdlist)
      begin
       if (dclfile  and  id_is(binid(p),is_global) ) {
	 codfile = dclfile;      /* umleitung der ausgabe in das dcl-file */
	 gen ("global ");
       }
       else
	 gen ("static ");      /* not "extern" */

       binchange (p, cIdent) ; /* pretend: not variable list */
       gendecl (p, iddatyp (binid(p)));
       idfset (binid(p), nodecl) ;
       binchange (p, cIdlist) ; /* reset symc */
       codfile = buffer;       /* ruecksetzen der ausgabe in das code-file */
      end
     else
       begin
	 gen ("# ") ;
	 gen (symptext [binsymc(p)]) ;
	 gen (" is unknown in gencdecl. #") ;
       end
     p = binnext (p) ;
   end
END /* gencdecl */                                  /*   g e n c d e c l   */
						    /*---------------------*/


						    /*---------------------*/
#ifdef LINT_ARGS
global void gencasgn (void)                         /*   g e n c a s g n   */
#else
global void gencasgn()
#endif
		   /* generates assignments of the constant pool */
BEGIN (gencasgn)
  binptr p = bincpool ;

  while (binfather (p))   p = binfather (p) ;
  while (p)
   begin
     if  (binsymc(p) == cIdlist)
      begin
	genCid (p) ;
	gen ("=") ;
	genexpr (unname(p));
	gen (";") ;
	genline() ;
      end
     else
       begin
	 gen ("# ") ;
	 gen (symptext [binsymc(p)]) ;
	 gen (" is unknown in gencasgn. #") ;
       end
     p = binnext (p) ;
   end
END /* gencasgn */                                  /*   g e n c a s g n   */
						    /*---------------------*/


						    /*---------------------*/
#ifdef LINT_ARGS
global void generate ( binptr p)
#else
global void generate(p)                             /*   g e n e r a t e   */
binptr p;
#endif
BEGIN (generate)
binptr   list;
idptr    tempid;

#ifdef Error_Seek
printf ("generate: %s\n", symptext[binsymc(p)]);
#endif

  if (not p)   return ;
  switch (binsymc(p))  {

      case cPROGRAM :
	  buffer = codfile;
	  mergtill(p);

#if INTERMEDIATE
	  if (initlist) {
	     geninclude ();
	     genline ();
	  }
#else
	  generate (binright(p));
#endif
      break;

      case cMODULE :
	  buffer = codfile;
	  mergtill(p);
	  if (on_terminal) dclfile=stdout;
	  else  dclfile=fopen(dclfnam(),"w");
	  if (not(dclfile)) {
	    errput (30002, pos, dclfnam()) ;
	    /* print ("not able to open headerfile "); */
	  }

#if INTERMEDIATE
	  if (initlist)
	    geninclude ();

	  gen ("#define global");
	  genline ();
	  gen ("#include \"");                /* include own declarations */
	  gen (dclinam());
	  gen ("\"");
	  genline ();
	  gen ("#undef global");
	  genline ();
	  genline ();
#else
	  generate (binright(p));
#endif
      break;

      case cBEGIN :
	if (binsymc(binfather(p)) == cPROGRAM ) {
	    binptr dummy=binidcreate(cIdent,NULL);

#if ! INTERMEDIATE
	    if (initlist) {
	       geninclude ();
	       genline ();
	    }

	    if (bincpool)  gencdecl () ;   /* generate constant pool */

	    list=binright(binleft(p));
	    while (binsymc(binleft(list))==cSemicolon) list=binleft(list);

      /*      generate non-temporary declarations only.     */
	    if ( binsymc(list)==cSemicolon and
		 istempvar(binright(list)) ) generate (binleft(list));
	    else generate (list);
#endif

	    genline ();

#ifdef Error_Seek
printf ("declarations complete \n");
#endif
	    if ( on_prototyp )
	       gen ("int main(int argc, char **argv)");
	    else {
	       gen ("int main(argc, argv)"); genline ();
	       gen ("int argc;");            genline ();
	       gen ("char **argv;");
	    }
	    genline (); gen ("{");
	    inctabs (); genline ();

	    list=binright(binleft(p));
	    while (binsymc(binleft(list))==cSemicolon)  /* generate temporary */
	       generate(binright(list)),                /* declarations only. */
	       list = binleft (list) ;

	    if ( binsymc(list)==cSemicolon and
		 istempvar(binright(list)) ) generate (binright(list));

	    if (on_number) {
		gen ("e_push (");
		genstring (symtab (binsym (binleft (binfather (p)))));
		gen (", ");
		genstring (srcfnam());
		gen (");"); genline ();
		gen ("e_line=");
		genint ((long) (errline=binpos(p).line) );
		gen (";"); genline ();
	    } /* e_push generated */

            /* PJ 27.08.92 : Conflict with FORTRAN compilers    */
            /*               f_init should be changed to p_init */
            /* PJ 11.11.92 : Done                               */

	    gen ("p_init (argc, argv);"); genline ();

	    list=binright(binleft(binfather(p)));   /* Start of program-parameter-list */

	    while (binsymc(list)==cIdlist or binsymc(list)==cIdent ) {
	       gen_init (list,NIL,cFILE);
	       list=binnext(list);
	    }

	    gen ("f_eofp ();"); genline ();

	    if ( not id_is(idINPUT,generated) ) {
	       binupid (dummy,idINPUT);
	       gen_init (dummy,NULL,cFILE);
	    }
	    if ( not id_is(idOUTPUT,generated) ) {
	       binupid (dummy,idOUTPUT);
	       gen_init (dummy,NULL,cFILE);
	    }

	    if (initlist)     initialisation ();

	    if (bincpool)  gencasgn () ;   /* generate constant pool */

	    varlistloc (binright (binleft (p)),VARINIT);

	    genstm (binright(p));               /* generate statements */

	    varlistloc (binright (binleft (p)),VARFREE);
#ifdef OLD
	    list=binright(binleft(binfather(p)));   /* Start of program-parameter-list */
	    while (binsymc(list)==cIdlist or binsymc(list)==cIdent ) {
	       gen_free (list,cFILE);
	       list=binnext(list);
	    }
#endif
	    if ( id_is(idINPUT,generated) ) {
	       binupid (dummy,idINPUT);
	       gen_free (dummy,cFILE);
	    }
	    if ( id_is(idOUTPUT,generated) ) {
	       binupid (dummy,idOUTPUT);
	       gen_free (dummy,cFILE);
	    }

	    gen ("a_exit(a_RETC); return 0;");
	    dectabs (); genline ();
	    gen ("}");
	    genline ();
	    binkill (dummy);
	}
	else if (binsymc(binfather(p))==cMODULE
	     or (binsymc(binfather(p))==cBlkptr and binsymc(binroot)==cMODULE))
	{

#if ! INTERMEDIATE
	    if (initlist)
	      geninclude ();

	    gen ("#define global  ");
	    genline ();
	    gen ("#include \"");                /* include own declarations */
	    gen (dclinam());
	    gen ("\"");
	    genline ();
	    gen ("#undef global");
	    genline ();
	    genline ();

	    if (bincpool)  gencdecl () ;   /* generate constant pool */

	    if (binsymc(binleft(p)) == cBlkptr)
	       generate (binright(binleft(p)));     /* generate declarations */
	    else
	       generate (binleft(p));              /* generate declarations */
	    genline ();
#endif

	    if (dclfile) {
	      codfile = dclfile;    /* umleitung der ausgabe in das dcl-file */
	      gen ("global void ");       /* initialsation-routine of module */
	      gen (iroutname(prognam()));              /* actual module name */
	      if (on_prototyp)
		gen ("(void);");
	      else
		gen ("();");
	      genline ();
	      codfile = buffer;       /* ruecksetzen des ausgabe-files */
	    }

	    gen ("extern void ");
	    gen (iroutname(prognam()));     /* init-rout of actual module */
	    if (on_prototyp)
	      gen ("(void)");
	    else
	      gen ("()");
	    genline ();
	    gen ("{");
	    inctabs (); genline ();

	    if (on_number) {
		gen ("e_push (");
		genstring (srcfnam());
		gen (", ");
		genstring (srcfnam());
		gen (");"); genline ();
		gen ("e_line=");
		genint ((long) (errline=binpos(p).line) );
		gen (";"); genline ();
	    } /* e_push generated */

	    if (bincpool)  gencasgn () ;   /* generate constant pool */

	    varlistloc (binright (binleft (p)),VARINIT);

	    genstm (binright(p));               /* generate statements */

	    if (on_number) {
	       gen ("e_popp ();");
	       genline ();
	    }

	    dectabs (); genline( );
	    gen ("}");  genline ();
	}
      break;

      case cSemicolon :
	do { /* repeat */
	  generate (binleft(p));
	 /* mergtill(p); */
	  p = binright(p);
	} while (binsymc(p) == cSemicolon);
	generate (p);
      break;

      case cUSE :   /* 'use' + 'use global' not used for generating C-code; */
      case cGLOBAL :    /* only used for creating module-interface */
      break;

      case cCONST :
       tempid=binid(binleft(p));
       IF  not on_rename  THEN
	if (to_export(binleft(p)) and dclfile)
	  codfile = dclfile;      /* umleitung der ausgabe in das dcl-file */
	mergtill(p);
	if ( tempid and not id_is(tempid,nodecl))
	{    genline (); gen ("#define ");
	     genCid (binleft(p));
	     gen (" ");
	     genexpr (binright(p));
	     genline ();
	}
	codfile = buffer;       /* ruecksetzen der ausgabe in das code-file */
       FI
      break;

      case cTYPE :
	if ( denestlevel>=IDSUBLEVEL ) break;    /* Already generated. */

	tempid=binid(binleft(p));  /* NULL, if left node is cTemptype. */
	mergtill(p);
	if  (dclfile and ( not tempid or
			   (id_is(tempid,is_global) or
			    id_is(tempid,globalglobal) or
			    id_is(tempid,usedglobal))))
	   codfile = dclfile;    /* umleitung der ausgabe in das dcl-file */

	gen ("typedef ");
	gendecl (binleft(p), binright(p));
	codfile = buffer;       /* ruecksetzen der ausgabe in das code-file */
      break;

      case cVAR :
	mergtill(p);

	if (dclfile  and  id_is(binid(binleft(p)),is_global) ) {
	  codfile = dclfile;      /* umleitung der ausgabe in das dcl-file */
	  gen ("global ");
	}
	else
	/*  if (idlevel (binid(binleft(p))) == IDMAINLEVEL)*/
	  if ( denestlevel == IDMAINLEVEL )
	    gen ("static ");      /* not "extern" */

	gendecl (binleft(p), binright(p));
	codfile = buffer;       /* ruecksetzen der ausgabe in das code-file */
      break;

      case cRegister :;
      case cTempvar :;
      case cTempused :
      case cCsymbol :
	if (binsymc(p)==cRegister) gen ("register ");
    /*    (void) gentyp (binright(p));
	gen (" "); gen (symtab(binsym(p)));
	gen (";"); genline();  */
	gendecl (p,binright (p));

      break;

      case cPROCEDURE :
      case cFUNCTION :
      case cOPERATOR :
	 if ( denestlevel==IDMAINLEVEL ) {    /* subroutine with file-scope */
	    static int mem_max=0;
	    if ( MAXDENLEVEL>mem_max ) {
					    /* previously allocated memory */
	       mem_max = MAXDENLEVEL+16;    /* for disp_name and AS_name   */
					    /* too small. */

	       disp_name=(symptr*) malloc(3*mem_max*sizeof(symptr));
	       if ( disp_name==NULL )   memerror (pos) ;

	       AS_name  = disp_name + mem_max;
	       disp_index = AS_name + mem_max;
	    }
	    linkdispl = blk_is (binblk (binleft (binright(p))), linkdispl);
	    genfuncdef (p);
	 }
      break;

      case cBlkptr :
	generate (binright(p));
      break;

      default :
          defaulterr (binsymc(p)) ;

      break;

  } /* switch */

END     /* generate */                              /*  g e n e r a t e  */

						  /*-----------------*/
#ifdef LINT_ARGS
local boolean namechange  (  binptr bin,binptr typ)
#else
local boolean namechange (bin, typ)                  /* */
/* Generate name of parameter.
*/
binptr bin;     /* name of parameter. */
binptr typ;
#endif
{
    idptr id;
    binptr temp;

    id=binid (bin);
    if ( id_is(id,arraytype) and not id_is(id,innerused) and
	 idgetkind(id)!=IDVARPARAM )
       bininsert (binright (bin), binsycreate (uniquename ("ar")));
    else
    if ( binsymc (typ)==cFUNCTION or
	 binsymc (typ)==cPROCEDURE ) {
       temp=binsycreate (uniquename ("ac"));
       binappend (typ, temp);
    }
    return false;
} /* namechange */


#ifdef LINT_ARGS
local void storage_class  (boolean isextern)
#else
local void storage_class (isextern)
boolean isextern;
#endif
{

	  if ( isextern )
	     gen ("extern ");
	  else if ( denestlevel-1 >= IDSUBLEVEL )
	     gen ("a_local ");
	  else
	     gen ("static ");
}
					       /*---------------------*/

					      /*---------------------*/
#ifdef LINT_ARGS
local void genfuncdef  (binptr p)
#else
local void genfuncdef (p)                     /* g e n f u n c d e f */
/*
 *
*/
binptr p;       /* cFUNCTION, cPROCEDURE or cOPERATOR. */
#endif
{
   symctype s;
   binptr body;
   boolean is_global = false;
   binptr rout;   /* rout. */

   rout = binleft(p);

   if ( binsymc(p)==cPROCEDURE and binop (rout) ) {
	if ( binop (rout) )
	   is_global = op_is (binop (rout), is_global);
   } else
   if ( binsymc(p)==cFUNCTION or binsymc(p)==cPROCEDURE ) {
	if ( binsymc(p)==cFUNCTION ) rout = binleft (rout);

	is_global = id_is (binid (rout), is_global);
	if  (disp_level<=0)
	  idfclr (binid (rout),parused) ;
   } else
   if ( binsymc(p)==cOPERATOR ) {
	rout = binleft (rout);
	is_global = op_is (binop (rout), is_global);
   }

   if (binid (rout) ? id_is (binid (rout), nodecl) :
		      op_is (binop (rout), nodecl) )   return ;

   body = binright(p);

	para_trav (binright (rout), namechange, 0);

	if (is_global and dclfile) {
	  codfile = dclfile;
	  binrlink (p,NIL);
	  gen ("global ");
	  decl (rout, p);
	  gen (";"), genline ();
	  binappend (p,body);
	  codfile = buffer;    /* ruecksetzen der ausgabe in das code-file */
	}

	mergtill(p);

   /* Generate all local types and all local constants. */
	dntypeput (binright (binleft (body)));

	s=binsymc (body);
	if ( s==cFORWARD  or  s==cEXTERNAL ) {
	   denestlevel++;
	   storage_class (binsymc (body)==cEXTERNAL or is_global);
	   denestlevel--;

	   decl (rout, p);
	   gen (";"), genline ();
	} else {
	   blockptr blk = binblk (binleft (body));
	   denestlevel++;
	   if ( blk_is (blk,innervar) ) disp_level++;

	   if ( blk_is (blk,innerrout) ) {
				    /* Subroutine has local subroutines. */
	      if ( not (is_global and dclfile) ) {
		 storage_class (is_global);
		 binrlink (p,NULL);
		 decl (rout, p);       /* Prototype only */
		 binappend (p,body);
		 gen (";"), genline ();
	      }
	      densubrout (p);
	   }

	   storage_class (is_global);
	   decl (rout, p);
	   genbody (body);
	   denestlevel--;
	   if ( blk_is (blk,innervar) ) disp_level--;
	}
} /* genfuncdecl */



/* PJ 07.01.93 : Checken ob temporaere Variable mit Bezeichner tp_nnn
                 vorliegt
*/

#ifdef LINT_ARGS
boolean is_tempvar( binptr varname )
#else
boolean is_tempvar( varname )
binptr varname;
#endif
{ char *entry;

  if ( binsymc( varname ) == cArrow )
  { entry = symtext( binsym( binleft( varname ) ) );
    if ( strlen( entry ) == 6 )
      return ( ( entry[ 0 ] = 't' ) && ( entry[ 1 ] = 'p' )
               && ( entry[ 2 ] = '_' ) && isdigit( entry[ 3 ] )
               && isdigit( entry[ 4 ] ) && isdigit( entry[ 5 ] ) );
    else
      return false;
  }
  else
    return false;
}

/* END PJ 07.01.93 */


						    /*-----------------*/
#ifdef LINT_ARGS
local void gen_init(  binptr name,binptr typ,symctype symc)
#else
local void gen_init(name,typ,symc)                  /* g e n _ i n i t */
/* Generate initialization of variable.
 *   typ is type.
 * name must contain name of variable.
 */
binptr name;
binptr typ;
symctype symc;
#endif
{
  binptr p;
  /* PJ 07.01.93 */
  gen( "{ " );
  inctabs( );
  /* END PJ 07.01.93 */
  switch ( symc ) {
    case cDYNAMIC: {
       binptr eltype,indexvar;
       byte dim=0;
       boolean not_flex=true; /*Flag: if the array is flexible */
       binptr indexrange;

       eltype=indexvar=typ;

       /* P.J. 20.9.94  set not_flex explicitely because of strange
                        behaviour of the SUN-cc compiler             */

       indexrange = binid(typ) ? binright(typ)            /* named type */
                               : binleft(unname(eltype));
       not_flex = indexrange ? 1 : 0;

       repeat {
         int i;
         eltype=unname (eltype);

        /*-----------------------------------*/
         IF not_flex THEN
           if ( binid(typ) ) {         /* named dynamic */
             indexvar=binright (indexvar);
             if (binsymc(indexvar)==cComma) 
               indexvar=binleft(indexvar);
           }else                               /* PJ 07.01.93 : wie oben */
             indexvar=binleft(eltype);

           for (i=0; i<2; i++) {
           /*    if ( binsymc (name)==cArrow )
             genexpr (binleft (name)), genexpr (binright (name)),
             gen ("->");
             else  */

           /* PJ 07.01.93 : temp_var must be casted */

           if ( is_tempvar( name ) )
           { gen( "( *( (" );
             gen( symtext( idcsym( binid( typ ) ) ) );
             gen( "* ) " );
             gen( symtext( binsym( binleft( name ) ) ) );
             gen( " ) )" );
           }
           else
             genexpr (name);

           /* END PJ 07.01.93 */

           gen (".");

             gen ("fd");
             gen (symctext[cLBrack]);   /* "[" */
             genint ((long) dim);
             gen (symctext[cRBrack]);   /* "]" */
             if ( i==0 ) gen(".lbound=(");
             else        gen (".ubound=(");
             geneline (typ,cComma,false);
             if ( i==0 ) genexpr (binleft(indexvar));
             else        genexpr (binright(indexvar));
             gen (");"); genline ();
          }
          indexvar=binfather(indexvar);
        FI
        /*-----------------------------------*/

        eltype = binright(eltype);
        dim++;
      } until (binsymc (unname (eltype)) != cDYNAMIC);

       IF not_flex THEN
         gen ("y_init ( (y_dscp) ");
       ELSE
         gen ("y_inid ( (y_dscp) ");
       FI
       genaddress (name);

       gen (", (a_byte)");
       genint ((long) dim);
       gen (", sizeof(");

       (void) gentyp ( eltype );    /* elementtype */
       gen (") );"); genline ();
       break;
    }

    case cFILE:
    case cTEXT: {
       idptr id;
       id = binid(name);

       if ( id_is(id,generated) and (idlevel (id) <= IDMAINLEVEL) ) break;

       gen ("f_assg((f_text*) &");
       denCid (name);
       gen (",\"");
       genPid (name);
       gen ("\", ");
       if (binid (iddatyp (id)) == idTEXT)
	  gen ("(size_t)0);");
       else {
	  gen ("sizeof(");
	  (void) gentyp (binright (unname (iddatyp (id)))) ;
	  gen ("));");
       }
       genline ();
       idfset (id,generated);
       break;
    }
    case cDOTPRECISION:
       gen ("d_init((d_otpr*) ");
       genaddress (name);
       gen (");");
       genline ();
       break;

    case cSTRING:
      gen ("s_init ((s_trng *) ");
      genaddress (name);
      gen (",");
      if ( binright (unname (typ)) != NULL ) {
	 gen ("(") ;
	 geneline (typ,cComma,false);
	 genexpr (binright (unname (typ)));
	 gen (")") ;
      } else gen ("0");
      gen (");");
      genline ();
      break;

    default :
	defaulterr (symc);

  } /* switch */
  /* PJ 07.01.93 */
  dectabs( );
  gen( "}" );
  genline( );
  /* END PJ 07.01.93 */
} /* gen_init */

						/*-------------------*/
#ifdef LINT_ARGS
local void gen_free  ( binptr name,symctype symc)
#else
local void gen_free (name,symc)                 /*  g e n _ f r e e  */
binptr name;
symctype symc;
#endif
{
   switch ( symc ) {

      case cDYNAMIC:
	 gen ("y_free((y_dscp) ");
	 genaddress (name);
	 gen (");");
	 genline ();
	 break;

      case cFILE:
      case cTEXT:
	 gen ("f_free((f_text*) ");
	 genaddress (name);
	 gen (");");
	 genline ();
	 idfclr (binid(name),generated); /* indicates: already freed */
	 break;

      case cSTRING:
	 gen ("s_free((s_trng*) ");
	 genaddress (name);
	 gen (");");
	 genline ();
	 break;

      case cDOTPRECISION:
	 gen ("d_free((d_otpr*) ");
	 genaddress (name);
	 gen (");");
	 genline ();

      default:
	defaulterr (symc);

   } /* switch */
} /* gen_free */

						/*------------------*/
#ifdef LINT_ARGS
local void gen_vlcp  ( binptr name,symctype symc)
#else
local void gen_vlcp (name,symc)                 /*  g e n _ v l c p */
binptr name;
symctype symc;
#endif
{
   if ( symc == cSTRING )
      gen ("s_vlcp((s_trng*) ");
   else
   if ( symc == cDOTPRECISION )
      gen ("d_vlcp((d_otpr*) ");
   else
   if ( symc == cDYNAMIC )
      gen ("y_vlcp((y_dscp) ");

   genaddress (name);

   gen (");"); genline ();
} /* gen_vlcp */


						/*------------------*/
#ifdef LINT_ARGS
local void gen_temp  ( binptr name,symctype symc)
#else
local void gen_temp (name,symc)                 /*  g e n _ t e m p */
binptr name;
symctype symc;
#endif
{
   if ( symc == cSTRING )
      gen ("s_temp((s_trng*) ");
   else
   if ( symc == cDOTPRECISION )
      gen ("d_temp((d_otpr*) ");
   else
   if ( symc == cDYNAMIC )
      gen ("y_temp((y_dscp) ");

   genaddress (name);

   gen (");"); genline ();
} /* gen_temp */


						/*------------------*/
#ifdef LINT_ARGS
local void gen_utmp  ( binptr name,symctype symc)
#else
local void gen_utmp (name,symc)                 /*  g e n _ u t m p */
binptr name;
symctype symc;
#endif
{
   if ( symc == cSTRING )
      gen ("s_utmp((s_trng*) ");
   else
   if ( symc == cDOTPRECISION )
      gen ("d_utmp((d_otpr*) ");
   else
   if ( symc == cDYNAMIC )
      gen ("y_utmp((y_dscp) ");

   genaddress (name);

   gen (");"); genline ();
} /* gen_utmp */


						/*---------*/
#ifdef LINT_ARGS
local void swap  ( binptr *bin1,binptr *bin2)
#else
local void swap (bin1,bin2)                     /* s w a p */
binptr *bin1,*bin2;
#endif
{  binptr temp;

   temp= *bin1;
   *bin1= *bin2;
   *bin2= temp;
} /* swap */

					     /*---------------------*/
#ifdef LINT_ARGS
local void genaddress  (  binptr object)
#else
local void genaddress (object)               /* g e n a d d r e s s */
/* Generiert
 *      '&object'
 * oder
 *      'object',
 * je nachdem object ein Lvalue oder ein Pointer auf ein Lvalue ist.
*/
binptr object;
#endif
{
    if ( binsymc (object) == cArrow )
      genexpr (binleft (object)),
      genexpr (binright (object));
    else
      gen ("&"), genexpr (object);

} /* genaddress */


#ifdef LINT_ARGS
boolean gen_varinit( binptr typ, int mode, symctype symc )
#else
boolean gen_varinit( typ, mode, symc )
binptr   typ;
int      mode;
symctype symc;
#endif

/*
    PJ  15.02.93 : result type changed from void to boolean.
                   variable change added.
                   if gen_varinit returns true a new C block has
                   been opened, i.e a "{" has been generated and tabs
                   have been incremented.
*/

{ struct stack *ptr   = top;
  binptr       object = charptr1;       /* Object to be initialized. */
  int          dim    = 0;
  boolean      change = false;

  while ( ptr != NULL )
  { binptr ltyp, ultyp = unname( ptr->binnode );
    if ( binsymc( ultyp ) == cARRAY )
    { /* Es wird folgendes generiert:                                     */
      /*                                                                  */
      /*    { int i;                                                      */
      /*      p1= object;         P.J. 19.9.94                            */
      /*      for (i=0; i<FELDWEITE; i++, p1+=sizeof(ELEMENTTYP))         */
      /*                                                                  */
      /* Es ist p1 ein pointer auf jeweils ein Element des Arrays object. */

      long size = 1 ;          /* product of index ranges */
      gen( "{ int " );
      gen( symtab( indexvar ) );
      gen( ";" );
      genline( );
      inctabs( );
      swap( &charptr1, &charptr2 );
/*      gen( "char *" );      P.J. 19.9.94   use global RTS variables */
      genCid( binleft( charptr1 ) );
      gen( "=(a_VOID) " );
      if ( object == charptr1  or  object == charptr2 )
        genaddress (object);    /* is temp charptr */
      else
        genexpr (object);       /* is Pascal var */
      gen( ";" );
      genline( );
      gen( "for ( ");
      gen( symtab( indexvar ) );
      gen( "=0; " );
      gen( symtab( indexvar ) );
      gen( "<" );
      while ( binsymc( ultyp ) == cARRAY )
      { /* evaluate array size */
        size *= rangesize( unname( binleft( ultyp ) ) );
	ultyp = unname( ltyp = binright( ultyp ) );
      }
      genint( size );
      gen( "; " );
      gen( symtab( indexvar ) );
      gen( "++, " );
      genCid( binleft( charptr1 ) );
      gen( "+=" );
      gen( "sizeof(" );
      (void) gentyp( ltyp );
      gen( "))" );
      genline( );
      object = charptr1;
      change = true;
    }
    else
      if ( binsymc( ultyp ) == cDYNAMIC )
      { /* Es wird folgendes generiert:                             */
        /*                                                          */
        /*        { int i;                                          */
        /*          p1=(object).array;   P.J. 19.9.94               */
        /*          for (i=(y_ubnd ((y_dscp)& object,1)-            */
        /*                  y_lbnd ((y_dscp)& object,1)) * ... );   */
        /*               i>=0; i--, p1 += sizeof(ELEMENTTYP)        */
        /*              )                                           */
        /*                                                          */
        /* Es ist object der Descriptor des dyn. Arrays und p1 ein  */
        /* pointer auf jeweils ein Element des Arrays.              */

	gen( "{" );
	gen( "int " );                  /* Declaration of counter. */
	gen( symtab( indexvar ) );
	gen( ";" );
	genline( );
        inctabs( );
        swap( &charptr1, &charptr2 );
/*        gen( "char *" );   P.J. 19.9.94 use global RTS variables
                             /* Declaration of pointer */
	genCid( binleft( charptr1 ) );   /* to data-element.       */
	gen( "=(*(y_dscp)(a_VOID)& ");
	genexpr( object );
	gen( ").array; ");
	genline( );
        gen( "for (" );
	gen( symtab( indexvar ) );
	gen( "=" );
        dim=0;
	do
        { /* Generate fieldwidth. */
          if ( dim != 0 ) gen( "*" );
	  gen( "(y_ubnd ((y_dscp)(a_VOID) " );
	  genaddress( object );
	  gen( "," );
          genint( (long) dim+1 ); /* 11.12.91 "+1" added */
	  gen( ")-" );
          gen( "y_lbnd ((y_dscp)(a_VOID) " );
	  genaddress( object );
	  gen( "," );
	  genint( (long) dim+1 ); /* 11.12.91 "+1" added */
	  gen( "))" );
	  ltyp = binright( ultyp );
	  dim++;
	} while ( binsymc( ultyp = unname( ltyp ) ) == cDYNAMIC );
        gen( ";" );
	gen( symtab( indexvar ) );
	gen( ">=0;" );
	gen( symtab( indexvar ) );
	gen( "--," );
        genCid( binleft( charptr1 ) );
	gen( " += " );
	gen( "sizeof(" );
	(void) gentyp( ltyp );
	gen( "))"/* 11.12.91 ";" deleted */ );
        genline( );
        object = charptr1;
        change = true;
      }
      else
        IF binsymc( ultyp ) == cRECORD THEN
          binptr cast = binleft( binleft( indirect ) );

          /* Es wird folgendes generiert:                            */
          /*                                                         */
          /*    { p1= (a_VOID)&object;     P.J. 19.9.94              */
          /*                                                         */
          /* Es ist object der Record und p1 Pointer auf den Record. */

	  if ( top != ptr )
          { /* Erstes Element. */
            swap( &charptr1, &charptr2 );
            gen( "{ " );
/*          gen( "{ char *" );     P.J. 19.9.94 use global RTS variables
                                   /* Deklaration des Pointers */
	    genCid( binleft( charptr1 ) );     /* auf den Record. */
	    gen( "= (a_VOID)" );
	    genaddress( object );
            gen( ";" );
	    genline( );
            inctabs( );
            change = true;
	  }
	  binrlink( cast, binleft( charptr1 ) );    /* Set pointer-name. */
	  binrlink( binleft( cast ), ptr->binnode );/* Set type-name.    */
	  binrlink( indirect,ptr->membername );     /* Set membername.   */
          object = indirect;
	}
        else
	  object = ptr->binnode;          /* First entry in stack: */
					  /* this object is ...    */
    ptr=ptr->next;
  } /* while ptr!=NULL */

  if ( mode == VARFREE or mode == ASGNFREE or mode == DISPFREE )
    gen_free( object, symc );
  else
    if ( mode == VARINIT or mode == NEWINIT ) gen_init( object, typ, symc );
    else
      if ( mode == PARCOPY  or mode == ASGNCOPY ) gen_vlcp( object, symc );
      else
	if ( mode == VARTEMP ) gen_temp( object, symc );
	  if ( mode == VARUNTEMP ) gen_utmp( object, symc );

  top=NULL;
  return change;
}


/******************************************************************/
/*      TEMPORARY DUMP-FUNCTION (INITIALIZATION-CHECK)            */
/******************************************************************/
/*      PJ   17.10.92                                             */
/******************************************************************/

#ifdef LINT_ARGS
void dump_stack( boolean on_entry, binptr for_type, symctype for_symcode )
#else
void dump_stack( on_entry, for_type, for_symcode )

boolean  on_entry;
binptr   for_type;
symctype for_symcode;

#endif

{ /* dump_stack */

  int          count;
  struct stack *stackptr;

  putchar( '\n' );
  if ( on_entry ) printf( "enter" ); else printf( "exit" );
  printf( "ing TYPE_TRAV for type : \n" );
  putchar( '\n' );
  dump( for_type );
  putchar( '\n' );
  printf( "Actual symbol : %s\n", symptext[ for_symcode ] );
  putchar( '\n' );
  for ( stackptr = top, count = 1; stackptr != NULL;
        stackptr = stackptr->next, count++ )
  { printf( "Stackentry %d : \n\n", count );
    printf( "BINNODE( %d ) : \n\n", count );
    dump( stackptr->binnode );
    putchar( '\n' );
    printf( "MEMBERNAME( %d ) : \n\n", count );
    dump( stackptr->membername );
    putchar( '\n' );
    printf( "----------------------------------------------------------\n\n" );
  }
} /* dump_stack */

/*************************************************************/
/*     PJ 17.10.92 :  END TEMPORARY                          */
/*************************************************************/


					    /*---------------------*/
#ifdef LINT_ARGS
local void type_trav  (  binptr typ,struct stack *adr,int mode)
#else
local void type_trav (typ,adr,mode)         /*  t y p e _ t r a v  */
/* Sucht einen Typ nach einer dotprecision- oder string-Komponente ab.
 *   typ: Der Typ.
 *   adr: Pointer zum letzten Stackeintrag. Wird gebraucht, um weitere
 *        Eintraege anzuhaengen.
 *   mode: Siehe generate.dok
*/
binptr typ;
struct stack *adr;
int mode;
#endif
{   binptr utyp;
    symctype symc;
    struct stack entry;
    int dim=0;
    boolean weiter = false;

    utyp=unname (typ);
    symc=binsymc (utyp);

/* PJ 17.11.92 :  TEMPORARY
dump_stack( true, typ, symc );
/* END TEMPORARY */

    switch (symc) {

    case cARRAY:
       adr->next= &entry;                    /* Link entry to stack. */
       entry.binnode=utyp;                   /* Reference to it's type. */
       entry.next=NULL;  entry.membername=NIL;
       do {
	 typ = binright(utyp);
	 utyp = unname (typ);
       } while (binsymc(utyp) == cARRAY);
       type_trav (typ,&entry,mode);
       if ( top==NULL ) {
/*        gen ("}"); dectabs (); genline ();  P.J. 19.9.94 no longer necessary */
	  swap (&charptr1,&charptr2);
       }

       break; /* case cARRAY */

    case cDYNAMIC:

/* ALT :       if ( mode == VARINIT or mode == NEWINIT) /* 22.10.92 */ 
/* ALT :	  gen_init (adr->binnode,typ,symc);
/* ALT :       else if ( mode == PARCOPY )
/* ALT :	  gen_vlcp (adr->binnode,symc);
/* ALT :
/* ALT :       adr->next= &entry;          /* Link entry to stack. */
/* ALT :       entry.binnode=utyp;             /* Reference to it's type. */
/* ALT :       entry.next=NULL; entry.membername=NIL;
/* ALT :
/* ALT :       do {
/* ALT :	  typ = binright (utyp);
/* ALT :	  dim++;
/* ALT :       } while ( binsymc (utyp=unname (typ)) == cDYNAMIC );
/* ALT :
/* ALT :       type_trav (typ,&entry,mode);
/* ALT :
/* ALT :       if ( top==NULL ) {      /* Code has been generated. */
/* ALT :	  swap (&charptr1,&charptr2);
/* ALT :	  gen ("}"); dectabs (); genline ();
/* ALT :       }
/* ALT :
/* ALT :       if ( mode == VARFREE )
/* ALT :	  gen_free (adr->binnode,symc);
/* ALT :       else if ( mode == VARTEMP )
/* ALT :	  gen_temp (adr->binnode,symc);
/* ALT :       else if ( mode == VARUNTEMP )
/* ALT :  gen_utmp (adr->binnode,symc);                    ENDE ALT */

      if ( gen_varinit( typ, mode, symc ) )     /* PJ 15.02.93 */
      { gen( "}" );
        dectabs( );
        genline( );
      }
      /* PJ 31.03.95  Change assignments to weiter due to casting problems */
      if ( binid( typ ) ) weiter = ( boolean ) (binright( typ ) != NULL );
      else
        weiter = ( boolean ) ( binleft( unname( typ ) ) != NULL );
      if ( weiter )
      {  adr->next= &entry;          /* Link entry to stack. */
         entry.binnode=utyp;             /* Reference to it's type. */
         entry.next=NULL; entry.membername=NIL;
         do
         { typ = binright (utyp);
	   dim++;
         } while ( binsymc (utyp=unname (typ)) == cDYNAMIC );
         type_trav (typ,&entry,mode);
         if ( top==NULL )
         { /* Code has been generated. */
     /*      swap( &charptr1, &charptr2 );
	   gen( "}" );
           dectabs( );           PJ 05.01.92 : type_trav should have completed
           genline( );                         the code, omit these calls !  */
         }
       }
       break; /* case cDYNAMIC */

    case cRECORD: {
       binptr head;
       adr->next= &entry;                 /* Link entry to stack. */
       head=binleft (utyp);             /* Static part only. */

       entry.binnode=typ;                     /* Type-name of record. */

       do {                             /* Scan struct-declaration-list. */
	  binptr list;

	  if ( binsymc (head) == cSemicolon ) list=binleft (head);
	  else list=head;

	  for (utyp=list;   /* get type from end of struct-declarator-list. */
	       binsymc (utyp=binright (utyp)) == cCsymbol  or
	       binsymc (utyp) == cIdlist ;);

	  do {       /* Scan struct-declarator-list. */
	     entry.membername=list;
	     entry.next=NULL;
	     type_trav (utyp,&entry,mode);
	     if ( top==NULL ) top= &entry;
	     list=binright(list);
	  } while ( binsymc(list) == cCsymbol or binsymc(list) == cIdlist );

	  if ( binsymc (head) == cSemicolon ) head=binright (head);
	  else break;      /* End of struct-declaration-list. */
       } while ( true /* forever */ );

       if ( top == &entry ) {      /* Code has been generated. */
	  swap (&charptr1,&charptr2);
	  top=NULL;

/*	  gen ("}"); dectabs (); genline ();
          
          P.J. 15.02.93 : Omit these calls. they should be done by "gen_init"
*/

       }

    } break;   /* case cRECORD */

    case cFILE:
    case cTEXT:
    case cSTRING:
    case cDOTPRECISION:  if ( gen_varinit( typ, mode, symc ) ) /* PJ 15.02.93 */
                         { gen( "}" );
                           dectabs( );
                           genline( );
                         }
                         break;

    default : ;

    } /* switch */

/* PJ 17.11.92 :  TEMPORARY
dump_stack( false, typ, symc );
/* END TEMPORARY */

} /* type_trav */

						/*---------------------*/
#ifdef LINT_ARGS
global void genvarloc  (  binptr name,binptr typ,enum mode mode)
#else
global void genvarloc (name,typ,mode)           /*  g e n v a r l o c  */
/* Generate function-calls on variable.
 * name: Name of variable.
 * typ:  Type of variable.
 * mode:
VARINIT, VARFREE, PARCOPY, VARTEMP, VARUNTEMP,
   ASGNFREE, ASGNCOPY, NEWINIT, DISPFREE
*/

binptr name;
binptr typ;
enum mode mode;
#endif
{ struct stack entry;        /* Erster Eintrag in den Stack. */
  boolean hasdyn=(id_is (binid (typ),hasdyn) or id_is (binid (name),hasdyn) /* or
		  id_is (binid (typ),imported) or id_is (binid (name),imported) */ );
  symctype symc=binsymc (unname (typ));
  if ( not hasdyn    and symc!=cFILE and
       symc!=cTEXT   and symc!=cDOTPRECISION and
       symc!=cSTRING and symc!=cDYNAMIC      and
       symc!=cARRAY  and symc!=cRECORD ) return;

  top= &entry;
  entry.binnode=name;
  entry.next=NULL;
  entry.membername=NIL;
  type_trav (typ,&entry,mode);
} /* genvarloc */


						 /*---------------------*/
#ifdef LINT_ARGS
local void varlistloc  (  binptr var,int mode)
#else
local void varlistloc (var,mode)                 /* v a r l i s t l o c */
/* Generate initialisation and freeing of variables in a list.
 *   var : Var-node.
*/
binptr var;
int    mode;
#endif
{  symctype symc;

   if (not var)   return ;
   switch (binsymc(var)) {
     binptr list;

     case cSemicolon:
	do { /* repeat */
	  varlistloc (binleft(var),mode);
	  mergtill(var);
	  var = binright(var);
	} while (binsymc(var) == cSemicolon);
	varlistloc (var,mode);
	break;

     case cVAR:

	list=binleft (var);
	do {
	   genvarloc (list,binright (var), (enum mode) mode);
	   list=binnext(list);
	} while (binsymc(list)==cIdlist or binsymc(list)==cIdent );
     break;

    case cTempvar :
    case cTempused :
    case cRegister :
    case cCsymbol : {
	binptr symdummy=binsycreate (symNIL);
	binupsym (symdummy,binsym (var));

	symc=binsymc (unname(binright (var)));
	if ( symc == cDYNAMIC ) {
	   if ( mode == VARFREE )
	      gen_free (symdummy,symc);
	   else if ( mode == VARINIT ) {
	      gen (symtab(binsym(var)));
	      gen (".array=0");
	      gen (";"); genline();
	   }
	} else
	if ( symc == cDOTPRECISION ) {
	   if ( mode == VARFREE )
	     gen_free (symdummy,symc);
	   else if ( mode == VARINIT ) {
	     gen_init (symdummy,NIL,symc);
	   }
	} else
	if ( symc == cSTRING ) {
	   if ( mode == VARFREE )
	      gen_free (symdummy,symc);
	   else if ( mode == VARINIT )
	      gen_init (symdummy,NIL,symc);
	}
	binkill (symdummy);
     }
     break;

    default : ;
   } /* switch */
} /* varlistloc */

						   /*-----------------------*/
#ifdef LINT_ARGS
local boolean genarrydecl ( binptr p,binptr typ )
#else
local boolean genarrydecl(p,typ)                   /* g e n a r r y d e c l */
binptr p;
binptr typ;
/* generate declarations of temporary static arrays,
 * to which value-parameters are copied.
 * Innerused parameters are copied to denest-structure and no
 * temporary array is required.
 */
#endif
{
    if ( binsymc (p)==cCsymbol ) {
	 gende_spec (typ);
	 genCid (binfather (p));
	 return true;
    }
    return false;
} /* genarrydecl */
						  /*---------------------*/
#ifdef LINT_ARGS
local boolean genparinit  ( binptr bin,binptr typ )
#else
local boolean genparinit (bin,typ)                /* g e n p a r i n i t */
binptr bin;
binptr typ;
/* copy value parameter to
 *   a)  member of denest-structure.
 *   b)  static array/set.
 *   c)  dynamic arrays/strings/sets.
 *   d)  dotprecision.
*/
#endif
{
  idptr id;
  boolean rename=false;

  if ( binsymc (bin)==cCsymbol )      /* Static array is value-parameter. */
     rename=true, bin=binfather (bin);

  id = binid (bin);

  if ( id_is(id,arraytype) and
       idgetkind(id)!=IDVARPARAM ) {
    /* Value parameter
     *    'var a:array [1..n] of type'
     *  yields
     *     'memcpy(a,ar_XYZ,n*sizeof(*ar_XYZ));
    */
    gen ("memcpy(");
    denCid (bin);
    gen (",");
    if ( rename )
       gen (symtab (binsym (binright(bin))));
    else
       genCid (bin);

    gen (",");

/*  If parameter is of type SET, the last argument
 *  of memcpy is replaced by 's_SIZE'.
*/
    if ( binsymc(unname(iddatyp (id)))==cARRAY ) {
	genrange (binleft(unname(typ)));
	gen ("*sizeof(*");
	genCid (bin);
	gen ("));");
    } else /* cSET */
	gen ("s_SIZE);");

    genline ();
  } else
  if ( id_is (id, innerused) ) {
       gen (symtab(AS_local)); gen (".");
       genCid (bin); gen (" = ");
       genCid (bin); gen (";");
       genline ();
  }

  if ( idgetkind(id)!=IDVARPARAM )
     genvarloc (bin,iddatyp (id),PARCOPY);
  return false;
} /* genparinit */

					   /*-----------------*/
#ifdef LINT_ARGS
local boolean genpfree (binptr bin, binptr dummy1)
#else
local boolean genpfree(bin,dummy1)         /* g e n p f r e e */
/* Free dynamic parameters */
binptr bin;
binptr dummy1;   /* Function is used as parameter for para_trav(), */
		 /* which expects three parameters.                */
#endif
{
  idptr id;
  id=binid(bin);
  if ( idgetkind(id)!=IDVARPARAM and
	(id_is (id, hasdyn) or id_is (id, dynamic)))
     genvarloc (bin,iddatyp (id),VARFREE);
  return false;
} /* genpfree */


					     /*---------------*/
#ifdef LINT_ARGS
local void genbody (binptr p)
#else
local void genbody(p)                        /* g e n b o d y */
/* Generate body of Operator, function or procedure.
 * p: cBEGIN
*/
binptr p;
#endif
{
    binptr  colon;
    boolean isfunc=false,
	    isoper=false,
	    denest,
	    isparused=false;  /* True, if subroutine is used as         */
			      /* actual parameter ( parused=true )      */
    idptr id;     opptr op;
    genline (); gen ("{");
    inctabs (); genline ();

    colon=binfather (p);

    isfunc =  ( binsymc (colon)==cFUNCTION ) ;
    if  (isfunc)
       id = binid (binleft (binleft (colon))) ;
    else
       id = binid (binleft (colon)) ;

    isoper =  ( binsymc (colon)==cOPERATOR ) ;
    if  (id)   op = NULL ;
    else {
      op = binop (binleft (binleft (colon))) ;
      if  (not op)   op = binop (binleft (colon)) ;
    }
    isparused = id_is (id,parused);

    colon=binleft (colon);                      /* Now colon is cColon. */

    if ( isfunc and not id_is(id,arraytype) ) {
	gende_spec (binright(colon ));          /* function return type */
	gen (" ");
	gen (symtab(symresid));                 /* function result id */
	gen (";"); genline ();
    } else
    if ( isoper and not op_is (op, arraytype) ) {
	gende_spec (binright(binright (colon)));  /* Operator return type */
	gen (" ");
	genCid (binright (colon));            /* Operator result id */
	gen (";"); genline ();
    }

    generate (binright (binleft(p)));        /* generate declarations */

/* Generate temporary static array-declarations.
*/
    if (isfunc or isoper)
       para_trav (binright(binleft(colon)), genarrydecl,2);
    else
       para_trav (binright(colon), genarrydecl,2);

    denest=blk_is(binblk(binleft(p)),innervar);
    if (denest) {
       gen (symtab(AS_name[disp_level]));  /* Declaration of */
       gen (" "); gen (symtab(AS_local));   /* active structure */
       gen (",*"); gen (symtab(AS_temp));
       gen (";"); genline ();
    }

    if ( denest ) {
       gen (symtab(AS_temp)); gen ("=");
       gen (symtab(disp_name[disp_level]));  /* save display */
       gen (";"); genline ();

       gen (symtab(disp_name[disp_level]));    /* set display to address */
       gen (" = &"); gen (symtab(AS_local));  /* of active structure    */
       gen (";"); genline ();
    }

    if (on_number) {            /* Generate
					e_push ("routname","filename");
					e_line = 'number';
				*/
	gen ("e_push (");
	if (isfunc) genstring (symtab(idsym(id)));
	else if (isoper)
	 if (sym_is [opsymc(binop(binleft(colon)))] .userdefined)
	   genstring (symtab(oppsym(binop(binleft(colon))))); /* named op */
	 else
	   genstring (symtab(idsym(binid(binright(colon)))));
	      /* standard op, so use result id as Operator id */
	else genstring (symtab(idsym(id)));; /* isproc */
	gen (", ");
	genstring (srcfnam());
	gen (");"); genline ();
	gen ("e_line=");
	genint ((long) (errline=binpos(p).line) );
	gen (";"); genline ();
    } /* e_push generated */

    if ( isparused ) gen ("a_2pop ();"), genline ();

    if ( denest and linkdispl ) {
	  gen (symtab(AS_local)); gen (".pred = ");
	  if ( disp_level>=2 )
	     gen (symtab(disp_name[disp_level-1]));
	  else
	     gen ("NULL");    /* No predecessor. */
	  gen (";");
	  genline ();

	  gen (symtab(AS_local)); gen (".adr = (a_VOID)&");
	     gen (symtab(disp_name[disp_level]));
	  gen (";");
	  genline ();
    }

/* Copy value-parameters. */
    if (isfunc or isoper)
       para_trav(binright(binleft(colon)), genparinit, 2);
    else
       para_trav(binright(colon), genparinit, 2);

    varlistloc (binright (binleft (p)),VARINIT); /* Initialisation of files  */
						 /* and dynamic arrays.      */

						 /* Initialisation of dynamic */
    if ( isfunc ) {
	 binptr name=binsycreate (symresid);
	 binsymc (unname(binright (colon)));
	 genvarloc (name,binright(colon),VARINIT);
	 binkill (name);
    } else
    if ( isoper ) {
	 binptr right=binright (colon);
	 binsymc (unname(binright(right)));
	 genvarloc (right,binright(right),VARINIT);
    }

    genline () ;
    genstm (binright(p));                          /* generate statements */

    varlistloc (binright (binleft (p)),VARFREE);   /* Free local variables. */

/* Free value-parameters. */
    if (isfunc or isoper)
       para_trav (binright(binleft(colon)), genpfree, 2);
    else
       para_trav (binright(colon), genpfree, 2);

    if ( isfunc ) {
	 binptr name=binsycreate (symresid);
     /*    binsymc (unname(binright (colon)));*/
	 genvarloc (name,binright(colon),VARTEMP);
	 binkill (name);
    } else
    if ( isoper ) {
	 binptr right=binright (colon);
     /*    binsymc (unname(binright(right)));     */
	 genvarloc (right,binright(right),VARTEMP);
    }

    if (denest) {
       gen (symtab(disp_name[disp_level]));  /* reset display */
       gen ("="); gen (symtab(AS_temp));
       gen (";"); genline ();
    }

    if ( isparused ) gen ("a_2pop ();"), genline ();

    if (on_number) {
	gen ("e_popp ();");
	genline ();
    }

    if (isfunc) {
       gen ("return ");
	if ( id_is(id,arraytype) )
	 gen ("(a_VOID)"); /* 17.02.92 */
       gen (symtab(symresid));         /* function result id */
       gen (";"); genline ();
    }
    else if (isoper) {
       gen ("return ");
	if ( op_is(op,arraytype) )
	 gen ("(a_VOID)"); /* 17.02.92 */
       genCid (binright (colon));     /* Operator result id */
       gen (";"); genline ();
    }

    mergtill(p);
    dectabs ();
    gen ("}");  genline ();

#if INTERMEDIATE
    bintrkill (binright (p));      /* Kill statements. */
#endif

} /* genbody */


#ifdef LINT_ARGS
local void densubrout ( binptr p)
#else
local void densubrout(p)                        /*---------------------*/
binptr p;                                       /* d e n s u b r o u t */
#endif
{
   binptr declroot;
   blockptr blk;
   idptr idroot;

   declroot=binleft(binright(p));

   blk=binblk(declroot);

   idroot=blkid(binblk(declroot));
   declroot=binright(declroot);

   if (blk_is(blk,innervar))
   {
	gen ("typedef struct ");
	gen (" {");
	genline (); inctabs ();

	if ( linkdispl ) {
	   gen (" a_VOID pred, adr;");  /* 'pred' must be first, 'adr' must */
	   genline ();                  /* be second member of structure,   */
	}                               /* see denest.dok.                  */

	idtabtraverse(idroot,dnstructput);

	gen ("} ");
	disp_index[denestlevel] = disp_level;
	AS_name   [disp_level]   = uniquename("dt");
	disp_name [disp_level]   = uniquename("dp");

	gen(symtab(AS_name[disp_level]));
	gen (";");
	dectabs ();  genline ();

	gen ("static ");
	gen (symtab(AS_name[disp_level]));
	gen (" *");
	gen (symtab(disp_name[disp_level]));
	gen (";");  genline ();
   }

   p=declroot;

   while (binsymc(binleft(p))==cSemicolon) /* Skip list of temp. variables. */
      p=binleft(p);

/* generate local subroutines */

   while ( p or binsymc(p)==cSemicolon ) {
      symctype symc;
      binptr bin;
      if ( binsymc(p)==cSemicolon ) bin = binleft (p);
      else bin = p;                /* last element of list. */
      symc = binsymc(bin);
      if ( symc==cFUNCTION or symc==cPROCEDURE
	   or symc==cOPERATOR ) {
	 genfuncdef (bin); genline ();
      }
      if ( binsymc(p)!=cSemicolon ) break;     /* end of list. */
      p=binright (p);
   }
} /* densubrout */


						  /*---------------------*/
#ifdef LINT_ARGS
local void geninclude  ( void)
#else
local void geninclude ()                          /* g e n i n c l u d e */
#endif
BEGIN (geninclude)

  initlast = initlist;      /* Saving initlist; initlast not used anymore */

  if (on_merge) {
    gen ("/* global declarations of imported modules :  */");
    genline ();
  }
  gen ("#define global extern");
  genline ();
  while (initlist) {
    gen ("#include \"");
    gen (dclfpath (getpath (initlist)));
    gen ("\"");
    genline ();
    initlist = initlist->next;
  }
  gen ("#undef global");
  genline ();
  genline ();

  initlist = initlast;      /* restoring initlist */

END  /* geninclude */                             /* g e n i n c l u d e */
						  /*---------------------*/


					    /*-----------------------------*/
#ifdef LINT_ARGS
local void initialisation  ( void)
#else
local void initialisation ()                /* i n i t i a l i s a t i o n */
#endif
BEGIN (initialisation)

  initlast = initlist;      /* Saving initlist; initlast not used anymore */

  if (on_merge) {
    gen ("/* Initialisierungs-Routinen der importierten Module: */");
    genline ();
  }
  while (initlist) {
    if (initlist->initrout) {
      gen (initlist->initname);
      gen ("();");
      genline ();
    }
    initlist = initlist->next;
  }
  genline ();

  initlist = initlast;      /* restoring initlist */

END  /* initialisation */                   /* i n i t i a l i s a t i o n */
					    /*-----------------------------*/


#ifdef LINT_ARGS
						 /*---------------------*/
global void para_trav (binptr p,                 /*  p a r a _ t r a v  */
		boolean (*func)(binptr, binptr),
		int sepa)
#else
global void para_trav (p, func, sepa)            /*  p a r a _ t r a v  */
   binptr p;
   boolean (*func)();
   int sepa;
#endif
{
   binptr bin;
   binptr typ;
   boolean done=false;
   while ( p )
   {
      if ( binsymc(p)==cSemicolon )
	 bin=binleft(p);
      else bin=p;

      typ=bin;

      if ( binsymc (bin)==cIdlist ) {

	 do typ=binright (typ);      /* Get type from end of ID-list. */
	 while ( binsymc (typ)==cIdlist or binsymc (typ)==cCsymbol );

	 do {
	    if ( done ) {
	       if ( sepa==1) gen (", ");
	       else if ( sepa==2 ) gen (";"), genline ();
	    }

	    if ( binsymc (binnext (bin))==cCsymbol )
	      bin = binnext (bin); /* parameter had been renamed by namechange */
	    done=(*func) (bin, typ);
	    bin=binnext(bin);
	    if ( binsymc (bin)==cCsymbol )     /* added 10.01.92 */
	      bin = binnext (bin); /* skip new parameter name */

	 } while ( binsymc(bin)==cIdlist );   /* while not end of ID-list. */
      } else  /* procedure or function */
      if ( func!=genparinit and func!=genpfree and
	   func!=genarrydecl ) {
	 bin=binleft (bin);
	 if ( binsymc (typ)==cFUNCTION )
	    bin=binleft (bin);
	 if ( done ) {
	    if ( sepa==1) gen (", ");
	    else if ( sepa==2 ) gen (";"), genline ();
	 }
	 done=(*func) (bin, typ);   /* bin is rout. */
	 if ( id_is (binid (bin), formpara) ) {
	    if ( sepa==1) gen (", ");
	    else if ( sepa==2 ) gen (";"), genline ();
	    done=(*func) (binright (typ), bina_VOID);
	 }
      }

      if ( binsymc (p)!=cSemicolon ) break;
      else p=binnext(p);
   }  /* while not end of parameter-list. */

   if ( done and sepa==2 ) gen (";"), genline ();

} /* para_trav */


							/*---------------*/
#ifdef LINT_ARGS
local void genPid  ( binptr id)
#else
local void genPid (id)                                 /*  g e n P i d
*/ binptr id;
#endif
BEGIN (genPid)

#ifdef Error_Seek
printf ("genPid -> ");
printf (symtab(idsym(binid(id))));
#endif

gen (symtab (idsym (binid (id))));

#ifdef Error_Seek
printf (" <- genCid\n");
#endif

END  /* genPid */                                     /*  g e n P i d  */
						      /*---------------*/

