/*
 *  MODULE:  head.c
 *  compilation of subroutine headers  and data types
{*  last modification:  26.08.92  16:00   }


 *  uli 9.1.91 : formarglist: cflist will not be deleted
                 pfsublist: pure pflist will be created
  *  uli 15.1.91 : formarglist: nooverload flag will be set.
  *  uli 18.1.91 : opheader: ":=" now has result type voidtype.
  *  uli 25.1.91 : header reports error, if function overloads procedure
                                       or procedure overloads function
  *  Uli 29.1.91 : expression has callclass parameter
  *  Uli 04.2.91 : header: idsetbin added
  *  Uli 07.2.91 : recordtyp: dummy element added for empty field list.
  *  Uli 22.2.91 : "Compiling ..." only if os_verbose.
  *  Uli 22.2.91 : new style headers
  *  uli 17.04.91 : recordtype: variant part corrected.
  *  uli 18.04.91 : chkfileparameter added.
  *  uli 18.04.91 : alltyp: subrange: lb <= ub checked
  *  uli 14.05.91 : "stringtyp" changed to strtyp.
  *  uli 15.05.91 : extracted from decl.c.
  *  uli 27.05.91 : dclerrtyp added.
  *  uli 08.07.91 : idlist : rename added.
  *  uli 08.07.91 : enumeration : baptize on mainlevel too, because of cast
  *                 Operators due to indexcheck.
  *  uli 10.07.91 : alltyp: default: chkscalar added.
  *  uli 10.07.91 : formarglist : chkc ")" inserted inside of loop.
  *  tim 10.07.91 : pop_parsloc has no parameter now.
  *  uli 14.08.91 : posnores added.
  *  uli 21.08.91 : formarglist : blktabflag linkdispl added.
  *  uli 27.08.91 : opheader: chkpar added.
  *  uli 18.11.91 : arraytyp recordtyp : dynamic components must be baptized.
  *  uli 28.11.91 : symjustdef checked against symNIL before reporting error.
  *  uli 28.11.91 : Check IDNONE and idBAD_ID before error reporting.
  *  uli 02.01.92 : alltyp : subrange : chkscalar only, if type not in error.
  *  uli 06.05.92 : case cArrow: pointer to dynamic array is allowed now.
  *  tim 30.07.92 : recordtyp: empty listelement in variant record definition
                    is handled properly now.
  *  tim 26.08.92 : chkeltyp: string type in variant record definition
                    is reported as an error now.
  *  tim 30.09.92 : chkeltyp: dynamic types in a variant record definition
                    are reported as an error.
                    alltyp:
                    dynamic type definitions or declarations may be nested
                    now; parsing of type-definition and variable-declaration
                    are equivalent now.
  *  tim 13.01.93 : dynnamtyp : the definition of a dynamic typename
                    is copied with new index bounds into a corresponding
                    variable declaration if its index range is specified anew,
                    the dynamic typename will thus not appear in the tree
  *  tim 02.05.93 : dynstdtyp: new local procedure created.
  *  tim 23.07.93 : dynstdtyp: renamed to dynnamtyp, original dynnamtyp
                    deleted. New dynnamtyp revised.
  *  tim 21.11.94 : header : Faulty 'if id()'-check after 'LParent' removed.
*/
#define CHECK

#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 "blktab.h"
#include "optab.h"
#include "bintab.h"
#include "std.h"
#include "errecy.h"
#include "seman.h"
#include "syntax.h"
#include "stm.h"                /* import konst */

#include             "expor.t"
#include "head.h"
#include             "implemen.t"

#include "runtime.h"


#ifdef LINT_ARGS
local  void     chkeltyp (boolean);
local  void     intexpr (void);
local  void     arraytyp (boolean *);
local  void     dynatyp (boolean *);
local  void     dynnamtyp (idptr);
local  void     strtyp (void);
local  void     auswahl (binptr);
local  void     recordtyp (boolean *, binptr);
local  void     restyp (void);
local  void     typspez (void);
local  binptr   pfsublist (binptr, binptr *);
local  binptr   pflist (binptr);
local  binptr   formarglist (void);
local  void     chkpar (binptr);
local  void     chkmorepar (binptr);
local  void     chkmonadic (symctype *);







local  void     chkdyadic (symctype *);
local  void     poolinit(void);
local  void     poolput(binptr, shortint);
local  binptr   pooldel(binptr);

#else

local  void     chkeltyp ();
local  void     intexpr ();
local  void     arraytyp();
local  void     dynatyp ();
local  void     dynnamtyp ();
local  void     strtyp();
local  void     auswahl ();
local  void     recordtyp();
local  void     restyp ();
local  void     typspez ();
local  binptr   pfsublist ();
local  binptr   pflist ();
local  binptr   formarglist ();
local  void     chkpar ();
local  void     chkmorepar ();
local  void     chkmonadic ();
local  void     chkdyadic ();
local  void     poolinit();
local  void     poolput();
local  binptr   pooldel();

#endif

static binptr pool = NULL;        /* head of pool of forward references */
                                                      /* , a dummy node */

                                                /*-------------------*/
                                                /*  p o o l i n i t   */
#ifdef LINT_ARGS
local void poolinit ( void)
#else
local void poolinit()               /* Creating dummy at head of list */
#endif
{
   pool = bincreate(cComma);
}                                               /*  p o o l i n i t   */
                                                /*-------------------*/

                                                /*-------------------*/
                                                /*  p o o l p u t   */
#ifdef LINT_ARGS
local void poolput  ( binptr binp,shortint blkle)
#else
local void poolput (binp, blkle)
binptr binp;                 /* Reference node to be inserted */
shortint blkle;   /* descriptor of node ( blockklevel in this case) */
#endif
{
   binptr runpool;
   postype ln_t_ble;           /* 'line to blocklevel' */

   if( pool == NULL)
      poolinit();
   runpool = binright(pool);               /* right of dummy node */
   if (runpool)  {          /* there is something written in pool */
      runpool = bininsert(runpool,bincreate(cComma));   /* insert new */
                /* node at the beginning and make runpool point at it */
      binexchange(runpool);     /* successor of runpool to the right */
   }
   else
      runpool = binappend(pool,bincreate(cComma));
   ln_t_ble.col = '0';              /* just for completeness */
   ln_t_ble.line = blkle;           /* blocklevel in 'line' */
   binuppos (runpool, ln_t_ble);
   binllink(runpool, binp);       /* reference node left of runpool */
}
                                                /*  p o o l p u t   */
                                                /*-------------------*/

                                                /*-------------------*/
                                                /*  p o o l d e l   */
#ifdef LINT_ARGS
local binptr pooldel ( binptr runpool)
#else
local binptr pooldel(runpool)
binptr    runpool;              /* binpointer of entry to be deleted */
#endif
{
     binptr rpool;

     rpool = runpool;
     idfclr (binid(binleft(rpool)), forward) ;
     binllink(rpool,NIL);                        /* delete reference */
     rpool = bindelete( rpool );      /* delete list element in pool */
     return(rpool);
}
                                                 /*  p o o l d e l   */
                                                 /*-------------------*


                                              /*-----------------------*/
                                              /*  r e s o l _ f o r w  */
            /* handles remaining forward references, entered into pool */
                                       /* after blkend has been called */
#ifdef LINT_ARGS
global void resol_forw (shortint blole )
#else
global void resol_forw(blole)
shortint blole;                  /* identifies blocklevel of entry in */
                                           /* pool to be deleted */
#endif
{
   binptr runpool;
   idptr  idp;

   if (pool == NIL)  return ;

   runpool = binright(pool);
   if (runpool) {
      while ( runpool )  { /* search pool for entries marked */
                                          /* by 'blole' */
         if ( binpos(runpool).line != blole )   {
            runpool = binright(runpool);
            continue;
         }
         idp = idtypfnd (idsym (binid(binleft (runpool))));
         if (not (idp))  {
                        /* There was found no definition at all */
            errput (1001, binpos (binleft (runpool)), NULL);
                             /* Unsatisfied forward-reference */
            runpool = pooldel(runpool );
               /* delete pool entry in order to avoid spurious errors */
         }
         else if (idgetkind(idp) != IDTYPE )  { /* Es wurde keine  */
                           /* no typdefinition found but something else */
             errput (1002, binpos (binleft (runpool)), NULL);
                            /* Type-identifier expected */
            runpool = pooldel(runpool );
               /* delete pool entry in order to avoid spurious errors */
         }
         else  {
            binupid (binleft (runpool), idp); /* update id-pointer */
            runpool = pooldel(runpool );      /* delete pool entry */
         }
         runpool = binright(runpool);
      }  /* while */
   }     /* if */
   else
      pool = NULL;             /* delete pool if list is empty */
}
                                                /*  r e s o l _ f o r w */
                                                  /*-------------------*/

                                                 /*-------------------*
                                                  /*  d e l _ f o r w  */
          /* deletes forward reference specified by idp and blocklevel */
