/*
 *  MODULE:  decl.c
 *  compilation of declarations
{*  last modification:  14.08.92   13:07  }


  *  Uli 04.2.91 : typdef: globglob set false
  *  Uli 18.2.91 : body: "Missing assignment to function result" added.
  *  Uli 22.2.91 : new style headers
  *  uli 06.03.91 : modcompile: del_extension replaced by prognam
  *  uli 17.04.91 : vardecl: call of moduniquename added.
  *  uli 18.04.91 : vardecl: forward flag set false.
  *  uli 23.04.91 : realconv added.
  *  uli 24.04.91 : constdef: "(<" added.
  *  uli 06.05.91 : bindecl set to cBlkptr node
  *  uli 07.05.91 : constdef: bincpool added.
  *  uli 07.05.91 : constdef: does no longer "unname" right side.
  *  uli 08.05.91 : rconstype added.
  *  uli 08.05.91 : constdef: "-" changed to r_umin.
  *  uli 15.05.91 : module head.c extracted from decl.c
  *  uli 24.05.91 : no export(), if error occurred.
  *  uli 29.05.91 : uniquename called, if sym_is[symc].rename
  *  uli 09.07.91 : typdef : rename typenames in any case.
  *  tim 10.07.91 : pop_parsloc has no parameter now.
  *  uli 26.07.91 : typdef : rename no longer used.
  *  uli 14.08.91 : body : posnores added.
  *  uli 19.08.91 : body : nogener replaced by nodecl.
  *  uli 19.11.91 : vardecl : dynamic arrays must be baptized.
  *  uli 29.11.91 : Check anytype and idBAD_ID before error reporting.
  *  uli 24.01.92 : body : olddecl inited in any case.
  *  PJ  02.07.92 : "GLOBAL" on the right side of a typedecl. without
                    "GLOBAL" on the left side causes an error.
  *  PJ  04.08.92 : variable decl. restriction for DEMOVERSION implemented.
  *  PJ  14.08.92 : CASE_SENSITIVE will be regarded in USE-clauses
                    and in program names
  *  tim 29.10.92 : vardef is now called vardecl
  *  tim 29.10.92 : typdef, vardecl: dynamic types are handled in alltyp now
*/
#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"
#include "module.h"
#include "sysutil.h"
#include "head.h"

#include             "implemen.t"

#include "runtime.h"


#ifdef LINT_ARGS
local  void     realconv (idptr *) ;
local  void     priodef (void);
local  void     constdef (register boolean);
local  void     typdef (register boolean, register boolean);
local  void     vardecl (register boolean );
local  void     body (void);
local  void     declarations (register boolean);
local  void     chkfileparameters (void) ;
local  void     program (void);
local  void     modcompile (void);

#else

local  void     realconv () ;
local  void     priodef();
local  void     constdef();
local  void     typdef();
local  void     vardecl();
local  void     body ();
local  void     declarations();
local  void     chkfileparameters () ;
local  void     program ();
local  void     modcompile ();

#endif

local char * std_mod = STDmod ;



                                                /*-------------------*/
#ifdef LINT_ARGS
local void realconv (idptr * idrconv)           /*  r e a l c o n v  */
#else
local void realconv (idrconv)
  idptr * idrconv ;
#endif
BEGIN(realconv)
   if  (*idrconv)  then
     begin
       errput(1046, pos, NULL) ;
                    /* Real constant conversion already defined. */
     end ;
   setparsloc(DECL, cREALCONSTANTCONVERSION);
   if ( chkid () ) {
      *idrconv = idlclfnd (sym);
      if  (*idrconv)  then
        /* check for correct declaration */ ;
      else
       begin
         *idrconv = idins (sym, IDFUNCTION) ;
         idsetbin(*idrconv, bincurr);
         idsetdatyp (*idrconv, binidcreate (cREAL, idtypfnd (sREAL))) ;
         if  (id_is (idtypfnd (sREAL), hasdyn))
            idfset (*idrconv, hasdyn) ;
         idsetparlist (*idrconv, binidcreate (cIdlist, idCHAR)) ;
         idfset (*idrconv, forward) ;
       end ;
      binget();
   }
   pop_parsloc();
   if ( chkc(cSemicolon) )
      binget();
END /* realconv */                              /*  r e a l c o n v  */
                                                /*-------------------*/


                                                /*-----------------*/
#ifdef LINT_ARGS
local void priodef ( void)
#else
local void priodef()                            /*  p r i o d e f  */
#endif
BEGIN(priodef)
 register symptr sy;

 sy=sym; binget();
 if ( chkc(cEQ) )
    binget();        /* symtab entry to be modified */
 switch (symc)
  begin
    case cEQ:    symchange (sy, cRelop) ;  break ;
    case cPlus:  symchange (sy, cAddop) ;  break ;
    case cMult:  symchange (sy, cMulop) ;  break ;
    case cArrow: symchange (sy, cMonop) ;  break ;
    default:
        errput(1008, pos, NULL) ;
                  /* =, +, * or ^ expected. */
        ery_loahd( cPlus);
  end ;
 binget();
 if (symc == cSemicolon) then binget();
END /* priodef */                               /*  p r i o d e f  */
                                                /*-----------------*/


                                                /*-------------------*/
#ifdef LINT_ARGS
local void constdef  ( register boolean glob )
#else
local void constdef (glob)                      /*  c o n s t d e f  */
 register boolean glob;
 /* Appends a constant definition including a ";" right of binprev. */
 /* At return binprev refers the ";". */
#endif
BEGIN(constdef)
 register idptr idp;
 register binptr  datyp ;
 boolean minus = false ;
 boolean rename = sym_is [symc].rename ;

 symjustdef = sym ;               /* store left side symbolpointer */
 chkid();
 binsuffix() ;
 binget();
                                      /*       \     */
                                      /*       |;|   */
 if ( chkc(cEQ) )  {                  /*      /      */
    binchange (bincurr, cCONST);      /*   |CONST|   */
    bininfix();                       /*    /   \    */
    binget();                         /*  id  value  */

    minus = (symc == cMinus) ;
    if (minus)  then
     begin
       binchange (bincurr, cMMinus) ;             /* mono - */
       binsuffix () ;
       binget () ;
     end
    else
    if (symc == cPlus)  then
     begin
       binget () ; /* ignore + */                 /* mono + */
     end

    if  (symc == cLParD or symc == cLParU)  then
      begin
          if  (idrdconv == (idptr)0  or  idruconv == (idptr)0)
            errput (1424, pos, NULL) ;
                        /* Rounded real constant conversion not declared. */
          binsuffix() ;                      /* append (< */
          binget () ;
          datyp = konst() ;
          if  (datyp != rconstype and datyp != anytype)
            errput (1059, binpos (binright(binprev)), NULL) ;
                                       /* real constant expected */
          gofather() ;
          chkc (cRParent) ;
          binget () ;
      end
    else
      datyp = konst() ;

    if  (binsymc (binprev) == cMMinus)  then
     begin
       opptr op ;
       binptr p = binright (binprev) ;

       op = opfnd (cMMinus, symNIL, NIL, rconstype, binpos(binprev)) ;
       IF op and opcsym(op) != symNIL THEN    /* Operator found */

         IF op_is (op,varpr) THEN    errput (1060, pos, NULL) ;
            /* -real should not have a VAR-parameter.  */
#ifdef NEW
           IF not id_is (binid (rconstype),arraytype) THEN
             IF sym_is [binsymc (p)].identifier THEN
               varparam( p, false);
             ELSE
               varexp( p, rconstype );
             FI
           FI
#endif
         FI
         binchange (binprev, cCall) ;
         binupsym (binprev, opcsym (op)) ;
         IF  id_is (binid (rconstype),arraytype) THEN
             binptr tempvar = tempdecl ("af",rconstype );
             binchange( tempvar,cTempvar);
             IF  p  THEN
               p = bininsert( p , bincreate(cComma));
               binappend( p,binsycreate(binsym(tempvar)));
               binexchange(p);
             ELSE
               binappend( binprev,binsycreate(binsym(tempvar)));
             FI
         FI
       FI
       gofather () ;
     end   /* constant preceeded by minus */

    idp = idins (symjustdef, IDCONST);
    idsetbin(idp, binleft(binprev) );
    binupid (binleft (binprev), idp) ;
    if (glob)   idfset (idp, is_global) ;
    idsetdatyp(idp, datyp );         /* konst returns the data type */

    if  (datyp == rconstype)
     begin                      /* add to constant pool */
       if  (bincpool) then
             bincpool = binappend (bincpool, binidcreate (cIdlist, idp)) ;
       else  bincpool = binidcreate (cIdlist, idp) ;
       if  (on_rename)
       if (on_bib) then
         idsetcsym (idp, moduniquename()) ;
       else
         if  (glob)   idsetcsym (idp, moduniquename()) ;
         else         idsetcsym (idp, uniquename("cn")) ;
       idsetvalue(idp, binright(binprev) );
                                        /* assign the value to the ident */
     end
    else
     begin
       idsetvalue(idp, unname (binright(binprev)) );
                          /* assign the unnamed value to the ident */
       if  (rename)  then
         idsetcsym (idp, uniquename ("rn")) ;
     end ;

    if (chkc(cSemicolon) )  {
       bininfix();
       binget();
    }
    else {
       binprev = bininsert( binprev, bincreate(cSemicolon)) ;
          /* insert semicolon node in order to recover tree structure */
    }
 }
 symjustdef = symNIL;