#ifdef LINT_ARGS
global void del_forw ( idptr idp,shortint blole )
#else
global void del_forw(idp, blole)
idptr idp;                           /* specification of pool entry to */
shortint blole;                                          /* be deleted */

#endif
{
   binptr runpool;

   runpool = binright(pool);
   if (pool && (runpool) ) {
      while ( runpool )  { /* search pool for entries marked */
                                          /* by 'blole' */
         if ( binpos(runpool).line != blole )   {
            runpool = binright(runpool);
            continue;
         }
         if ( (idsym(idp) == idsym (binid(binleft (runpool)))))  {
                                    /* compare idpointers */
            binupid (binleft (runpool), idp);     /* update idpointer */
            runpool = pooldel(runpool );          /* delete poolentry */
         }
         runpool = binright(runpool);
      }  /* while */
   }     /* if */
   else
      pool = NULL;             /* delete pool if list is empty */
}
                                                    /* d e l _ f o r w */
                                                  /*-------------------*/



                                                  /*---------------------*/
                                                  /*  d c l e r r t y p  */
#ifdef LINT_ARGS
global idptr dclerrtyp (void)
#else
global idptr dclerrtyp ()
#endif
BEGIN(dclerrtyp)
   idptr idp ;
   errput (1112, pos, NULL) ;    /*  Identifier not declared  */
   idp = idins (sym, IDTYPE) ;   /*  declare dummy  */
   idsetbin(idp, bincurr);
   idsetdatyp(idp, anytype);
   return idp ;
END /* dclerrtyp */
                                                  /*  d c l e r r t y p  */
                                                  /*---------------------*/


                                                       /*---------------*/
                                                       /* t y p a s s g */
#ifdef LINT_ARGS
global void typassg(binptr p,binptr datyp,boolean hasdyn)
#else
global void typassg (p,datyp, hasdyn)
  /* assigns the data type datyp and the hasdyn flag */
  /*  to all identifiers in the list referenced by p */
  binptr p,datyp;
  boolean hasdyn;
#endif
BEGIN (typassg)

#ifdef CHECK
    if (not(p)) {
        errput (9512, binpos(p), "typassg");
                      /* typassg : p == NIL. */
    }
#endif

     while  (binsymc(p) == cIdlist)
       begin
       idsetdatyp (binid(p), datyp) ;
       if  (hasdyn)   idfset(binid(p), hasdyn) ;
       p = binright (p) ;
       end ;
END  /*  typassg  */
                                                       /* t y p a s s g */
                                                       /*---------------*/


                                                        /*---------------*/
#ifdef LINT_ARGS
global void idlist(symctype endsym,idkind kind )        /*  i d l i s t  */
#else
global void idlist (endsym, kind)
 symctype endsym;
 idkind  kind ;
#endif
BEGIN(idlist)
 idptr idp;

 repeat
  if (chkid () )  {
     binchange (bincurr, cIdlist);
     idp = idins(sym, kind);
     idsetbin(idp, bincurr);
     binupid (bincurr, idp);
     if  (sym_is [symc].rename)  then
       idsetcsym (idp, uniquename ("rn")) ;
     binsuffix () ;
     binget ();
     if (symc!=cComma)
        chkc(endsym) ;
     if (symc==cComma)
        binget () ;
  }
 until (symc==endsym or symc == cEndofSrc or stoppars(DECL) );
END /*idlist*/                                          /*  i d l i s t  */
                                                        /*---------------*/


                                                /*-------------------*/
  /* checks whether the right side of binprev */
  /* is a legal element type or component type. */
#ifdef LINT_ARGS
local void chkeltyp  (  boolean recorddef)
#else
local void chkeltyp ( recorddef)                   /*  c h k e l t y p  */
  boolean recorddef;            /* flag for check of a record component */
#endif
BEGIN(chkeltyp)
 binptr bintemp = binprev;
 symctype temp;

 if  (binsymc (unname (binright(binprev))) == cFILE)  then
    begin
      errput (1004, binpos(binright(binprev)), NULL);
                    /* A component type must not be a file type. */
    end

 temp = binsymc (unname (binright(binprev))) ;
 if  ( (temp == cSTRING || temp == cDYNAMIC ) && recorddef) {
    while ( binsymc ( bintemp ) != cRECORD )
       bintemp = binfather(bintemp);
    if ( binsymc (binright(bintemp) ) == cCASE )
       if (temp == cSTRING)
          errput(1017, binpos(binright(binprev)), NULL) ;
/* A component type must not be a string type in a variant record definition */
       else if ( temp == cDYNAMIC )
          errput(1005, binpos(binright(binprev)), NULL) ;
                                  /* A component type must not be a dynamic */
                                    /* type in a variant record definition */
 }
END /* chkeltyp */                              /*  c h k e l t y p  */
                                                /*-------------------*/

                                                        /*-----------------*/
#ifdef LINT_ARGS
local void intexpr  (  void)
#else
local void intexpr ()                                   /*  i n t e x p r  */
  /* parses and checks an integer expression */
  /* used for index expressions of dynamic arrays. */
#endif
BEGIN(intexpr)
  sc_type sc ;
  binptr datyp ;

  contpars(STM);            /* pretending that syntax is called by STM */
  datyp = expression (FCALL, &sc) ;
  setstoppars(STM);
  if (subtype (datyp) != integertype and datyp != anytype) then
   begin
     errput(1006, binpos(binprev), NULL) ;
             /* Index range of a dynamic array must be integer type. */
   end ;

  if  (binstm)  then
   begin
     errput(1007, binpos(binprev), NULL) ;
                    /* Do not use #-expressions in index ranges. */
     binstm = NIL ;
   end ;
END /* intexpr */                                       /*  i n t e x p r  */
                                                        /*-----------------*/


                                                /*---------------*/
#ifdef LINT_ARGS
local void  strtyp (void)                       /*  s t r t y p  */
#else
local void  strtyp ()
#endif
BEGIN(strtyp)
 binptr datyp ;

/* errput(1009, pos, NULL) ;
                 /* The string data type is not yet implemented. */

 if  (symc == cLBrack)  then
  begin
    binget();                           /* skip "[" */

    datyp = konst () ;                  /* string length */
    if  ( datyp != integertype and datyp != anytype )  then
      begin
        errput(1010, pos, NULL) ;
                        /* The string length must be integer. */
      end ;

    if (chkc(cRBrack) )
       binget();
  end ;
END /* strtyp */                                /*  s t r t y p  */
                                                /*---------------*/

                                                /*-------------------*/
#ifdef LINT_ARGS
local void arraytyp  ( boolean * hasdyn )
#else
local void arraytyp (hasdyn)                    /*  a r r a y t y p  */
  boolean * hasdyn ;   /* "has dynamic element" */