END /*constdef*/                                /*  c o n s t d e f  */
                                                /*-------------------*/


                                                        /*---------------*/
#ifdef LINT_ARGS
local void typdef ( register boolean is_module, boolean glob )
#else
local void typdef(is_module, glob)                      /*  t y p d e f  */
  register boolean is_module, glob ;
#endif
BEGIN(typdef)
  idptr idp;  /* idp = id to be declared */
  register boolean hidd ;
  boolean hasdyn, forwdecl, globglob;
 /*old: boolean rename = sym_is [symc].rename ; */

 symjustdef = sym;
 hasdyn = false;
 forwdecl = false;
 if ( chkid() ) {                              /* ident to be defined */
    idp = idlclfnd(sym);
    if ( !(idp))  {
       forwdecl = false;            /* there is no forward declaration */
    }
    else if (id_is(idp, forward) && idgetkind(idp) == IDTYPE)  {
       idfclr (idp, forward) ;
       del_forw(idp,blocklevel);
                           /* delete forward reference of current block */
                                               /* with id-pointer 'idp' */
                   /* existence of pool warranted by 'else if'-condition */
       forwdecl = true;
    }
    else if (idp != idBAD_ID) {        /* no IDTYPE on same blocklevel */
       errput(1022, pos, NULL) ;
                     /* Identifier already declared */
    }
    binsuffix() ;
    binget();
 }

 if ( chkc(cEQ) ) {  /* panic mode avoiding spurious errors */
    binchange (bincurr, cTYPE);
    bininfix();                            /* insert  TYPE keyword */
    binget();

    hidd =  symc != cGLOBAL ;              /* global */
    if (hidd) then
     begin /* if (is_module)  then  idhidd(idp) */ ;
       globglob = false ;
     end
    else
     begin
       if (not is_module)  then
       begin
         errput(1023, pos, NULL) ;
         /* A global specification is only allowed in a module declaration. */
       end
       else
         if (!glob)
           errput( 1027, pos, NULL );
           /* P.J. 2.7.92 : */
           /* Typedefinition must not be global
              when typedeclaration is not global */
       binget();  /* skip global */
       globglob = true ;
     end ;

    alltyp (not hidd, &hasdyn) ;

    idp = idlclfnd(symjustdef );
    if ( !(idp) )  {
       idp=idins(symjustdef, IDTYPE);
                                   /* create idtab-entry if there is none */
       idsetbin(idp, binleft(binprev) );
    }
    del_forw(idp, blocklevel);                        /* check up pool */

    binupid (binleft(binprev), idp) ;
    if  (glob)   idfset (idp, is_global) ;
    if  (blocklevel == IDMAINLEVEL and
         binsymc (binroot) == cMODULE  and  on_rename)
       idsetcsym (idp, moduniquename ()) ;
    else
     if  (on_rename /*old: rename*/)  then
       idsetcsym (idp, uniquename ("ty")) ;

    if  (hasdyn) idfset (idp, hasdyn) ;
    if  (globglob) idfset (idp, globalglobal) ;
    idsetdatyp (idp, unname (binright (binprev)));
    if ( forwdecl && binsymc( binright(binprev) ) != cRECORD )
       errput ( 1052, binpos(binright(binprev)), NULL);
                          /* Forward declared types must be record-types. */
    if ( chkc(cSemicolon) )  {
       bininfix();
       binget();
    }
    else {
       binprev = bininsert( binprev, bincreate(cSemicolon)) ;
          /* insert semicolon node in order to recover tree structure */
    }
 }
 symjustdef = symNIL;
END /*typdef*/                                          /*  t y p d e f  */
                                                        /*---------------*/

                                                        /*---------------*/
#ifdef LINT_ARGS
local void vardecl ( register boolean glob )
#else
local void vardecl(glob)                               /*  v a r d e c l */
  register boolean glob ;
#endif
BEGIN(vardecl)
  idptr    idp; /* name of variable */
  idptr  typid; /* right side type id */
  binptr  root;
  boolean forw = false ; /* "any variable is forward declared" */
  boolean hasdyn = false ; /* normally a variable has no dynamic element */


 root = binprev ;

 repeat
  chkid () ;
  binchange (bincurr, cIdlist);
  idp = idforfnd (sym) ;
  if  (blocklevel == IDMAINLEVEL and
       idgetkind (idp) == IDVAR and id_is (idp, forward))  then
    /* forward declared by program file parameter list */
   begin
     forw = true ;
     idfclr (idp, forward) ;
   end
  else
    idp = idins (sym, IDVAR) ;
  idsetbin(idp, bincurr);
  binupid (bincurr, idp);
  if (glob)
   begin
     idfset (idp, is_global) ;
     if  (on_rename )  then
       idsetcsym (idp, moduniquename ()) ;
   end
  else                                                           /*neaga*/
   if  (blocklevel == IDMAINLEVEL and
       binsymc (binroot) == cMODULE  and  on_rename and on_bib)
       idsetcsym (idp, moduniquename ()) ;
   else                                                          /*neaga*/
   if  (sym_is [symc].rename)  then
       idsetcsym (idp, uniquename ("rn")) ;

  binsuffix () ;
  binget ();
  if (symc!=cComma)                /* encouraging error recovery */
     chkc(cColon);

  if (symc==cComma)
     binget () ;

until (symc==cColon or symc == cEndofSrc or stoppars(DECL) );
if (not stoppars(DECL) )  {    /* panic mode */
 binprev = binright (root) ;    /* go to start of idlist */
 binchange (bincurr, cVAR) ;
 bininfix () ;                  /* insert VAR */
 binget(); /* skip ":" */

 if  (symc == cGLOBAL)  then   binget() ;

 if  (id())
  begin
    typid= idfnd(sym) ;
    if (idgetkind(typid) == IDFUNCTION)  then
           typid = idtypfnd (sym) ;

    alltyp(/* glob= */ false, &hasdyn);

  end

 else                                           /* not type identifier */
    alltyp(/* glob= */ false, &hasdyn);

 if  (forw and binsymc (unname(binright (binprev))) != cFILE)  then
  begin
   errput(1026, binpos (binright (binprev)), NULL) ;
                           /* A program parameter must be file type. */
  end ;

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

 typassg (binleft (binprev), binright (binprev), hasdyn);
 if ( chkc(cSemicolon) )  {
    bininfix () ;
    binget () ;
 }
 else {
    binprev = bininsert( binprev, bincreate(cSemicolon)) ;
       /* insert semicolon node in order to recover tree structure */
 }
}
END /*vardecl*/                                      /*  v a r d e c l */
                                                     /*----------------*/



                                                        /*-----------*/