#endif
BEGIN(arraytyp)
 binptr root ;
 boolean skip = true, dummy = false;

 root = binprev ;
 binsuffix();
 binget();
 skip = chkc(cLBrack);
 repeat
  if (skip) {
     binget () ;                   /* skip LBrack or Comma */
     alltyp (/* glob= */false, &dummy) ;
     chkscalar (binright(binprev), binpos (binright (binprev))) ;
     if  (unname (binright (binprev)) == integertype)  then
      begin
        errput(1011, binpos (binright (binprev)), NULL) ;
                          /* Integer is not allowed as index type. */
      end ;

     if (symc != cComma)                         /* error recovery */
        chkc(cRBrack);

     if (symc == cComma)
      begin
        binprefix () ;                /* shift index type left */
        binchange (bincurr, cARRAY) ;
        binsuffix () ;
      end
  }
 until (symc == cRBrack || stoppars(DECL) );

 binprefix () ;                    /* shift index type left */
 if (chkc(cRBrack) )
   binget();
 if (chkc(cOF) )  {
   binget();
   alltyp (/* glob= */false, hasdyn) ;     /* element type */
   chkeltyp ( /* recorddef == */ false) ;
   if  (binsymc (binright (binprev)) == cRECORD   /* unnamed record type */
                                      /* must be named because of "with" */
     or binsymc (binright (binprev)) == cDYNAMIC) /* unnamed dynamic type */
                       /* must be named because of type conversion calls */
    begin
      baptize (binright (binprev) );
    end ;
   if (id_is(binid (binright(binprev) ), dynamic) ||
       id_is(binid (binright(binprev) ), hasdyn)  ||
       binsymc (binright(binprev)) == cDYNAMIC)
      *hasdyn = true;                      /* array has dynamic element */
 }  /* if .. cOF .. */
 binprev = root ;
END /*arraytyp*/                                /*  a r r a y t y p  */
                                                /*-------------------*/

                                                /*-----------------*/
#ifdef LINT_ARGS
local void  dynatyp (boolean * hasdyn)         /*  d y n a t y p  */
#else
local void  dynatyp (hasdyn)
  /* parses an unnamed dynamic array type. */
  boolean * hasdyn ;   /* "has dynamic element" */

#endif
BEGIN(dynatyp)
 register binptr root;
 boolean var_dekl = binsymc (binprev) != cTYPE ;
 boolean expr, star;            /* denote wether memory is allocated to */
                            /* an object by declaration or by statement */
 boolean skip = true;

 expr = star = false;
/* #ifdef CHECK
  if  (var_dekl and binsymc (binprev) != cVAR)
   begin
     errput (9001, binpos(binprev), NULL);
                     * dynatyp: not type nor var. *
   end ;
#endif  Useless, since dynamic arrays can be nested. */

 root = binprev ;
 binsuffix();                                   /* append DYNAMIC */
 binget();
 if ( chkc(cARRAY) )
    binget();                        /* skip "ARRAY"  */
 skip = chkc(cLBrack);                        /* skip "["      */

 repeat  /* until "]" */
   if (skip) {
      binget();                                 /* skip "[" or "," */
      if ( symc != cMult) then
       begin                                        /* parse indexrange */
        setparsloc(SYNTAX, cLBrack);
        intexpr () ;                               /*  lbound */
        resetparsloc( SYNTAX);
        if ( expr || not star )
           expr = true;
        else
           errput ( 1054, binpos (binprev), NULL);
  /* You either have to specify all index bounds of a dynamic array or none */

        if ( chkc (cTill) ) {
           goright () ;
           bininfix () ;                              /* insert ".." */
           binget () ;
           setparsloc(SYNTAX, cTill);
           intexpr () ;                               /*  ubound */
           resetparsloc( SYNTAX);
           gofather();
        }
      end     /* var decl */

      else    /* type declaration */
      begin                                        /* else "*"      */
        if (chkc(cMult) )                               /*           */
        /* binsuffix();                            */
        /* binchange (binprev , cIrange) ;         */
        /* gofather();                             */
        if ( star || not expr)
           star = true;
        else
           errput ( 1054, binpos (binprev), NULL);
  /* You either have to specify all index bounds of a dynamic array or none */

        binget();                                  /* skip "*" */
      end;

      binprefix ();                                /* range is left son */
      if (symc != cComma)                              /* next is "," ? */
         chkc(cRBrack);                      /* possible error recovery */

      if (symc == cComma)
      begin
        binsuffix ();                              /* append comma    */
        binchange (binprev , cDYNAMIC) ;           /*  as DYNAMIC     */
      end
   }
   skip = true;
 until ( symc == cRBrack || stoppars(DECL) );

 if (!stoppars(DECL) )
    binget();                                      /* skip "]"       */
 if (chkc(cOF) )  {
    binget();                                   /* skip OF        */
    alltyp (/* glob= */false, hasdyn);

    if  (binsymc (binright (binprev)) == cLParent or /* unnamed enum type */
      binsymc (binright (binprev)) == cRECORD  or /* unnamed record type */
      binsymc (binright (binprev)) == cARRAY)     /* unnamed array type */
     begin                                      /* must be named */
      baptize (binright (binprev) );
     end ;

    if  (binsymc (unname (binright(binprev))) == cFILE)  then
     begin
      errput(1004, binpos (binright (binprev)), NULL) ;
               /* A component type must not be a file type. */
     end
    if (id_is(binid (binright(binprev) ), dynamic) &&
       binsymc (unname (binright(binprev))) != cDYNAMIC ||
                       id_is(binid (binright(binprev) ), hasdyn) )
       *hasdyn = true;
 } /* if .. cOF .. */
 binprev = root ;
END /*dynatyp*/                                 /*  d y n a t y p  */
                                                /*-----------------*/

                                                /*-----------------*/
#ifdef LINT_ARGS
local void  auswahl  ( binptr datyp )
#else
local void  auswahl (datyp)                     /*  a u s w a h l  */
  binptr datyp ;
#endif
BEGIN(auswahl)
 binptr root, ctyp;

 root = binprev ;

 while ( symc != cColon    and not sym_is [symc] .stmstopper )
 begin
    ctyp = unname( konst() ) ;               /* constant             */
    binrlink(binprev, NIL);
    if  (unname (subtype (datyp)) != unname (ctyp) and
        ctyp != anytype and datyp != anytype)  then
     begin
       errput(1013, binpos (binright (binprev)), NULL) ;
              /* The type of the constant is incompatible. */
     end ;

    if (symc !=cTill && symc != cComma )        /* no subrange found    */
       chkc(cColon);                     /* facilitating error recovery */
    if (symc==cComma || symc == cTill)
       binget () ;                    /* skip ".." or "," */
 end
 binprev = root ;
END /*auswahl*/                                 /*  a u s w a h l  */
                                                /*-----------------*/



                                                /*---------------------*/
#ifdef LINT_ARGS
local void recordtyp (boolean *hasdyn, binptr typroot)
#else
local void recordtyp(hasdyn, typroot)           /*  r e c o r d t y p  */
  /* parses a "data set list" of a record type. */
  /* recursive call in case of variant record */
boolean *hasdyn;                           /* has dynamic element */
binptr  typroot;      /* Pointer to root of the record type, i.e. */
                      /* cRECORD node, but not inside of a variant part */
                      /* Used to check multible element names. */