#ifdef LINT_ARGS
local void  body ( void)
#else
local void  body()                                      /*  b o d y  */
#endif
BEGIN(body)
  binptr root;
  binptr olddecl ; /* save old bindecl */
  binptr routptr;  /* pointer to routine name or opptr */
  idptr idp ;      /* identifier of the routine */
  opptr opp ;      /* optab entry */

 olddecl = bindecl ;           /* save old bindecl */
 root = binprev ;       /* pointing to PROCEDURE or FUNCTION or OPERATOR */
 routptr = binleft (binprev) ;
 if  (binsymc (routptr) == cColon)  then
    routptr = binleft (routptr) ;
 idp = binid (routptr) ;
 opp = binop (routptr) ;
 if  (symc == cFORWARD)  then
  begin
   binsuffix () ;
   binget();
   if  (idp)  then
     idfset (idp, forward) ;
   else
     opfset (opp, forward) ;
   blksetfor (blkfather (actblock), true);  /* Increase forward-counter */
  end
 else

 if  (symc == cEXTERNAL)  then
  begin
   if  (idp)  then
     idfset (idp, external) ;
   else
     opfset (opp, external) ;
   binsuffix () ;
   symsetorg (true);
   binget () ;
   symsetorg (false);
   if  (symc != cSemicolon)  then       /* external name specified */
     begin
      gofather () ;
      if (id() or symc==cCsymbol)  then /* external name is an identifier */
        if  (idp)  then
          idsetcsym (idp, sym) ;
        else
          opsetcsym (opp, sym) ;
      else
      if  (symc == cScon)  then
       begin                            /* external name is a string */
        if  (idp)  then
           idsetcsym (idp, symins (symstring)) ;
        else
           opsetcsym (opp, symins (symstring)) ;
       end
      else
       begin
        errput(1043, pos, NULL) ;
        /* The external name must be an Identifier or a string constant. */
       end
      binget () ;
     end /* runtime name */
   else
    if  (idp)  then
      idsetcsym (idp, idsym (idp)) ;    /* Pascal name is C name */
    else
     if  (posnores.line)
      begin
        opsetcsym (opp, symNIL) ;
        opfset (opp, nodecl) ;   /* suppress generation of prototype */
      end
     else
        opsetcsym (opp, idsym (binid (binright (binleft (root))))) ;
                                        /* result name is C name */

  end /* external specification */
 else

 begin  /* no external, no forward specification */
  if  (idp)  then
     idfclr (idp, forward) ;
  else
     opfclr (opp, forward) ;

  if  (opp and posnores.line)  then
     errput (1061, posnores, NULL) ; /* Operator result name missing. */

  binappend (binprev, bincreate (cBlkptr)) ;    /* add blockpointer node */
  goright () ;
  binupblk (binprev, actblock) ;
  bindecl = binprev ;           /* set new bindecl */

  setparsloc(DECL, cMODULE );       /* main program is comparable to */
                                    /* module for error recovery */
  declarations (/* is_module= */ false);        /* declarations */
/*  if  (on_dump)  then   iddump() ; */
  chkc(cBEGIN);
  /* if  (binright (binprev))
      goright () , */
  bininfix () ;
  /* else  binsuffix () ;          /* no declarations */

  bindecl = binprev ;           /* set new bindecl */
  binget();
  setparsloc(STM, cBEGIN);
  stms();           /* statements */
  chkc(cEND);
  resetparsloc(STM);
  pop_parsloc();
  /* printf("*/
/*  if (parsloc[DECL].stop) ;  */
            /* = %d\n", (int)parsloc[SYNTAX].stop); */
  if ( not stoppars(DECL) )
     binget();
/*
  if  (on_dump)  then   iddump() ;
*/
  if  (idcurrf)
    if  (id_is (idcurrf, generated))  then
      idfclr (idcurrf, generated) ;  /* reset flag */
    else
      errput (1057, binpos (idbin (idcurrf)), NULL) ;
                           /*  Missing assignment to function result */

 end /* statement part */

 blkend () ;
                                /* handling forward references */
 resol_forw(blocklevel + 1);               /* at blockend */
 bindecl = olddecl ;            /* restore bindecl */
 binprev = root ;
END /*body*/                                            /*  b o d y  */
                                                        /*-----------*/



                                        /*---------------------------*/
#ifdef LINT_ARGS
local void declarations ( register boolean is_module )
#else
local void declarations(is_module)      /*  d e c l a r a t i o n s  */
  register boolean is_module ;
#endif
BEGIN(declarations)
  /* binptr    st,s1,s2,s3; */
  register binptr              root;
  idptr                  i;
  char             lab[20];
  boolean             glob;
  boolean    stop = false ;    /* stops this procedure */

#if INTERMEDIATE
  binptr lastbinprev;
#endif

 root = binprev ;
 repeat

#if INTERMEDIATE
  lastbinprev=binprev;