#endif
BEGIN(recordtyp)
 register binptr root;
 binptr     stlist,
       datyp,caskn;
 idptr         idp ;
 symptr         sy;
 postype    typpos;   /* position of tagfield data type */
 boolean     dummy = false;

 root = binprev ;
 while (id())
 begin
  stlist = binprev ;                            /* father of list  */

  repeat   /* until end of id list */           /* pars id list */
   if ( chkid () )  {
      if ( sym_is[symc].rename )  {         /* component to be renamed? */
         binchange (bincurr, cIdlist);
         idp = idcreate (sym, IDVAR);
         idsetcsym( idp, uniquename("rn") );
         binupid (bincurr, idp );
      }
      else {
         binchange (bincurr, cCsymbol);
         binupsym (bincurr, sym);
      }
      if ( reccfnd(sym, typroot, NULL) != voidtype )
         errput(1051, binpos(bincurr), NULL);
     /* Record-component declared more than once in a record-definition. */
      binsuffix () ;                            /* append symbol node */
      binget ();
      if (symc!=cComma)
         chkc(cColon) ;                    /* encouraging error recovery */
      if (symc==cComma)
         binget () ;
   }
  until (symc==cColon or symc == cEndofSrc or stoppars(DECL) );

  if (not stoppars(DECL) )  {
     binget(); /* skip ":" */
     alltyp (/* glob= */false, hasdyn);
     chkeltyp (/* recorddef == */ true) ;
     if  (binsymc (binright (binprev)) == cRECORD )    /* unnamed record */
      begin                                      /* type must be named */
       baptize (binright (binprev) );            /* because of "with" */
      end ;
     if  (id_is (binid (binright(binprev)), dynamic) ||
          binsymc (binright(binprev)) == cDYNAMIC)
        *hasdyn = true;
  }
  binprev = binright (stlist);       /* go to start of component list */

  if (symc != cSemicolon  and  !stoppars(DECL) )  {
    if (binsymc(root) == cRECORD) {      /* in constant part */
       if ( symc != cEND )
          chkc( cSemicolon) ;                  /* ";" or "end" expected */
    }
    else                                /* in variant part */
       if ( symc != cRParent )
          chkc( cSemicolon) ;                   /* ";" or ")" expected */
 /*    errput(1014, pos, NULL) ;   */
           /* 'end' , ')' or ';' expected in type-definition */
  }
  if (symc == cSemicolon) {           /* insert semicolon-node if exists */
     bininfix () ;
     binget () ;
  }
 end; /* until not id; constant part parsed */

 if  (binsymc(binprev) == cSemicolon and not binright(binprev))
   then   bindelete (binprev) ;

 binprev = root ;
 if ( binsymc(binprev) == cRECORD )     /* if record-node            */
    binprefix () ;                      /* shift constant part to left  */


                                                /*--------------*/
 if (symc == cCASE) then                        /* variant part */
 begin
  if ( binsymc(binprev) == cRECORD )
     ;
  else if (binright (binprev) ) {      /* Create and insert REC.-node */
                                         /* if there is none */
     bininsert (binright (binprev), bincreate (cRECORD));
     goright();
  }
  else {              /* Create and append REC.-node if there is none */
     binappend(binprev, bincreate ( cRECORD) );
     goright();
  }
  binsuffix();
  binget();                                     /* Case node         */
  if ( chkid() ) {                              /* next symbol IdEnt */
     typpos = pos ;
     sy = sym ;
     binget();

     binlside(binprev,binsycreate( uniquename("un")) );
                                                /* Csym strukt left */
  }

  if (symc == cColon) then                      /* Selection by compon.*/
  begin
   if ( reccfnd(sy, typroot, NULL) != voidtype )
      errput(1051, binpos(bincurr), NULL);
     /* Record-component declared more than once in a record-definition. */
   binget();                                    /* skip :                */
   caskn = binprev;                             /* save binprev          */
   binprev = binfather(caskn);                  /* on recordnode for     */
                                                /* tagfield->konst part  */
   if ( binleft(binprev) != NIL ) then
   begin
     goleft();
     while ( binsymc(binprev) == cSemicolon )
        goright();                              /* binprev ->last syml.  */
     bininsert( binprev, bincreate( cSemicolon ));/* new listelement     */
     gofather();
     binappend(binprev,binsycreate(sy) );       /* append symbol right   */
     goright();                                 /* binP. on symbol       */
   end
   else
   begin
     binlside (binprev, binsycreate(sy));       /* only tagfield        */
     goleft();                                  /* on sym node          */
   end;

   if ( chkid() ) {                             /* expect typename      */
      binsuffix();                              /* and append right     */
      binupid(binprev, idtypfnd(sym) );
      datyp = binprev;
      binget();
   }
   else
      datyp = anytype ;
   binprev = caskn ;                            /* on CASE node        */
  end
  else {
    idp = idtypfnd(sy);
    if (not(idp)) {
       errput(1015, typpos, symtab(sy)) ;
       datyp = anytype ;
                                          /* Type identifier expected, */
    }
    else
       datyp = iddatyp (idp) ;

  }
  chkscalar (datyp, typpos) ;

  if (chkc (cOF) )
     binget () ;                               /* skip OF              */

  do {
    if ( symc == cSemicolon || symc == cEND ) {
       errput(1016, pos, NULL) ;
                /* Missing selection part in variant record definition */

      if ( symc == cSemicolon ) {                  /* empty listelement */
        binget();                               /* skip ;               */
        if (symc!=cEND && symc != cRParent) {   /* new listelement?     */
           bininsert (binprev, bincreate( cSemicolon));
           gofather();
        }
      }
      else break;               /* cEnd stops parsing of variant record */
    }
    else if ( not stoppars(DECL) )
    begin
      if (symc ==cELSE )  {
         binsuffix () ;            /* cELSE node is right son  */
         binget();
         if (symc == cColon)
            binget();
      }
      else  {
         auswahl (datyp) ;                       /* selection (Auswahl) */
         if ( chkc(cColon) ) {
            binsuffix () ;                         /* : node right son  */
            binget();
         }
      }
      binlside(binprev,binsycreate(uniquename("st")));
                                                /* Csym struct left     */
      if ( chkc(cLParent) ) {
         binget();                              /* skip (               */
         setparsloc(DECL, cRECORD);
         recordtyp(hasdyn, typroot);            /* recordlist right */
         pop_parsloc();
         *hasdyn = *hasdyn || dummy;
         if ( chkc(cRParent) )
            binget();                           /* skip )               */
      }
      if (symc!=cSemicolon) {
        if ( !stoppars(DECL) ) {
         if (binsymc(root) == cRECORD) {      /* in constant part */
            if ( symc != cEND )
               chkc(cSemicolon) ;                /* ";" or "end" expected */
         }
         else                                /* in variant part */
            if ( symc != cRParent ) {
               chkc(cSemicolon) ;                  /* ";" or ")" expected */
            }
        }
      }
      if ( symc == cSemicolon ) {              /* recovered semicolon ? */
        binget();                               /* skip ;               */
        if (symc!=cEND && symc != cRParent) {   /* new listelement?     */
           bininsert (binprev, bincreate( cSemicolon));
           gofather();
        }
     /*    errput(1014, pos, NULL) ;  */
                      /* 'end' , ')' or ';' expected in type-definition */
      } /* not cSemicolon */
    end;  /* if ...cELSE... */
  } while (symc!=cEND && symc != cRParent && symc != cEndofSrc &&
                !stoppars(DECL) );

  end   /* variant part (if ...cCASE...) */
  else

    if ( binsymc(root) == cRECORD )     /* if record-node */
      if  (not binleft (root))  then    /* empty field list */
        begin
        binlside  (root, binsycreate (symins ("st_000"))) ;
        binrlink (binleft (root), chartype) ;
        end  else ; /* constant part exists */
    else
      if  (not binright (root))  then    /* empty field list */
        begin
        binappend (root, binsycreate (symins ("st_000"))) ;
        binrlink (binright (root), chartype) ;
        end ;

 binprev = root ;
END /*recordtyp*/                       /*  r e c o r d t y p  */
                                        /*---------------------*/



                                                        /*---------------*/
#ifdef LINT_ARGS
global void alltyp (boolean glob,boolean *hasdyn)        /*  a l l t y p */
#else
global void alltyp(glob, hasdyn)
  boolean glob;
  boolean *hasdyn;       /* has dynamic element */
#endif
BEGIN(alltyp)
  register binptr root, ltyp ,rtyp;
  binptr runtree;
  register idptr    idp;