#endif

  idglobdecl = glob = symc == cGLOBAL ;
  if (glob) then
   begin
    if  (not is_module)  then
     begin
      errput(1044, pos, NULL) ;
      /* A global specification is only allowed in a module declaration. */
      idglobdecl = glob = false ;
     end
    binget();  /* skip global */
   end

 /* recovery-action inserted here !!!!!!!!!!!!!!!!!! */
 switch (symc)
  begin
   /*------------------*/
   /*  label           */
   /*------------------*/
   case cLABEL:                                         /* LABEL found */
       repeat
         binget();
         setparsloc(DECL, cLABEL);
         if  (symc != cIcon)  then
          begin
            errput(1045, pos, NULL) ;
                         /* Label number expected. */
          end ;
         sprintf (lab, "_l%ld", symvalue) ;
         i = idins (symins(lab), IDLABEL);

         idsetbin (i, binidcreate (cIdent, i));
         idfset( i, forward) ;
         blksetfor (actblock, true);    /* Increase forward-counter */
         binget();
         if (symc!=cComma)
            chkc(cSemicolon);
       until (symc == cSemicolon || stoppars(DECL) );
       pop_parsloc();
       if (not stoppars(DECL) )
          binget();
   break ; /* LABEL */

   /*--------------------------*/
   /*  realconstantconversion  */
   /*--------------------------*/
   case cREALCONSTANTCONVERSION:                  /* realconstconv found */
       binget();
       if  (symc == cLParD)  then
         begin
           binget();
           realconv (&idrdconv) ;
         end
       else
       if  (symc == cLParU)  then
         begin
           binget();
           realconv (&idruconv) ;
         end
       else
         begin
           realconv (&idrconv) ;
           rconstype = iddatyp (idrconv) ;
         end
   break ; /* REALCONSTANTCONVERSION */

   /*------------------*/
   /*  const           */
   /*------------------*/
   case cCONST:                                         /* const found */
       binget();
       while (id())   {
          setparsloc(DECL, cCONST);
          constdef( glob );
          pop_parsloc();
       }
   break ; /* CONST */

   /*------------------*/
   /*  type            */
   /*------------------*/
   case cTYPE:
       binget();
       do   {
          setparsloc(DECL, cTYPE);
          typdef( is_module, glob);
          pop_parsloc();
       } while (id()) ;
   break ; /* TYPE */

   /*------------------*/
   /*  var             */
   /*------------------*/
   case cVAR:
        binget();
        while (id())  {
           setparsloc(DECL, cVAR);
           vardecl(glob);
           pop_parsloc();
        }
   break ; /* VAR */

   /*------------------*/
   /*  priority        */
   /*------------------*/
   case cPRIORITY:
       if  (blocklevel > IDMAINLEVEL)  then
         begin
           errput (101, pos, NULL) ;
           /* A local priority definition will be valid in the whole source file. */
         end ;
       binget();
       while (id())   {
          setparsloc(DECL, cPRIORITY);
          priodef();
          pop_parsloc();
       }
   break ; /* priority */

   /*------------------*/
   /*  Operator        */
   /*------------------*/
   case cOPERATOR: ;
       setparsloc(DECL, cOPERATOR);
       opheader (glob) ;
       pop_parsloc();
       body () ;
       if ( chkc(cSemicolon) )  {
          bininfix () ;
          binget();
       }
       else                     /* error! inserting semicolon in order to */
                                /* recover tree-structure */
          binprev = bininsert (binprev, bincreate(cSemicolon) );
   break ;

   /*-------------------------*/
   /*  procedure or function  */
   /*-------------------------*/
   case cPROCEDURE: ;
   case cFUNCTION:
       setparsloc(DECL, symc);
       header (glob) ;
       blkfclr (actblock, innerrout) ;
          /* avoids denesting of routine with func/proc parameters */
       pop_parsloc();
       if (chkc(cSemicolon) ) {
          binget () ;
       }
       body () ;
     /*
       if (binsymc (binright (binright (binprev))) == cEXTERNAL) then
         idextern (binid(binleft (binright (binprev))));
     */
       if ( chkc(cSemicolon) )  { /* no error in procedure or function */
          bininfix () ;
          binget();
       }
       else                     /* error! inserting semicolon in order to
                                      recover tree-structure */
          binprev = bininsert (binprev, bincreate(cSemicolon) );
   break ;  /* routine */

   default:if (symc == cBEGIN || ( is_module && symc == cEND) )
                      /* only 'BEGIN' or 'END' (in a module) are correct */
              stop = true;
           else {                /* error! */
              errput (1064, pos, NULL) ;
                     /* Error in declaration part. */
              ery_loahd(/* symbol to start match is */ ALTLISTBEG);
             /* 'chkc' involves significant side effects on symc */
              stop = (symc == cBEGIN);
           }
  end /* switch symc */ ;
 contpars(DECL);  /* after recovery action DECL is continued anyway */

#if INTERMEDIATE
  if ( blocklevel==IDMAINLEVEL and not stop )
     generate (binright (lastbinprev));
#endif

 until (stop) ;  /* until no more declarations */

 if  (binsymc(binprev) == cSemicolon)  then   bindelete (binprev) ;
 binprev = root ;
END /*declarations*/                   /*  d e c l a r a t i o n s  */
                                       /*---------------------------*/



                                        /*-----------------------------------------*/
#ifdef LINT_ARGS
local void  chkfileparameters (void)
#else
local void  chkfileparameters ()      /*  c h k f i l e p a r a m e t e r s  */
#endif
BEGIN(chkfileparameters)
  binptr p = binright (binleft (binroot)) ;
  idptr idp ;

  while  (p)
   begin
     idp = binid (p) ;
     if  (id_is(idp, forward) or binsymc (unname(iddatyp(idp))) != cFILE)
        errput(1026, binpos (p), NULL) ;
                /* A program parameter must be a file variable. */
     p = binright (p) ;
   end
END /* chkfileparameters */



                                        /*-----------------*/
#ifdef LINT_ARGS
local void   program ( void)
#else
local void   program()                  /*  p r o g r a m  */
#endif
BEGIN(program)
  idptr  idp ;     /* file parameter name */

  binroot = binprev = bincreate(cPROGRAM);      /* create root */
  binuppos (binprev, pos) ;                     /* do not use binsuffix! */
  if ( chkc(cPROGRAM) )
     binget();
  if ( chkid() )  {                                  /* program name */
     binchange (bincurr, cCall) ;
     binsuffix () ;                                /* suffix it right */
     binupsym (binprev, sym) ;
  /* binupid (binprev, idcreate(sym, IDPROGRAM))  ; */
     binget();
  }
  blkbegin ((idptr)0) ; /* enter use level */

  if (symc != cSemicolon && !stoppars(DECL))  then
  begin                                         /* file parameter */
    if ( chkc(cLParent) )  {             /* '(' found ? */
       binget();

       repeat
         if ( chkid () )  {
            binchange (bincurr, cIdlist);
            idp = idfnd (sym) ;
            if  (idp != idINPUT and idp != idOUTPUT)  then
             begin
               idp = idins(sym, IDVAR) ;
               /* idsetdatyp (idp, bincreate (cFILE)) ; */
               idfset (idp, forward) ;
             end ;
            binupid (bincurr, idp);
            binsuffix () ;
            binget ();
            if (symc != cComma)           /* encouraging error recovery */
               chkc(cRParent) ;

            if (symc==cComma)
                binget () ;
         }
       until (symc==cRParent or symc == cSemicolon or symc == cEndofSrc
                  or stoppars(DECL) );
       if ( not stoppars(DECL) )
          binget();   /* skip ")" */
    }   /* if chkc( cLParent ) */
    while  (binsymc(binprev) == cIdlist)
       gofather () ;
  end /* program parameter */

  gofather () ;
  binprefix () ;                                /* shift progname left */
  if ( chkc(cSemicolon) )
     binget();

  binappend (binprev, bincreate (cBlkptr)) ;    /* add blockpointer node */
  goright () ;
  binupblk (binprev, actblock) ;
  bindecl = binprev ;           /* set bindecl */

  if (strcmp (std_mod, prognam()) != 0)
    insmod (std_mod, false, true);

  while (symc == cUSE)                          /* use clause */
  begin
    symsetorg( CASE_SENSITIVE );       /* PJ 14.08.92 */
    binget();
    if (symc == cGLOBAL)                        /* use global clause */
     begin
       errput (102, pos, NULL) ;
       /* global in the use clause of a program is ignored. */
       binget() ;
     end ;
    while (symc != cSemicolon && !stoppars(DECL) )
    begin                              /* module names */
      if ( chkid() )  {

         insmod(symtab(sym), false, true);
         binget();
         if (symc != cComma)      /* encouraging error recovery */
            chkc(cSemicolon);

         if (symc == cComma)
            binget();
      }
    end
  symsetorg(false);
  if ( not stoppars(DECL) )
     binget();
  end /* until not USE */

  import ();    /* uses global modlist and initlist */

#if INTERMEDIATE
  generate (binroot);
#endif

  blkbegin ((idptr)0) ; /* enter main level */

  setparsloc(DECL, cMODULE);
  declarations (/* is_module= */ false); /* declarations */

  chkfileparameters () ;

/*  if  (on_dump)  then   iddump() ; */
  chkc(cBEGIN);
  bininfix () ;         /* insert BEGIN above Blkptr */
  binget();

  bindecl = binprev ;           /* set bindecl */
  setparsloc(STM, cBEGIN);
  stms();                       /* statement sequence */
  chkc(cEND);
  resetparsloc(STM);
  pop_parsloc();

  blkend () ; /* exit main level */
                              /* handling forwardreferences */
  resol_forw(blocklevel + 1);             /* at blockend */
  blkend () ; /* exit use level */
                              /* handling forwardreferences */
  resol_forw(blocklevel + 1);             /* at blockend */
  binprev = binroot ;