/*  shortint  nr;
  char nstr[5]; */
 boolean dummy = false;

 root = binprev ;
 setparsloc(DECL, cIdent);    /* identifier is the simplest type */
 if (symc == cPACKED) then   binget() ;         /* ignore packed */

 if (id())
 begin                                  /* type identifier or subrange */
  idp= idfnd (sym) ;
  if  (not idp)  then   idp = dclerrtyp () ;

  if (idgetkind(idp)== IDFUNCTION)  then
     idp = idtypfnd (sym) ;
  if (idgetkind(idp)==IDTYPE)  {                     /* type identifier */
     if ( binsymc( unname(iddatyp(idp))) == cDYNAMIC) {
                                                /* x: RVECTOR[1..n]     */
        dynnamtyp (idp) ;
        if (id_is(idp, hasdyn ) )  *hasdyn = true;
     }
     else  {
        binsuffix() ;
        binupid (binprev, idp) ;
        binget();
        if (idp == idSTRING ) then
           strtyp();                            /* string type */
      }
  }
  else
   begin                                        /* not type id */
     if (idgetkind(idp)!=IDNONE  and  idgetkind(idp)!=IDCONST)  then
      begin
        if (symjustdef == sym  and  symjustdef != symNIL)
           errput(1053, pos, "type");
      /* Type identifier found on both sides of '=' in its definition. */
        else
           errput(1018, pos, NULL) ;
                     /* Type identifier or subrange expected. */
        ltyp = anytype ;                        /* error in type */
      end
     else
      begin
        ltyp = iddatyp (idp) ;                     /* subrange */
        chkscalar (ltyp, pos) ;
      end
     binsuffix() ;                              /* append lower bound */
     binupid (binprev, idp) ;
     binget () ;
     if (symc == cTill) then                    /* ".." found */
        begin
          bininfix () ;
          binget () ;
          rtyp = konst() ;                      /* append upper bound */
          if  (subtype (ltyp) != subtype (rtyp))  then
            begin
             errput(1019, binpos (binprev), NULL) ;
                                  /* Incompatible subrange bounds. */
            end ;
          if  (binvalue (binleft(binprev)) > binvalue (binright(binprev)))  then
            begin
             errput(1058, binpos (binprev), NULL) ;
                /* Upper bound is less than lower bound */
            end ;
        end
     else
      if (idgetkind(idp)==IDCONST)  then     /* suppress follow up error */
        begin
         errput(1020, pos , NULL) ;
                              /* \"..\" expected. */
        end ;
   end /* not type id */
 end  /* identifier found */
 else                                  /* no identifier */

 switch  (symc)
 begin
  /*--------------------*/
  /*  enumeration type  */
  /*--------------------*/
  case cLParent:
      binsuffix () ;                            /* suffix "(" */
      setparsloc(DECL, cLParent);
      binget();
      idlist (cRParent, IDCONST) ;              /* suffix constants */
      if (chkc(cRParent) )  {
         binget(); /* skip ")" */
         while  (binsymc(binprev) == cIdlist)
            gofather () ;

         if  (binsymc (root) != cTYPE  and  blocklevel >= IDMAINLEVEL)
           baptize (binprev) ;

         if  (binsymc (binfather (binprev)) == cTYPE)    /* is typedef? */
            typassg (binright (binprev),
                  binleft (binfather (binprev)), false) ;
              /* assign type name to all enumeration constants */
         else
            typassg (binright (binprev),      /* assign data type to all */
                     binprev, false) ;        /* enumeration constants */

         begin  register binptr p, val ;
             shortint n = 0 ;                /* assign values to all */
           p = binright (binprev) ;             /* enumeration constants */
           while  (binsymc (p) == cIdlist)
             begin
               idsetvalue (binid (p), val = bincreate (cIcon) ) ;
               binupvalue (val, (long)n) ;
               n++ ; p = binright (p) ;
             end ;
         end ;
      }  /* if chkc(cRParent) */
      pop_parsloc();
  break ; /* enumeration type */

  /*----------------*/
  /*  pointer type  */
  /*----------------*/
  case cArrow:
      binsuffix();
      binget();
      setparsloc(DECL, cArrow);
      if ( chkid() )  {
         idp = idfortyp(sym);
         if (not (idp)) {
            idp=idins(sym,IDTYPE);             /* forward reference */
            idfset (idp, forward) ;
            idsetbin(idp, bincurr);
            binupid(bincurr, idp);
            poolput(bincurr, blocklevel);     /* enter into pool */
         }
         else if (idlevel(idp) == blocklevel ) {  /* locally found? */
            binupid (bincurr, idp) ;
            if ( id_is(idp, forward)) {
                 poolput(bincurr, blocklevel);     /* enter into pool */
            }
         }
         else if ( not id_is(idp, forward))  {
                    /* global type definition was found */
            idfset (idp, forward) ;
            binupid(bincurr, idp);
            poolput(bincurr, blocklevel);
         }
         else
            binupid (bincurr, idp) ;
         if (symjustdef == sym  and  symjustdef != symNIL)  {
            runtree = binprev;
            while ( binsymc (runtree) != cTYPE && binsymc (runtree) != cVAR
                 && binsymc(runtree) != cNosym) {
                runtree = binfather(runtree);
            }
            if (binsymc(binright(runtree ) ) != cRECORD)
               errput(1056,pos,NULL);  /* This type must be a record type */
         }             /* since this identifier occurs in its definition. */
         binsuffix ();
         binget();
         gofather () ;
         if  (binsymc (unname (binright(binprev))) != cDYNAMIC)  then
                chkeltyp (/* recorddef == */ false) ;
      }
      pop_parsloc();
  break ; /* pointer type */

  /*--------------------*/
  /*  array type        */
  /*--------------------*/
  case cARRAY:
      setparsloc(DECL, cARRAY);
      arraytyp(hasdyn);
      pop_parsloc();
  break ; /* array type */

  /*----------------------------*/
  /*  dynamic array type        */
  /*----------------------------*/
  case cDYNAMIC:
     setparsloc(DECL, cDYNAMIC);
     dynatyp(hasdyn);
     pop_parsloc();
  break; /* cDYNAMIC */

  /*--------------------*/
  /*  set type          */
  /*--------------------*/
  case cSET:
      binsuffix();
      setparsloc(DECL, cSET);
      binget();
      if ( chkc(cOF) )  {
         binget();
         alltyp (/* glob= */false, &dummy);
         chkscalar (binright(binprev), binpos (binright(binprev))) ;
      }
      pop_parsloc();
  break ; /* set type */

  /*--------------------*/
  /*  file type         */
  /*--------------------*/
  case cFILE:
      binsuffix();
      setparsloc(DECL, cFILE);
      binget();
      if ( chkc(cOF) ) {
         binget();
         alltyp (/* glob= */false, hasdyn);
         if ( *hasdyn ||
              id_is (binid(binright(binprev)), dynamic) ||
              binsymc (binright(binprev)) == cDYNAMIC)
            errput (1050, binpos(binprev), NULL);
                 /*  File must not have dynamic components. */
         if  (binsymc (binright (binprev)) == cLParent or
           binsymc (binright (binprev)) == cRECORD or
           binsymc (binright (binprev)) == cARRAY)   /* unnamed type */
          begin                                      /* must be named */
            baptize (binright (binprev) );
          end ;

         chkeltyp (/* recorddef == */ false) ;
      }
      pop_parsloc();
  break ; /* file type */

  /*--------------------*/
  /*  record type       */
  /*--------------------*/
  case cRECORD:
      binsuffix ();
      binget();
      setparsloc(DECL, cRECORD);
      recordtyp(hasdyn, binprev);
      pop_parsloc();
      if ( chkc(cEND) )  {
         binget();

         if  (binsymc (root) != cTYPE  and  blocklevel > IDMAINLEVEL)
           baptize (binprev) ;
      }
  break ; /* record type */

  case cNIL :   case cPlus:   case cMPlus:  case cMinus:  case cMMinus:
  case cIcon:   case cCcon:   case cRcon:   case cBcon:   case cScon:
                                        /* a subrange type       */
      setparsloc(DECL, cTill);
      ltyp = konst() ;
      chkscalar (ltyp, binpos (binright (binprev))) ;
      if (chkc (cTill) )  {
         goright () ;
         bininfix () ;
         binget();
         rtyp = konst() ;
         if  (subtype (ltyp) != subtype (rtyp))  then
          begin
            errput(1019, binpos (binprev) , NULL) ;
                    /* Incompatible subrange bounds. */
          end ;
         if  (binvalue (binleft(binprev)) > binvalue (binright(binprev)))  then
           begin
            errput(1058, binpos (binprev), NULL) ;
               /* Upper bound is less than lower bound */
           end ;
      }
      pop_parsloc();
  break ; /* subrange type */
  default:
      errput(1063, pos, NULL) ;    /* Data type expected */
      ery_loahd ( cIdent);
 end /* switch type keyword */
 pop_parsloc();
 binprev = root ;
 *hasdyn = *hasdyn || id_is(binid (binright(binprev)), hasdyn );
END /*alltyp*/                                          /*  a l l t y p  */
                                                        /*---------------*/


                                                /*----------------------*/
#ifdef LINT_ARGS
local void  dynnamtyp (idptr typid)            /*  d y n n a m t y p   */
#else
local void  dynnamtyp (typid)
  /* parses a named standard dynamic array type. */
  idptr typid ;

#endif
BEGIN(dynnamtyp)
 binptr root, datyp, bintemp;

 root = binprev;
 binsuffix();                                   /* append type id       */
 binupid (binprev , typid) ;
 if  (symc == cIdent)  then
   binchange (binprev, cArry );                 /* change symc to cArry */
 binget();                                      /* skip type id         */
 datyp = unname (iddatyp (typid)) ;             /* index ranges */

 if ( symc == cLBrack )  {     /* indices to be parsed */
    binget();                       /* skip "["       */
    repeat /* until "]" */
      if (binsymc(datyp) != cDYNAMIC)           /* Type dynamic ?    */
      begin
        errput(1024, pos, NULL) ;
                         /* Too many index ranges for dynamic array. */
      end ;

      setparsloc(SYNTAX, cLBrack);
      intexpr () ;                                 /* lbound */
      resetparsloc( SYNTAX);
      if (chkc (cTill) ) {
         goright () ;
         bininfix () ;                             /* insert ".." */
         binget () ;
         setparsloc(SYNTAX, cTill);
         intexpr () ;                                 /* ubound */
         resetparsloc( SYNTAX);

         datyp = unname (binright (datyp)) ;
      }
      if (symc != cComma)             /* needed for error recovery */
         chkc(cRBrack);
      if (symc == cComma)
      begin
          bininfix();                              /* insert ","   */
          binget ();
      end
    until (symc == cRBrack || stoppars(DECL) );

    if (binsymc(datyp)==cDYNAMIC)                  /* range missing  */
    begin
       errput(1025, pos, NULL) ;
                  /* Too few index ranges for dynamic array. */
    end;

    if ( !stoppars(DECL) )
       binget();                                      /* skip "]"      */
 }  /* if symc == cLBrack */

 else if ( symc == cEND or chkc(cSemicolon) )  {
                                 /* NO indices to be parsed. Formerly set */
                       /* indices have to be copied from datyp if present */
      if ( binleft( datyp) ) {
         bintemp = bincopy( datyp);
         binappend( binprev, bintemp);
         while ( binsymc(bintemp) == cDYNAMIC) {
            binchange( bintemp, cComma);
            bintemp = binright( bintemp);
         }
         bintemp = bindelete( bintemp);
         bintemp = bindelete( bintemp);
      }
  }
 binprev = root;
END /* dynnamtyp */                             /*  d y n n a m t y p  */
                                                /*---------------------*/



                                                /*---------------*/
#ifdef LINT_ARGS
local void   restyp ( void)
#else
local void   restyp()                           /*  r e s t y p  */
#endif
BEGIN(restyp)    /* parses result type of a function or Operator */
  idptr     idp;
/* binptr st,s1,s4,tt; */

  if ( id() ) {
     idp = idtypfnd (sym) ;
     if  (not idp)  then   idp = dclerrtyp () ;
     if (idgetkind (idp) == IDTYPE and
           binsymc (unname(iddatyp(idp))) == cDYNAMIC) {  /* dynamic type */
      dynnamtyp (idp) ;
     }
     else                                                  /* other types */
      begin
        binsuffix () ;
        binupid (binprev, idp) ;
        if (idgetkind(idp) != IDNONE  and  idgetkind(idp) != IDTYPE)  then
          begin
            errput(1002, pos, NULL) ;
                         /* Type Identifier expected */
          end
        binget () ;

        if (idp == idSTRING ) then
          strtyp ();                                    /* string type */
        gofather () ;
      end  /* not dynamic */
  } else
    if  (sym_is[symc].type)
     begin                         /* perhaps unnamed type */
      boolean hasdyn ;
      errput(1002, pos, NULL) ;
      alltyp(/* glob= */ false, &hasdyn);
     end
    else
      chkid() ;   /* call error recovery */
END /* restyp */                                /*  r e s t y p  */
                                                /*---------------*/


                                                /*-----------------*/
#ifdef LINT_ARGS
local void   typspez ( void)
#else
local void   typspez()                          /*  t y p s p e z  */
#endif
BEGIN(typspez)
 idptr      idp;

 if (id() )  {
    idp = idtypfnd(sym);
    if  (not idp)  then   idp = dclerrtyp () ;
    /*  errput(1002, pos, NULL) ;   /* Type Identifier expected. */
    binupid (bincurr, idp) ;
    binsuffix () ;
    binget () ;
    gofather () ;
 } else {           /* perhaps unnamed type */
  if  (sym_is[symc].type)
    begin
      boolean hasdyn ;
      errput(1002, pos, NULL) ;
      alltyp(/* glob= */ false, &hasdyn);
    end
  else
      chkid() ;   /* call error recovery */
 }
END /*typspez*/



/************************************/
/*  routines for proc/func headers  */


                                                /*---------------------*/
#ifdef LINT_ARGS
local binptr pfsublist  (  binptr cflist ,binptr * last )
#else
local binptr pfsublist (cflist, last)           /*  p f s u b l i s t  */
  /* creates a part of a Pascal formal paramlist */
  /* by traversing a Comma list of the C formal paramlist. */
  /* *last will refer to the last element of the sublist */
  binptr cflist ;
  binptr * last ; /* *last will refer to the last element of the sublist */
#endif
BEGIN(pfsublist)
 binptr      res; /* Pascal formal parameter list to be returned */
 binptr   q1, q2; /* traverse the target list. */
 symctype   symc;

 res = q1 = NIL ;
 symc = binsymc (cflist) ;
 if  (symc == cFUNCTION  or  symc == cPROCEDURE)  then  /* formal routine */
  begin
    res = bincreate (symc) ;          /* duplicate proc or func keyword */
    binuppos (res, binpos (cflist)) ;
    cflist = binleft (cflist) ;
    if  (binsymc (cflist) == cColon)  then
      begin                                        /* formal function */
        res = binlside ( res, bincreate (cColon)) ;
        binuppos (res, binpos (cflist)) ;          /* duplicate ":" */
        binrlink (res, binright (cflist)) ;        /* append result type */
        q1 = idparlist (binid (binleft (cflist))) ;
        if (q1)   binlside (res, q1) ;
        res = binfather (res) ;  /* go to father */
      end
    else                                           /* formal procedure */
      begin
        q1 = idparlist (binid (cflist)) ;
        if (q1)    binlside (res, q1) ;            /* append pflist of */
      end                                          /*  formal procedure */
    *last = res;
  end
 else

 while  (binsymc (cflist) == cIdlist)           /* until end of idlist */
  begin
    q2 = binidcreate ((idgetkind (binid (cflist)) == IDVARPARAM
                       ? cVarparam : cIdlist) ,
                      binid (iddatyp (binid (cflist)))) ;
                   /* ^ = data type of the formal parameter */
    binuppos (q2, binpos (cflist)) ;
    *last = q2 ;
    if  (res)  then
      binappend (q1, q2) , q1 = q2 ;    /* further elements */
    else  q1 = res = q2 ;               /* or first element */
    cflist = binnext (cflist) ;
  end ;
  return res ;
END /* pfsublist */

                                                /*---------------*/
#ifdef LINT_ARGS
local binptr pflist  (  binptr cflist )
#else
local binptr pflist (cflist)                    /*  p f l i s t  */
  /* creates a Pascal formal paramlist */
  /* by traversing the C formal paramlist. */
  binptr cflist ;
#endif
BEGIN(pflist)
 binptr      res; /* Pascal formal parameter list to be returned */
 binptr     last; /* pointer to the last element in the pf list */
 binptr      newb; /* pointer to the new sublist to be suffixed */
 binptr  newlast; /* pointer to the last element of the new sublist */

 res = last = NIL ;
 while  (binsymc (cflist) == cSemicolon)
  begin                                 /* until end of ";" list */
    newb = pfsublist (bincont (cflist), &newlast) ;
    if  (res)  then
      binappend (last, newb)  ;  /* further elements */
    else   res = newb ;          /* or first element */
    last = newlast ;
    cflist = binnext (cflist) ;
  end ;

  newb = pfsublist (cflist, &newlast) ;  /* last sublist */
  if  (res)  then
    binappend (last, newb)  ;    /* further elements */
  else   res = newb ;            /* or first element */
  return res ;
END /* pflist */


                                        /*-------------------------*/
#ifdef LINT_ARGS
local binptr formarglist (  void)
#else
local binptr formarglist()              /*  f o r m a r g l i s t  */
  /* parses the formal parameterlist, */
  /* suffix the C formal parameterlist (CF list) to binprev and */
  /* returns the C formal parameterlist (CF list). */