#if INTERMEDIATE
  generate (binright (binroot));
#endif

  binget();
  chkc(cPoint);
END /*program*/                         /*  p r o g r a m  */
                                        /*-----------------*/

                                        /*-----------------------*/
#ifdef LINT_ARGS
local void   modcompile  ( void)
#else
local void   modcompile ()              /*  m o d c o m p i l e  */
#endif
BEGIN (modcompile)
  boolean glob;

  binroot = binprev = bincreate(cMODULE);       /* create root */
  binuppos (binprev, pos) ;                     /* do not use binsuffix! */
  symsetorg( CASE_SENSITIVE );
  binget() ;
  symsetorg(false);
  if ( chkid() ) {                           /* module name */

     if (strcmp (prognam(), symtab (sym)) != 0)
      begin
        errput(1047, pos, NULL) ;
                 /* Module name should be identical with the filename. */
      end

     binchange (bincurr, cCall);
     binsuffix ();
     binupsym (binprev, sym) ;

     binget();     /* skip module name */

     blkbegin ((idptr)0) ; /* enter use block */

     gofather ();
     binprefix ();         /* shift module name left */
     if ( chkc(cSemicolon) )
        binget();

     binappend (binprev, bincreate (cBlkptr)) ; /* add blockpointer node */
     goright () ;
     binupblk (binprev, actblock) ;
     bindecl = binprev ;        /* set bindecl */

     if (strcmp (std_mod, prognam()) != 0)
       insmod (std_mod, false, true);
  }
  while (symc == cUSE)                     /* use clause */
  begin
    symsetorg(true);
    binget() ;
    glob = (symc==cGLOBAL);
    if (glob)   binget() ;                 /* use global clause */
    while (symc != cSemicolon && not stoppars(DECL) )
    begin
     if ( chkid() ) {

        insmod(symtab(sym), glob,true);    /* insert name in modlist */
        binget();                          /* skip module name */

        if (symc != cComma)             /* needed for error recovery */
           chkc(cSemicolon);

        if (symc == cComma)
           binget();
     }
    end /* until ";" */

    symsetorg(false);
    if ( not stoppars(DECL) )
       binget();    /* skip ";" */
  end /* use clause */

  import ();    /* uses global modlist and initlist  */

#if INTERMEDIATE
  generate (binroot);
#endif

  blkbegin ((idptr)0) ; /* enter main level */

  setparsloc(DECL, cMODULE);
  declarations(/* is_module= */ true);  /* declarations */

  if  (symc == cBEGIN) then
   begin
     bininfix () ;
     binget();
     bindecl = binprev ;        /* set bindecl */
     setparsloc(STM, cBEGIN);
     stms();                    /* statement sequence */
     resetparsloc(STM);
   end
  else
    bininsert (binprev, bincreate (cBEGIN)) ;

/*  if  (on_dump)  then   iddump() ; */

  chkc(cEND);

  pop_parsloc();

  if  (os_code ? on_code : errcount==0)   export ();

  blkend () ;   /* exit use level */
                           /* handling forwardreferences */
  resol_forw(blocklevel + 1);             /* at blockend */
  blkend () ;   /* exit main level */
                           /* handling forwardreferences */
  resol_forw(blocklevel + 1);             /* at blockend */
  binprev = binroot ;

#if INTERMEDIATE
  generate (binright (binroot));
#endif

  binget();
  chkc(cPoint);

END  /* modcompile */                          /*  m o d c o m p i l e  */
                                               /*-----------------------*/

                                        /*---------------*/
#ifdef LINT_ARGS
global boolean pass1  ( void)
#else
global boolean pass1 ()                 /*  p a s s 1    */
#endif
BEGIN(pass1)
  initparsloc();
  binget();
  if (symc==cMODULE) {
    setparsloc(DECL, cMODULE);
    modcompile();                    /* module */
    resetparsloc(DECL);
    finish_errecy();            /* delete data of error-recovery */
    return (false);
  }
  else {
    setparsloc(DECL, cPROGRAM);
    program();                       /* program */
    resetparsloc(DECL);
    linklist ();                     /* create list of modules for linker */
    finish_errecy();            /* delete data of error-recovery */
    return (true);
  }
END /*pass1*/