#endif
BEGIN(formarglist)
 binptr  root, p, binpara, temp;
 boolean  varp;
 boolean  procedure = false;  /* normally no procedure parameter */

 root = binprev ;   /* cRout node of subroutine is father of parameter list */
 if ( chkc (cLParent) )  {
   binget () ;

   while ((varp = symc == cVAR and not stoppars(DECL) ) or id()
         or (procedure = symc == cFUNCTION or symc == cPROCEDURE) )
   begin
    if (not procedure )  {
     p = binprev ;
     if (varp) then   binget()/*,  chkid()  unnoetig: chkid in idlist*/ ;
     idlist (cColon, (varp ? IDVARPARAM : IDPARAM));
     if ( not stoppars(DECL) )
       binget(); /* skip ":" */
     typspez();                                  /* type id */

     if  (not varp and binsymc (unname (binright (binprev))) == cFILE)  then
      begin
       errput(1029, binpos(binright (binprev)), NULL) ;
                     /* A file parameter must be a var parameter. */
      end ;

     typassg (binright(p), binright(binprev),        /* assign data type */
          id_is(binid(binright(binprev)), hasdyn) );
     binprev = p ;

     p = binright (p) ;
     while  (binsymc(p) == cIdlist)
      begin                     /* set "formal parameter" flag in idtab */
        idfset (binid(p), formpara) ;
        p = binnext (p) ;
      end
    }  /* if .. !procedure .. */
    else /* formal proc/func */  {
       setparsloc(DECL, symc);
       header(/*glob == */ false);         /* procedure parameter */
       pop_parsloc();
       p = binleft( binprev) ;
       if  (binsymc(binprev) == cFUNCTION)
          p = binleft (p) ;                /* thus p points to procedure */
                                              /* or function name anyway */
       binpara = idparlist (binid (p)); /* store PASCAL formal param. list */
       idfset (binid(p), formpara) ;
      /*  temp =  binfather(p);  */
       /* bintdelete (&p );            /* drop C formal parameter list */
                                     /* and name of function or procedure */
    /*   binllink(temp, binpara);  */
       blkend () ;
       idfset (binid (root), nooverload) ;
                        /* A subroutine with formal subroutines */
                        /* must not be overloaded. */

       begin    /* set linkdispl flag of outermost subroutine block */
         blockptr b ;   int i ;
         for (i = blocklevel , b = actblock ; i > IDSUBLEVEL ;
              i-- , b = blkfather (b)) ;
         blkfset (b, linkdispl) ;
       end

       procedure = false;                  /* reset procedure */
       gofather();
    }
    if (symc != cSemicolon)       /* needed for error recovery */
       chkc (cRParent) ;

    if (symc == cSemicolon)
     begin
       goright();
       bininfix () ;
       binget () ;
     end
   end /* while parameter found */

   if  (binsymc(binprev) == cSemicolon and not binright(binprev))
     then   bindelete (binprev) ;
   if (chkc (cRParent) )
      binget();
 }   /* if ..cLParent.. */
 binprev = root ;
 return (binright (root));
END /*formarglist*/                     /*  f o r m a r g l i s t  */
                                        /*-------------------------*/

static int upline = 0 ; /* last line number of "Compiling" message */

                                                        /*---------------*/
#ifdef LINT_ARGS
global void   header (register boolean glob)            /*  h e a d e r  */
#else
global void   header(glob)
  register boolean glob;
#endif
BEGIN(header)
 binptr   root;
 binptr   datyp,ident; /* argument list, result data type */
 idptr           idp; /* routine identifier */
 register boolean  f; /* func/proc */
 register boolean  o; /* operator */                  /* neaga */
 symctype     idsymc; /* routine identifier */

 root = binprev ;
 binsuffix () ;                         /* suffix keyword */
 f = symc != cPROCEDURE ;
 o = symc == cOPERATOR ;                /* neaga */
/* if (not f)  then chkc(cPROCEDURE) ; */
 binget () ;

 if ( chkid() ) {
    ident=bincurr;
    idsymc = symc ;
    if (on_verbose and os_verbose and upline != pos.line)
       printf ("Compiling %s in line %d\n", symtab(sym), upline= pos.line) ;
    idp = idlclfnd (sym) ;
    if  (idp)  then       /* already declared */
      if  (idgetkind (idp) != IDNONE  and
           f ? idgetkind (idp) != IDFUNCTION and idgetkind (idp) != IDTYPE
           : idgetkind (idp) != IDPROCEDURE)
         errput (1055, pos, idkndtext [idgetkind(idp)]) ;

    idp = idcreate (sym,                   /* create idtab entry */
                 ( f ? IDFUNCTION : IDPROCEDURE )) ;
    binupid (bincurr, idp) ;
    idsetbin(idp, bincurr);
    binsuffix () ;                         /* suffix routine name */
    if  (glob)  idfset (idp, is_global) ;
    binget();                      /* skip routine identifier */

    blkbegin ( idp ) ;               /* enter new block */
    if  (symc == cLParent)  {
      setparsloc(DECL, cPROCEDURE);
      idsetparlist (idp, pflist (formarglist ())) ; /* Parameter list */
      pop_parsloc();
    }

    if  (idsymc == cREAD  or idsymc == cREADLN  or
         idsymc == cWRITE or idsymc == cWRITELN )  then
     begin
       if  (binsymc (unname (idparlist (idp))) != cFILE  and idp != idBAD_ID)
        begin
          errput(1030, binpos(ident), NULL) ;
      /* The first formal parameter of READ and WRITE must be FILE type. */
        end ;
       if  ( (idsymc == cREADLN  or  idsymc == cWRITELN) and
          binright (idparlist (idp)) )  then
        begin
          errput(1031, binpos(ident), NULL) ;
                 /* READLN and WRITELN must have only one file parameter. */
        end ;
     end

    if  (on_dump)  then
     begin
       print (" Formal Argument types of ") ;
       print (symtab (idsym(idp))) ;
       print (" at line ") ;
       printint ((longint)(binpos(binright(binright(root)))).line) ;
     /*  print (" col ") ;
         printint ((longint)(binpos(binright(binright(root)))).col) ;*/
       printline () ;
       dump (idparlist (idp) ) ;
       printline () ;
     end ;   /* PF list dump */

    if  (on_rename )  then
     if (on_bib) then
       idsetcsym (idp, moduniquename ()) ;
     else
     if  (glob)  then
       idsetcsym (idp, moduniquename ()) ;
     else
       idsetcsym (idp, uniquename (f ? "fu" : "pr")) ;
    if  (id())  then                             /* neaga */
    begin if (o) then binget () ;
          else if (f) then
               begin
                  errput(1048, pos, NULL);
               end ;
    end ;                                        /* neaga */

    if (symc == cColon) then
     begin                                 /* function result type */
       if  (not f)  then
        begin
          errput(1032, pos, NULL) ;
                          /* A procedure must not have a result type. */
        end ;

       bininfix () ;                       /* insert ":" */
       binget () ;
       restyp () ;
       datyp = binright (binprev);
       idsetdatyp (idp, datyp) ; /* result type */
    /* idsetdatyp (idins (symresid, IDVAR), datyp ) ; /* result variable */
     end  /* result type */
    else
      if  (f)  then
        begin
          errput(1033, pos, NULL) ;
          /* \" : resulttype\" missing. */
        end ;

    idroutins (ident) ;    /* Inserts id of ident to idtab and */
                        /* sets id.bin to ident.            */

    gofather () ;                          /* go to keyword */
    binprefix () ;
 }
END /*header*/                                          /*  h e a d e r  */
                                                        /*---------------*/


/*------------------------*/
/*  routines of opheader  */

postype posnores = {0,0} ; /* position, where result name is missing */

                                                /*---------------*/
#ifdef LINT_ARGS
local void chkpar (binptr p)                    /*  c h k p a r  */
#else
local void chkpar (p)
  binptr p ;
#endif
BEGIN(chkpar)
  if  (p and binsymc(p) != cIdlist)  then
     errput(1062, binpos (p), NULL) ;
             /* Illegal formal operand. */
END /* chkpar */                                /*  c h k p a r  */
                                                /*---------------*/


                                                /*-----------------------*/
#ifdef LINT_ARGS
local void chkmorepar  ( binptr p )
#else
local void chkmorepar (p)                       /*  c h k m o r e p a r  */
  binptr p ;
#endif
BEGIN(chkmorepar)
  if  (binsymc(p) == cIdlist)  then
   begin
     errput(1034, binpos (p), NULL) ;
                         /* Too many formal parameters in Operator. */
   end ;
END /* chkmorepar */                            /*  c h k m o r e p a r  */
                                                /*-----------------------*/

                                                /*-----------------------*/
#ifdef LINT_ARGS
local void chkmonadic  ( symctype * symc )
#else
local void chkmonadic (symc)                    /*  c h k m o n a d i c  */
  symctype * symc ;
#endif
BEGIN(chkmonadic)
  if  (*symc == cPlus)  then    *symc = cMPlus ;
  else
  if  (*symc == cMinus)  then    *symc = cMMinus ;
  else
   if  (symprio (*symc) != priomonop)
   begin
     errput(1035, pos, NULL) ;
                     /* Too few formal parameters for a dyadic Operator. */
   end ;
END /* chkmonadic */                            /*  c h k m o n a d i c  */
                                                /*-----------------------*/

                                                /*---------------------*/
#ifdef LINT_ARGS
local void chkdyadic  ( symctype * symc )
#else
local void chkdyadic (symc)                     /*  c h k d y a d i c  */
  symctype * symc ;
#endif
BEGIN(chkdyadic)
   if  (symprio (*symc) == priomonop)
   begin
     errput(1036, pos, NULL) ;
                /* Too many formal parameters for a monadic Operator. */
   end ;
END /* chkdyadic */                             /*  c h k d y a d i c  */
                                                /*---------------------*/


                                                /*-------------------*/
#ifdef LINT_ARGS
global void opheader(boolean glob)              /*  o p h e a d e r  */
#else
global void opheader(glob)

boolean   glob;

#endif
{
     symctype     osymc;
     binptr       oprestyp = anytype, ltyp = NIL, rtyp= NIL;
     boolean      lvar = false, rvar = false ;
     idptr        resid;
     symptr       oppsym,opcsym;
     binptr       fpar ;
     opptr op;

     blkbegin((idptr)0);

     /*** add 'cOPERATOR' node ***/
     binsuffix();

     binget();
     if (not sym_is[symc].Operator and symc != cAssign)
       if  (sym_is[symc].identifier)
        begin
          errput(1037, pos, NULL) ;
                  /* Priority definition missing for Operator symbol. */
          symc = cPlus ;
          binchange (bincurr, cPlus) ;
        end
       else
        begin
          errput(1038, pos, NULL) ;
                          /* Operator symbol expected. */
          symc = cPlus ;
          binchange (bincurr, cPlus) ;
          binllink  (bincurr, NIL) ;
        end ;

     if(sym_is[symc].userdefined)
          {
          oppsym = sym;
          if  (on_rename)
          if (on_bib) then
            opcsym =  moduniquename() ;
          else
            opcsym =  glob ? moduniquename() : uniquename("op") ;
          else
            opcsym = sym ; /* Operator symbol will be C name */
          if (on_verbose and os_verbose and upline != pos.line)
            printf ("Compiling %s in line %d\n", symtab(sym), upline= pos.line);
          }
     else
          {
          oppsym = symNIL;
          if (on_bib) then
            opcsym =  moduniquename() ;
          else
          opcsym =  glob ? moduniquename() : uniquename("op") ;
          if (on_verbose and os_verbose and upline != pos.line)
            printf ("Compiling %s in line %d\n",
                     symptext[symc], upline = pos.line) ;
          }
     osymc = symc;
     binsuffix () ;             /* append Operator symbol */
     binchange (binprev, cBEGIN) ;
     binllink (binprev, NIL) ;  /* kill left, for debugging */
     binchange (binprev, cOpptr) ;

     binget () ;                /* skip Operator symbol */
     if  (chkc(cLParent) ) then           /* '(' expected  */
      begin
        setparsloc(DECL, cPROCEDURE);
        fpar = formarglist () ;  /* pars Parameter list */
        pop_parsloc();

        if  (binsymc (fpar) == cSemicolon)  then        /* ";" separated */
         begin
           chkpar (binleft (fpar)) ;
           chkmorepar (binright (binleft (fpar))) ;
           ltyp = iddatyp (binid (binleft (fpar))) ;
           lvar = idgetkind (binid (binleft (fpar))) == IDVARPARAM ;
           if  (binsymc (binright (fpar)) == cSemicolon)  then
             begin
               errput(1034, binpos (binright (fpar)), NULL) ;
                           /* Too many formal parameters in Operator. */
             end
           else
            begin
              chkpar (binright (fpar)) ;
              chkmorepar (binright (binright (fpar))) ;
              rtyp = iddatyp (binid (binright (fpar))) ;
              rvar = idgetkind (binid (binright (fpar))) == IDVARPARAM ;
            end ;
           chkdyadic (&osymc) ;
         end

        else  /* no ";" */                              /* "," separated */
         begin
           if  (binsymc (binright (fpar)) == cIdlist)  then
            begin                                       /* dyadic op */
              chkpar (fpar) ;
              chkmorepar (binright (binright (fpar))) ;
              ltyp = iddatyp (binid (fpar)) ;
              lvar = idgetkind (binid (fpar)) == IDVARPARAM ;
              rtyp = iddatyp (binid (binright (fpar))) ;
              rvar = idgetkind (binid (binright (fpar))) == IDVARPARAM ;
              chkdyadic (&osymc) ;
            end
           else
            begin                                       /* monadic op */
              chkpar (fpar) ;
              rtyp = iddatyp (binid (fpar)) ;
              rvar = idgetkind (binid (fpar)) == IDVARPARAM ;
              chkmonadic (&osymc) ;
            end
         end /* no ";" */
      end  /* any formal parameters */
     else
      begin
        errput(1040, pos, NULL) ;
                  /* An Operator must have formal parameters. */
      end ;

     if  (osymc != cAssign)
      begin
       if ( id() ) {
          posnores.line = 0 ;
          resid= idins(sym,IDRES2VAR);
          idsetbin(resid, bincurr);
          if  (not on_rename and not sym_is[osymc].userdefined)
            opcsym = sym ;  /* result id will be C name of Operator */

          binget();
       } else {
          posnores = pos ;   /* mark position, where result id is missing */
          resid = (idptr) NULL ;
          opcsym = symNIL ;
       }
       if ( chkc(cColon) )  {
          bininfix();                           /* insert ":" */

          bincurr = binidcreate (cIdent, resid) ;
          binsuffix () ;                        /* append result variable */
          binget();        /* skip ":" */
          restyp();                             /* append result type */
          if(binsymc (unname (iddatyp (binid (binright(binprev))))) == cFILE)
            {
              errput(1041, pos, NULL) ;
                        /* Filetype not allowed as Operator result */
            }

          oprestyp = binright (binprev) ;
          if (resid)
            idsetdatyp (resid, oprestyp) ;      /* assign result type to */
                                                /* result var */
          gofather();        /* go to ":" */
          op=opins(osymc,oppsym,opcsym, oprestyp,ltyp,rtyp, lvar,rvar);
          opsetbin (op,binleft (binprev));
          binupop (binleft (binprev) ,op);
          if (glob)   opfset (binop(binleft(binprev)), is_global) ;
       }
      end
     else       /* assignment    := */
      begin
        posnores.line = 0 ;
        binchange (binfather (binprev), cPROCEDURE) ;
        /* oprestyp = ltyp ;  /* right type is result type */
        if  (not lvar)  then
         {
           errput(1042, pos, NULL) ;
           /* The left operand of the assignment Operator
              must be a VAR parameter. */
         }
        op=opins(osymc,oppsym,opcsym, voidtype,ltyp,rtyp, lvar,rvar);
        opsetbin (op, binprev);
        binupop (binprev,op);
        if (glob)   opfset (binop(binprev), is_global) ;
      end

     gofather();                        /* go to OPERATOR */
     binexchange(binprev);              /* shift header left */

     if ( chkc(cSemicolon) )
        binget();

     return;
} /* opheader() */                              /*  o p h e a d e r  */
/*-------------------------------------------------------------------*/
/* END of routine 'OPHEADER()'                                       */
/*-------------------------------------------------------------------*/
