/*
 *  MODULE:  stm.c
 *  statement analysis
{*  last modification:  27.10.92  16:40   }


 *  uli 19.12.90: with-variable has leftside-flag
 *  uli 04.01.91: prototypes added, if ( = ) corrected, unused vars deleted
 *                CLR_TEMP is void function
 *  uli 09.01.91: auswahl: type check of right side of range corrected
 *  Uli 29.01.91: expression and seman have callclass parameter
 *  Uli 08.02.91: stm no longer checks left side of :=
 *  uli 06.03.91 : new style headers.
 *  uli 12.03.91 : FOR statement: type compatibility will be checked
 *  dima 10.04.91: idflag forvariable set and reset in DO-statement
 *  uli 03.05.91 : binend add and stmapp replaced.
 * Dima 17.06.91 : global clrtmp added
 *  uli 10.07.91 : with-statement: withc added.
 *  tim 10.07.91 : pop_parsloc has no parameter now.
 * Dima 15.07.91 : clrtmp moved to seman
 *  uli 26.07.91 : cFOR: assignment moved out of IF.
 *  tim 17.09.91 : setparsloc calls moved to beginning of statement parsing.
 *  tim 19.09.91 : setparsloc call with parameter cPROCEDURE added.
 *  uli 26.09.91 : konst and symjustdef moved from seman.c.
 *  uli 26.09.91 : konst : default case : chkc (cIcon) added, anytype returned
 *  uli 26.09.91 : get_parsloc has no parameter now.
 *  uli 28.11.91 : konst checks symNIL and IDNONE before reporting error.
 *  uli 29.11.91 : konst checks idvalue(idp) before changing bincurr.
 *  tim 27.01.92 : stm : contpars added.
 *  uli 02.04.92 : stms: checks EndofSrc.
 *  uli 23.04.92 : stm : FOR statement: for-variable must be declared as var.
 *  tim 27.10.92 : handling of standard-procedure 'allocate' added
 *  PJ  30.03.95 : casts for ANSI compatibility inserted
*/

#define Writeln(msg)              {print(msg);printline();}
#include <stdio.h>
#include <stdlib.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 "errecy.h"
#include "std.h"
#include "syntax.h"
#include "seman.h"
#include             "expor.t"
#include "stm.h"
#include             "implemen.t"

#include "runtime.h"



 /*****************************/
 /*   E X E C U T A B L E S   */
 /*****************************/

#ifdef LINT_ARGS
local boolean handlstmsto (void);
local void allocstm  (void);
local void stm( void);
local void einausanw( void);
local void einausliste (int);
local idptr stdio ( symctype sy,symctype *fc );
local void iobincopy (symctype, idptr, symctype, idptr, postype);

local void auswahl (binptr);
local void chkboolean (binptr);

local binptr stmins (binptr);
local binptr stmapp (binptr);
#else
local void allocstm  ( );
local boolean handlstmsto ();
local void stm();
local void einausanw();
local void einausliste ();
local idptr stdio ( );
local void iobincopy ();

local void auswahl ();
local void chkboolean ();
local binptr stmins  ();
local binptr stmapp  ();
#endif


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


/*****************************/
/*  I N P U T / O U T P U T  */
/*****************************/

#define  NUREINP   2

                                       /*-------------------------*/
                                       /*  e i n a u s l i s t e  */

/* procedure expecting expression : at bincurr                  *
 * generating argumentlist.                                     *
 * binprev pointing at expr. or file-node                       *
 * Eventually binprev points to io node and bincurr contains ")"*
 * "," node                                                   *
 */

#ifdef LINT_ARGS
local void einausliste ( int parac )
#else
local void einausliste(parac)
int parac;                    /* counting parameters of */
            /* io-Statements,in order to distinguish file variables */
#endif
BEGIN(einausliste)
 binptr root ;
 boolean gehrechts ;               /* avoids binprev being set to nil */

 root = binfather(binprev);
 while (binsymc(root)==cComma )                 /* listenode            */
    root = binfather(root);                     /* root is io-node      */

 switch ( binsymc ( root ))
 begin
  case cWRITELN: binchange( root, cWRITE );
  case cWRITE  : binupid(root,idfnd(sWRITE));   /* set id of io-node   */
                 break;
  case cREADLN : binchange( root,cREAD );
  case cREAD   : binupid(root,idfnd(sREAD));
                 break;
  default :errput(9651, binpos(root), symptext[binsymc(root) ] );
          /* Symbolcode in root: @. READ(LN) or WRITE(LN) expected */
 end; /* switch */

 if (symc!= cColon and symc != cComma and symc != cRParent) then
                                               /* expression expected */
 begin
    bininsert( binprev, bincreate(cComma) );    /* generate list node   */
    gofather();                                 /* binprev on listnode  */
 end;

 if (parac > 1)   {                       /* syntax check for parameter */
    setparsloc(SYNTAX, cComma);
    syntax();                             /* after first parameter */
    resetparsloc(SYNTAX);
 }
 gehrechts = (parac > 1);
 while ( symc == cColon )
  begin                                          /* format specifikation */
        binchange(bincurr, cComma );     /* new list element  */

        if (gehrechts)          /* goright is suppressed only */
            goright();           /* for first part of first param.  */
        gehrechts = true;
        bininfix();
        binget ();
        setparsloc(SYNTAX, cColon);
        syntax();
        resetparsloc(SYNTAX);
 end;
 binprev = root;

END /*einausliste*/                    /* e i n a u s l i s t e  */
                                       /*------------------------*/


#ifdef LINT_ARGS
local idptr stdio  (  symctype sy,symctype *fc)
#else
local idptr stdio (sy, fc)                       /*  s t d i o  */
 /* generating standard iofilenode as right       *
  * son. Binprev unchanged. Returns idptr at io.  *
  */
 symctype          sy; /* procedure name */
 symctype         *fc;
#endif
 BEGIN(stdio)
   idptr fn ;

    if (sy==cREAD or sy==cREADLN) then
    begin
      fn = idINPUT;
      *fc= cINPUT;
    end
    else
    begin
      fn = idOUTPUT;
      *fc = cOUTPUT;
    end;
    if (fn == idBAD_ID ) then
    begin
     if (sy==cREAD or sy==cREADLN) then /* file input not declared */
          errput (1102, pos, NULL) ;
     else                               /* file output not declared */
          errput (1103, pos, NULL) ;
    end
    binappend(binprev,binidcreate(*fc,fn));     /* append text node */
    RETURN(fn) ;
END /* stdio */                                  /*  s t d i o  */
                                                 /*-------------*/

/* copying io node and file node      */


#ifdef LINT_ARGS
local void iobincopy (symctype ioc,idptr ioid,
                        symctype fc,idptr fid,postype iopos)
#else
local void iobincopy (ioc, ioid, fc, fid,iopos)
symctype        ioc;
idptr          ioid;
symctype         fc;    /* file symbolcode                */
idptr           fid;    /* file data type                 */
postype       iopos;    /* position of iostm or io komma */
#endif
BEGIN(iobincopy)

      binappend(binprev,binidcreate(ioc,ioid)); /* ionode duplicated  */
                                                /* and appended right */
      goright();                                /* binprev on f node  */
      binuppos( binprev ,iopos );               /* position of comma  */

      binappend(binprev,binidcreate(fc,fid));   /* append filenode    */
      goright();                                /* binprev on fnode   */
      binuppos( binprev ,iopos );               /* position of comma  */
END


                                       /*---------------------*/
#ifdef LINT_ARGS
local void einausanw (  void)
#else
local void einausanw()                 /*  E i n a u s a n w  */

/* procedure expects bincurr to contain read,write(ln) *
 * and selects particular io statements from list      *
 */

#endif
BEGIN(einausanw)
 binptr     root,
              fn;
 idptr       fid;
 idptr      ioid;
 symctype    ioc, /* procedure name */
              fc; /* file type    */
 boolean  std_io;
 postype   iopos;
 sc_type   sc;
 int      parac;              /* Counter for parameters of io statement */

 root   = binprev;                              /* root at last stm     */
 ioc    = symc;                                 /* symc of ionode       */
 ioid   = idfnd(sym);                           /* and id               */
 binupid(bincurr, ioid);
 iopos  = pos;                                  /* position of ionode   */
 std_io = true;
 parac  = 1;
 binsuffix(); binget () ;                       /* procedure node       */

 if (symc==cLParent)                            /* with parameter       */
 begin
  binget () ;                                   /* skip '('             */
  setparsloc(SYNTAX, cLParent);
  syntax();                                     /* analyse 1. parameter */
  resetparsloc(SYNTAX);
  goright();                                    /* at 1.param. node     */
  fc = binsymc (binprev) ;                      /* store symc for dupl. */
  fid = binid(binprev) ;
  if (fid) then               /* 1.param. is name     */
  begin
     fn = iddatyp ( fid ) ;
     if ( binsymc ( unname(fn)) == cFILE and    /* File datatype?       */
          binsymc (binprev) != cArry ) then
     begin                                      /* File specified       */
        parac = 2;                         /* 1.Param. has been parsed, */
                                          /* because a filename occurred */
        if (symc == cComma )                        /* skip ','         */
           then binget();
        std_io = false;
        if (symc == cRParent && (ioc == cREAD or ioc == cWRITE) )
             seman( binfather(binprev), PCALL, &sc) ; /* search io proc. */

     end;
  end;

  if (std_io) then                                /* insert stdardiofile  */
  begin
    bininsert(binprev, bincreate( cComma ) );     /* insert listelement   */
    gofather();                                   /* Binprev at listnode  */
    fn = iddatyp (fid = stdio (ioc,&fc));         /* stdio on the right   */
    binexchange(binprev);                         /* expr. <-> filenode   */
    goright();                                    /* binprev at expr.     */
  end;

  if (not(std_io and symc == cRParent) or parac ==1) then
                                              /* not only file parameter */
  begin
    if (symc != cRParent or parac == 1) then
    begin
      einausliste(parac++);                       /* parameterlist        */
                                                  /* binprev at ionode    */
      seman(binprev, PCALL, &sc) ;                /* search io procedure  */
      clrtmp(tlist);
      if (binstm)
        begin
          stmins(binprev);
          if (binend)
             binprev = stmapp(binprev) ;
        end
      else if (binend)   errput (9005, binpos(binprev), NULL) ;
    end

    while (symc!=cRParent && !stoppars(STM) )
    begin                                         /* parse io-list        */
      if (symc==cComma) then
      begin
        binprev = binright ( root );              /* binprev at io node   */
        bininfix();                               /* next io statement    */
        root = binprev ;
        binchange (binprev, cSemicolon);
        iobincopy(ioc,ioid,fc,fid,pos);           /* insert new io stm    */
                                                  /* binprev at filenode  */
        binget () ;
        einausliste(parac++);                    /* parameterlist        */
                                                 /* binprev at ionode    */
        seman(binprev, PCALL, &sc) ;             /* search io procedure  */
        clrtmp(tlist);
        if (binstm)
         begin
           stmins(binprev);
           if (binend)
             binprev = stmapp(binprev) ;
         end
        else if (binend)   errput (9005, binpos(binprev), NULL) ;
      end
      else chkc(cRParent);

    end;/*While*/
    if  (ioc==cWRITELN or ioc==cREADLN)  {
      if (parac != NUREINP or std_io)  {
                                       /* ...ln more than filepar. */
         bininsert(binprev,bincreate(cSemicolon));
         gofather();
         root = binprev ;                          /* last statement     */
         iobincopy(ioc,ioid,fc,fid,iopos );        /* line feed sttement */
      }
      seman(binfather(binprev), PCALL, &sc) ;    /* search io procedure */
      clrtmp(tlist);
    }   /* if ...ln */
  end;  /* CRparent */
  if ( chkc(cRParent) )
     binget () ;                                 /* skip ")" */
  end
 else {  /*  no "(" */
    fid = stdio (ioc, &fc);
    seman(binprev, PCALL, &sc) ;                /* search io procedure   */
    clrtmp(tlist);
 }

 binprev = root;                              /* binprev at last io node */

END /*einausanw*/                      /*  e i n a u s a n w  */


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



                                                        /*-----------------*/
                                                        /* a l l o c s t m */
#ifdef LINT_ARGS
local void allocstm  (  void)
#else
local void allocstm ()
  /* handles allocation procedure for dynamic arrays ( allocate ) */
#endif
{
 binptr     root;

 idptr alid;
 boolean std_proc = false;
 sc_type sc;


 root   = binprev;                              /* root at last stm     */
 alid   = idfnd(sym);                           /* and id               */

 binsuffix(); binget () ;                       /* procedure node       */

 binupid(binprev, alid);



 if ( chkc(cLParent) ) {
    binget () ;                                /* skip "("              */

    setparsloc(SYNTAX, cLParent);
    syntax();                                  /* 1. parameter          */
    resetparsloc( SYNTAX);
 }

 if ( symc != cComma )
    chkc( cRParent );
 if ( symc == cComma ) {
    goright();
    bininfix();
    binget();                                           /* skip  "," */
                                                   /* parse 2. parameter */
    setparsloc(SYNTAX, cComma);
    syntax () ;
    resetparsloc( SYNTAX);
    if ( symc != cComma && symc != cTill) {
       chkc( cRParent );               /* offset for error recovery */
    }
    if ( symc == cComma ) {
       std_proc = false;
    }
    else if ( symc == cTill ) {
       std_proc = true;
       binchange ( bincurr, cComma);
                              /* "," to be inserted instead of ".." */
    }
 } /* if .. == cComma.. */


 while ( symc != cRParent &&  not stoppars(STM) ) {

      goright () ;
      bininfix () ;                                /* insert "," or ".." */

      binget () ;
      setparsloc(SYNTAX, cComma);
      syntax () ;                                     /*  next parameter */
      resetparsloc( SYNTAX);

      if (symc != cComma)  {                            /* next is "," ? */
         chkc(cRParent);                      /* possible error recovery */
         if ( symc == cRParent || stoppars(STM) )
            break;
      }
      if (symc == cComma)  {
         goright();
         bininfix ();                              /* insert comma    */
         binget ();
         setparsloc(SYNTAX, cComma);
         syntax () ;                                  /*  next parameter */
         resetparsloc( SYNTAX);
         if ( std_proc ) {
            if ( chkc ( cTill ) )  {
               binchange ( bincurr, cComma);
            }
         }
         else
            chkc ( cComma );

      }  /* if .. == cComma .. */
 }   /* end: while != cRParent ... */
 if ( not stoppars(STM) ) {
    binget();
 }
 binprev = binright ( root);
 if ( std_proc ) {
    /* append symbol left, used to distinguish standard procedure call */
                             /* from user-defined 'allocate'-procedure */
    bininsert ( binright (binprev), bincreate ( cSemicolon ) );
 }
 seman ( binprev, PCALL, &sc);

 binprev = root;
}
                                                        /* a l l o c s t m */
                                                        /*-----------------*/

                                                /*-----------------------*/
                                                /* h a n d l s t m s t o */
#ifdef LINT_ARGS
local boolean handlstmsto  (  void)
#else
local boolean handlstmsto ()
  /* handles special kind of symbol code delimiting a statement */
   /* returns true, if enclosing symbol to such symbol code was found */
#endif
{
   binptr datyp;
   sc_type   sc;

   if(symc == cELSE) {
      if ( get_parsloc() - ( STM*256 ) == cIF ) {  /* o.k.! */
         return(true);
      }
      else  {
         errput (1117, pos, "IF");  /* missing IF in statement */
         if  (binright (binprev))  {
            goright () ;
            bininfix () ;
         }
         else                        /* very ordinary */
            binsuffix () ;
         binget () ;
         stm () ;                      /* else statement */
         return (false);
      }
   }
   if(symc == cUNTIL) {
      if ( get_parsloc() - ( STM*256 ) == cREPEAT ) {  /* okay */
         return(true);
      }
      else  {
         errput (1117, pos, "REPEAT");  /* missing REPEAT in statement */
         binget () ;
         binprefix () ;
         setparsloc(SYNTAX, cUNTIL);
         datyp = expression (FCALL, &sc) ;        /* boolean expression */
         resetparsloc(SYNTAX);
         chkboolean (datyp) ;
         return(false);
      }
   }
   else
      return(false);
}
                                                /* h a n d l s t m s t o */
                                                /*-----------------------*/



                                                /*-----------*/
#ifdef LINT_ARGS
global void  stms  ( void)
#else
global void  stms ()                            /*  s t m s  */
#endif
BEGIN(stms)
 binptr root;

 root = binprev ;
 while (symc == cSemicolon)   binget () ;
 while ( not (symc == cEND or symc == cEndofSrc or stoppars(STM) )
     /* sym_is [symc].statement or symc == cIcon or id() */  )
  begin
    if(handlstmsto( ) )    /* symbol code interrupts 'while' loop */
       break;             /* and is handled outside of 'stms' */
   /* setparsloc(STM, symc);*/
    stm () ;
    /* pop_parsloc(STM); */
    if  (symc == cSemicolon)  then
      if  (binright (binprev))  then
        begin
          goright () ;
          bininfix () ;
          binget () ;
        end
      else /* ok */ ;
    else if  (symc != cEND and symc != cELSE and symc != cUNTIL)  then
     begin              /* not a statement stopper */
       errput (1104, pos, NULL);
                               /* Semicolon expected. */
       if  (binright (binprev))  then
         begin
           goright () ;
           bininsert (binprev, bincreate (cSemicolon)) ;
           gofather () ;
         end;
       ery_loahd(cSemicolon);
       contpars(STM) ;
     end /* ";" expected */ ;
    while (symc == cSemicolon)   binget () ;
  end;

 if  (binsymc(binprev) == cSemicolon and not binright(binprev))
   then   bindelete (binprev) ;
 binprev = root ;
END /* stms */                                  /*  s t m s  */
                                                /*-----------*/


symptr symjustdef = symNIL ; /* Initialize. Declared in stm.h */

/*-------------------------------------------------------------------------*/
#ifdef LINT_ARGS
global binptr konst (void)                      /*  k o n s t  */
#else
global binptr konst ()
#endif
BEGIN(konst)
  binptr root ;
  register binptr datyp ;
  boolean minus = false ;
  boolean chktype ;   /* check data type, if sign occured */
  idptr idp ;

  root = binprev ;
  minus =  (binsymc(binprev) == cMMinus) ;
  chktype = minus ;
  if (symc == cMinus)  then
   if  (minus)
    begin
      bindelete (binprev) ;
      root = binprev ;   /* correct root */
      binget () ;                        /* ignore two minus */
      minus = false ;
    end
   else    /* bincurr is minus, binprev is not minus */
    begin
      binchange (bincurr, cMMinus) ;             /* mono - */
      binsuffix () ;
      binget () ;
      chktype = minus = true ;
    end
  else    /* bincurr is not minus */
  if (symc == cPlus)  then
   begin
     binget () ; /* ignore + */                 /* mono + */
     chktype = true ;
   end

  if  (sym_is[symc].identifier)  then
   begin
    if (symjustdef == sym  and  symjustdef != symNIL)
       errput(1053, pos, "constant");
       /* constant identifier found on both sides of its definition. */
     idp= idfnd (sym) ;
     datyp = iddatyp (idp) ;
     IF  idgetkind (idp ) != IDNONE and idgetkind (idp ) != IDCONST  THEN
        errput (1402, pos, NULL) ;
                        /* Constant identifier expected. */
     ELSE
        if (not idp) then
         begin                             /* define dummy identifier */
           errput (1402, pos, NULL) ;
           idp = idins (sym, IDCONST) ;
           datyp = anytype ;
           idsetdatyp (idp, datyp) ;
           idsetbin   (idp, bincurr) ;
           idsetvalue (idp, idvalue(idFALSE)) ;
         end ;
        IF (on_rename or id_is (idp, imported))
           and  datyp != rconstype   and  idvalue (idp)  THEN
          symc = binsymc(idvalue(idp));
          binchange(bincurr,symc);
          IF sym_is[symc].value THEN
            IF minus THEN
              minus = false;
              if (root == binprev)   root = binfather (root) ;
              bindelete (binprev) ;
              binupvalue(bincurr,-binvalue(idvalue(idp)));
            ELSE
              binupvalue(bincurr,binvalue(idvalue(idp)));
            FI
          ELIF sym_is[symc].constant THEN
            IF minus THEN
              char *n_str;
              char *o_str = bincharp(idvalue(idp));
              minus = false;
              if (root == binprev)   root = binfather (root) ;
              bindelete (binprev) ;
              IF  *o_str == '-' THEN
                /* PJ 30.03.95  cast to char* inserted */
                n_str = (char *)  malloc( strlen(o_str));
                if (n_str==0)  memerror (pos) ;
                strcpy(n_str, o_str+1);
              ELSE
                /* PJ 30.03.95  cast to char* inserted */
                n_str =  (char *) malloc( strlen(o_str)+2);
                if (n_str==0)  memerror (pos) ;
                *n_str= '-';
                strcpy(n_str+1, o_str);
              FI
              /*free(o_str);*/
              binupcharp(bincurr,n_str );
            ELSE
              binupcharp(bincurr,bincharp(idvalue(idp)) );
            FI
          FI
        FI
     FI
     IF not on_rename and not id_is (idp, imported)
        or  datyp == rconstype  THEN
       binupid (bincurr, idp) ;
     FI
   end
  else
  switch (symc)
   begin
     case cNIL :  datyp = pointertype ;   break ;
     case cIcon:  datyp = integertype ;   break ;
     case cCcon:  datyp = chartype ;      break ;
     case cRcon:  datyp = rconstype ;     break ;
     case cBcon:  datyp = booleantype ;   break ;
     case cScon: /* ; case cS2con : ; case cS3con : ; case cS4con : */
                  datyp = bincurr    ;    break ;
     default:
       errput (1403, pos, NULL) ;
                                /* Constant expected. */
       datyp = anytype ;
   end /* switch symc */

  if  (chktype and  datyp != integertype  and  datyp != anytype  and
                    datyp != rconstype )
   begin
       errput (1404, binpos (binprev), NULL) ;
                  /* A signed Constant must be integer or real. */
   end ;

   IF minus THEN
    IF sym_is [symc].value THEN
      binupvalue (bincurr, -binvalue (bincurr)) ;         /* change sign */
      if (root == binprev)   root = binfather (root) ;
      bindelete (binprev) ;
    ELIF  symc == cRcon THEN
      char *o_str = bincharp(bincurr);
         /* PJ 30.03.95  cast to char* inserted */
      char *n_str = ( char * ) malloc( strlen(o_str)+2);
      if  (n_str==0)  memerror (pos) ;
      /*binchange(bincurr,symc);*/
      *n_str = '-';
      strcpy(n_str+1, o_str);
      free(o_str);
      binupcharp(bincurr,n_str );
      if (root == binprev)   root = binfather (root) ;
      bindelete (binprev) ;
    FI
   FI
  binsuffix () ;
  binget () ;
  binprev = root ;
  RETURN (datyp) ;
END                                                  /*  k o n s t  */
/*-------------------------------------------------------------------------*/


                                                /*-----------------*/
#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 = konst() ;                            /* constant             */
    if  (unname (subtype (datyp)) != unname (ctyp) and
          ctyp != anytype and datyp != anytype)  then
     begin
       errput (1105, binpos(binright(binprev)), NULL);
                      /* The type of the constant is incompatible. */
     end ;

    if (symc !=cTill && symc != cComma) then      /* no subrange found */
       chkc(cColon);
    if (symc ==cTill ) then                     /* subrange found    */
    begin
      goright () ;
      bininfix (); binget () ;
      ctyp = konst();                           /* upper bound       */
      if  (unname (subtype (datyp)) != unname (ctyp) and
            ctyp != anytype and datyp != anytype)  then
       begin
         errput (1105, binpos(binright(binprev)), NULL);
                         /* The type of the constant is incompatible. */
       end ;
       if  (binvalue (binleft(binprev)) > binvalue (binright(binprev)))  then  /* neaga */
         begin
          errput(1058, binpos (binprev), NULL) ;
             /* Upper bound is less than lower bound */
         end ;                                                      /* neaga */
      gofather();
    end;

    if (symc==cComma) then
    begin
      goright();
      bininfix();binget();                      /* insert "," */
    end
 end
 binprev = root ;
END /*auswahl*/                                 /*  a u s w a h l  */
                                                /*-----------------*/

                                                /*-----------------------*/
#ifdef LINT_ARGS
local void chkboolean  ( binptr datyp)
#else
local void chkboolean (datyp)                   /*  c h k b o o l e a n  */
  binptr   datyp;
#endif
BEGIN(chkboolean)
  if  (binid (datyp) != idBOOLEAN and datyp != anytype)  then
   begin
     errput (1107, pos, NULL) ;
                               /* Condition must be boolean expression. */
   end ;
END /* chkboolean */                            /*  c h k b o o l e a n  */
                                                /*-----------------------*/


                                                /*---------------*/
#ifdef LINT_ARGS
local binptr stmins (binptr binp)               /*  s t m i n s  */
#else
local binptr stmins (binp)
binptr binp;
#endif
BEGIN(stmins)     /* inserts statements refered by binstm before binp */

/* binstm -> ,    binp -> ,            binstm=NIL    |;| <- stmins */
/*          /i\          /s\    ===>                /   \          */
/*      init.stm.    statement                   /i\     /s\       */

   binptr p;
 /*  if  (binstm == NIL)  return ;  */
   p = bininsert(binp, bincreate(cSemicolon) );
   binappend(p,binstm);
   binexchange(p);
   binstm = NIL;           /* binstm is not needed any more */
   return(p);
END /*stmins */                                 /*  s t m i n s */
                                                /*---------------*/


                                                /*---------------*/
#ifdef LINT_ARGS
local binptr stmapp (binptr binp)               /*  s t m a p p */
#else
local binptr stmapp (binp)
binptr binp;
#endif
BEGIN(stmapp)     /* appends statements refered by binend after binp */

/* binp -> ,    binend -> ,             -> |;| <- stmapp      */
/*        /s\            /f\    ===>      /   \   binend=NIL  */
/*     statement    freeing stm.       /s\     /f\            */

  binptr p;
  /*  if  (binend == NIL)  return ;  */
  p = bininsert(binp, bincreate(cSemicolon) );
  binappend(p,binend);
  binend = NIL;         /* binend is not needed any more */
  return(p);
END /*stmapp */
                                                /*  s t m a p p */
                                                /*---------------*/



#define MAXTEMP     15
                                                /*-------------------*/
#ifdef LINT_ARGS
local void   stm ( void)
#else
local void   stm()                              /*      s t m        */
#endif
BEGIN(stm)
 binptr   root, datyp;
 binptr   p ;
 idptr    idp;
 int      tempc;           /* counts temp. declarations (with-stm.)*/
 int      withc ;          /* counts with-variables (with-stm.)*/
 binptr   temp[MAXTEMP] ;  /* pointers to temporary declarations */
 int      ic;
 char     lab[20];
 static  sc_type  scs, sc ;          /* storage class */

 if (chkappend ("stm"))
  begin
    binget () ;      /* stm has to skip at least one symbol */
    return ;
  end

 root = binprev ;
 while (symc == cIcon)
 begin                                           /* labels */
  sprintf (lab, "_l%ld", symvalue) ;      /* generate C label Name */
                                            /* by means of bincurr */
  idp = idlclfnd (symins( lab));
  if ( idp ) {                       /* label declared on same */
                                   /* block,where it was defined? */
     idfclr(idp, used) ;           /* used flag supposed to indicate */
               /* reference and not definition (idlclfnd sets used true) */
     if ( !id_is(idp, forward))  {
        errput(1108, pos, NULL);
                                   /* Label has been already defined */
     }
     else
        idfclr(idp, forward) ; /* forward flag in idtab determines,*/
  }                               /* wether a label has been already used */
  else {                                    /* else error */
     errput(1109, pos, NULL);
                                              /* Undeclared label. */
  }
  binprev = binappend(binprev, binsycreate(symins( lab)) );
         /* generate symbolnode from label name and append */
  if ( !stoppars(STM) )
     binget () ;
  if ( chkc (cColon) ) {
     bininfix () ;
     binget () ;
  }
 end ;     /* while labels */


 if  (id())  then              /*  statement starts with identifier  */
  begin
   if (symc==cWRITELN or symc==cREADLN or
       symc==cWRITE   or symc==cREAD) then
   begin
    setparsloc(STM, cWRITE);
    einausanw();
    pop_parsloc();
   end
   else if ( symc == cALLOCATE ) {
      setparsloc(STM, cALLOCATE);
      allocstm();
      pop_parsloc();
   }
   else
   begin
    setparsloc(STM, cIdent);
    setparsloc(SYNTAX, cHighest);      /* start at beginning of pattern */
    syntax () ;                           /* proc. call or assignment */
    resetparsloc(SYNTAX);
    if  (symc == cAssign)  then                /* := found     */
     begin
       goright () ;
#if 0   /* must be detected by seman */
       if  (not binisvariable (binprev) and
            idsym (binid(binprev)) != idsym (idcurrf))  then
        begin
          errput (1205, pos, NULL) ;
                        /* Left side is not a variable. */
        end ;
#endif
       bininfix () ;                    /* insert ":="  */
       binget () ;
       setparsloc(SYNTAX, cAssign);
       syntax () ;                      /* right side tree */
       resetparsloc(SYNTAX);
       datyp = seman (binprev, FASGN, &sc) ;
       if (binstm)
        begin
          stmins(binprev);
          if (binend)
            binprev = stmapp(binprev) ;
        end
       else if (binend)   errput (9005, binpos(binprev), NULL) ;
     end /* Assignment */
    else /* Procedure call */
     begin
       IF (datyp= seman (binright (binprev), PCALL, &sc)) != voidtype  and
           datyp != anytype
       THEN
           errput (1111, binpos (binright (binprev)), NULL) ;
                        /* A function call is not a statement. */
       FI
       if (binstm)
        begin
          p = binright (binprev) ;
          stmins(p);
          if (binend)    stmapp (p) ;
        end
       else if (binend)   errput (9005, binpos(binprev), NULL) ;
     end ;
    clrtmp(tlist);
    pop_parsloc();
   end /* not i/o-statement */ ;
  end /* statement starting with identifier */

 else       /* statement not starting with identifier */

 switch (symc)
  begin
   /*---------*/
   /*   for   */
   /*---------*/
   case cFOR:
       setparsloc(STM, cFOR);
       binsuffix () ;                   /* FOR keyword */
       binget () ;
       if ( chkid () )  {
          idp = idfnd (sym) ;
          IF  idp  THEN
            if  (idgetkind (idp) != IDVAR)
              errput (1119, pos, NULL) ;
                                /* not declared as Variable */
            if  (id_is (idp, forvariable))
              errput (1118, pos, NULL) ;
                                /* Assignment to outer for-variable */
            idfset(idp, forvariable) ;
          ELSE
            errput (1112, pos, NULL) ; /* Identifier not declared. */
          FI
          chkscalar (iddatyp (idp), pos) ;
          binupid (bincurr, idp) ;
          binsuffix () ;                   /* loop variable */
          binget () ;
       }
       if (chkc (cAssign) )  {
          bininfix () ;                    /* ":=" */
          binget () ;
          setparsloc(SYNTAX, cAssign);
          datyp = expression (FCALL, &scs); /* start expression */
          if  (unname (subtype (iddatyp (idp))) != unname (subtype (datyp))
               and iddatyp (idp) != anytype and datyp != anytype)  then
            begin char st [550] ;
              strcpy (st, namestring (iddatyp (idp))) ;      /* left type */
              strcat (st, " := ") ;
              strcat (st, namestring (datyp) ) ;             /* right type */
              errput (1106, binpos(binprev), st) ;
            end
          resetparsloc(SYNTAX);
          p = binright (binprev) ;      /* pointer to start expression */
          gofather () ;
          binprefix () ;                   /* shift left */
       }

       if  (symc == cDOWNTO  or  chkc (cTO) )  {
          binsuffix () ;
          binget () ;
          setparsloc(SYNTAX, cTO);
          datyp = expression (FCALL, &sc); /* end expression */
          if  (unname (subtype (iddatyp (idp))) != unname (subtype (datyp))
               and iddatyp (idp) != anytype and datyp != anytype)  then
           begin char st [550] ;
             strcpy (st, namestring (iddatyp (idp))) ;      /* left type */
             strcat (st, " := ") ;
             strcat (st, namestring (datyp) ) ;             /* right type */
             errput (1106, binpos(binprev), st) ;
           end
          resetparsloc(SYNTAX);

          if  (sc !=sc_const)  then
            begin
              if  (scs !=sc_const)  then
                begin
                  temp[0] = tempdecl ("fb", integertype) ;
                  bintemp (p, binsym (temp[0])) ; /* start expression */
                end
              else temp[0] = NIL ;
              temp[1] = tempdecl ("fe", integertype) ;
              bintemp (binright (binprev), binsym (temp[1])) ;
            end
           else temp[0] = NIL,  temp[1] = NIL ;
          if (binstm)  {
             p = binstm ;
             stmins(binfather(binprev)); /* insert statements generated */
                                         /* by expression */
             if (binend)    stmapp (p) ;
          }
          else if (binend)   errput (9005, binpos(binprev), NULL) ;
       }
       if ( chkc (cDO) )  {
          binget () ;
          binprefix () ;                   /* shift left */
          if  (temp[0])
             binchange (temp[0], cTempvar) ;   /* free startvalue */
          stm () ;
          idfclr(idp, forvariable) ;
          if  (temp[1])
             binchange (temp[1], cTempvar) ; /* free endvalue */
        }
        pop_parsloc();
        break ; /* FOR */


   /*---------*/
   /*   if    */
   /*---------*/
   case cIF:
       setparsloc(STM, cIF);
       binsuffix () ;
       binget () ;
       setparsloc(SYNTAX, cIF);
       datyp = expression (FCALL, &sc) ;     /* boolean expression */
       resetparsloc(SYNTAX);
       chkboolean (datyp) ;
       if (binstm)
         begin
           stmins(binprev);
           if (binend)
            begin       /* create temp. var. for condition */
              temp[0] = tempdecl ("bo", booleantype) ;
              binchange (temp[0], cTempvar) ;   /* free temp boolean */
                                                /* may reused immediately */
              bintemp (binright (binprev), binsym (temp[0])) ;
              p = binstm ;
              stmins(binprev);  /* insert assignment */
              stmapp(p) ;
            end
         end
       else if (binend)   errput (9005, binpos(binprev), NULL) ;

       binprefix () ;                   /* shift left */
       if (chkc (cTHEN) ) {
          binget () ;
       }
       stm () ;                         /* then statement */
       if  (symc == cELSE)  then
        begin
          if  (binright (binprev))  then
            goright () ,
            bininfix () ;
          else   binsuffix () ;
          binget () ;
          stm () ;                      /* else statement */
        end ;
       pop_parsloc();

   break ; /* IF */

   /*---------*/
   /*  case   */
   /*---------*/
   case cCASE:
    setparsloc(STM, cCASE);
       binsuffix () ;
       binget () ;
    setparsloc(SYNTAX, cCASE);
    datyp = expression (FCALL, &sc) ;           /* case-expression */
    resetparsloc(SYNTAX);
    chkscalar (datyp, binpos (binright (binprev))) ;
    if (binstm)
      begin
        stmins(binprev);
        if (binend)
         begin       /* create temp. var. for condition */
           temp[0] = tempdecl ("ca", datyp) ;
           binchange (temp[0], cTempvar) ;   /* free temp condition var */
           bintemp (binright (binprev), binsym (temp[0])) ;
           p = binstm ;
           stmins(binprev);  /* insert assignment */
           stmapp(p) ;
         end
      end
    else if (binend)   errput (9005, binpos(binprev), NULL) ;

    binprefix();                                /* expr left of "CASE" */
    if (chkc (cOF))
       binget () ;                     /* skip "OF"         */
    while (symc!=cEND && !stoppars(STM) )
    begin
      if (symc==cELSE) then
      begin
        binsuffix();                            /* append else         */
        binget () ;
        if (symc == cColon )
           binget();                  /* skip ':'          */
        else
           errput(111,pos, NULL);
          /* ':' expected behind 'ELSE' in case-statement. */
        stm();                                  /* Statement on the right */
        if( symc ==cSemicolon ) then binget (); /* ';' ?                  */
        chkc(cEND);                             /* ready                */
      end
      else
      begin
        auswahl (datyp) ;                       /* case selection        */
        if ( chkc (cColon) )  {
           goright ();
           bininfix();                             /* insert ":"         */
           binget () ;
        }
        stm();                                  /* statement on the right */
        if (symc!=cSemicolon) {
          if ( !stoppars(STM) ) {
             if ( symc != cEND )
                chkc(cSemicolon) ;                /* ";" or "end" expected */
          }

        }
        if ( symc == cSemicolon ) {              /* recovered semicolon ? */
           bininfix () ;
           binget();                           /* insert ";"        */
        }
      end /* not else case */ ;
    end;
    pop_parsloc();

    if (binsymc(binprev) == cSemicolon and not binright(binprev))
       bindelete (binprev) ;
    if ( not stoppars(STM) )
       binget () ;                       /* End has been forgotten */

   break ; /* CASE */

   /*---------*/
   /*  repeat */
   /*---------*/
   case cREPEAT:
       setparsloc(STM, cREPEAT);
       binsuffix () ;
       binget () ;
       stms () ;                                /* statements */
       if ( chkc (cUNTIL) )
          binget () ;
       binprefix () ;
       setparsloc(SYNTAX, cUNTIL);
       datyp = expression (FCALL, &sc) ;        /* boolean expression */
       resetparsloc(SYNTAX);
       pop_parsloc();
       chkboolean (datyp) ;
       if (binstm) {                  /* append binstm rightmost of */
          p = binleft(binprev);       /* left son of repeat-node */
          if  (p)  then   /* body exists */
           begin
             while (binsymc(p) == cSemicolon)
                p = binright(p);
             p = bininsert(p, bincreate(cSemicolon));
             p = binappend(p, binstm);
           end
          else   /* empty repeat loop */
             p = binlside(binprev, binstm);
          binstm = NIL;

          if (binend)
           begin       /* create temp. var. for condition */
             temp[0] = tempdecl ("bo", booleantype) ;
             binchange (temp[0], cTempvar) ;   /* free temp boolean */
             bintemp (binright (binprev), binsym (temp[0])) ;
             /*  assignment created by bintemp */
             stmins(p) ;   /* insert assignm before init stm */
             p = binfather(p) ;
             binexchange (p) ; /* move asgn. behind init stm */
             stmapp(binright(p)) ;   /* append behind assignment */
           end
       }
       else if (binend)   errput (9005, binpos(binprev), NULL) ;
   break ; /* REPEAT */

   /*---------*/
   /*  while  */
   /*---------*/
   case cWHILE:
       setparsloc(STM, cWHILE);
       binsuffix () ;
       binget () ;
       setparsloc(SYNTAX, cWHILE);
       datyp = expression (FCALL, &sc) ;        /* boolean expression */
       resetparsloc(SYNTAX);
       chkboolean (datyp) ;
       if (chkc (cDO) )
          binget () ;
       binprefix () ;
       if(binstm) {                  /* stms. generated by expression */
          p = binleft(binprev);               /* left of while-node  */
          stmins (p) ;
          if (binend)
           begin       /* create temp. var. for condition */
             temp[0] = tempdecl ("bo", booleantype) ;
             binchange (temp[0], cTempvar) ;   /* free temp boolean */
             p = bintemp (p, binsym (temp[0])) ;
             stmins (p) ;  /* insert assignment created by bintemp */
             stmapp (p) ;  /* append behind expression */
             binexchange (binfather(p)) ; /* move expr. behind final stm */
           end
       }
       else if (binend)   errput (9005, binpos(binprev), NULL) ;
       stm () ;
       pop_parsloc();
   break ; /* WHILE */

   /*---------*/
   /*  with   */
   /*---------*/
   case cWITH:
     setparsloc(STM, cWITH);
     tempc = 0;
     withc = 0;
     do {
       withc++;
       /* binsuffix () ; */
       binget () ;
       setparsloc(SYNTAX, cWITH);
       datyp = expression (FASGN, &sc) ;        /* variable */
       resetparsloc(SYNTAX);
       if  (binsymc (unname (datyp)) != cRECORD)  then
        begin
          errput (1113, pos, NULL) ;
                       /* Left side must be a record data type. */
        end ;
       if  (sc != sc_var)  then
        begin
          errput (1114, pos, NULL) ;
                              /* Left side must be a variable. */
        end
       else
        if  (binleft (binright (binprev)) or
             binright(binright (binprev)) )
         begin                                  /* not simple variable */
           temp[tempc] = bincreate (cArrow) ;
           binrlink (temp[tempc], datyp) ;
                                     /* the type of the temp. variable is */
                                     /* pointer to the type of the with var. */
           temp[tempc] = tempdecl ("wi", temp[tempc]) ;
           varparam (binright (binprev), false) ;
                                            /* reference above with-var */
           bintemp (binright (binprev), binsym (temp[tempc])) ;
           bininsert (binright (binprev), bincreate (cArrow)) ;
                                            /* dereference above temp var */
           tempc++;
         end /* temp var created for non simple variable */


       /* binprefix () ; */
                 /* The with-variable has been appended right of binprev. */
       blkwith (datyp, binright (binprev)) ;
                    /* The with variable is now attached to the idtab. */
       binrlink (binprev, NIL) ;
                    /* disconnects the with-variable from binprev. */
     } while (symc == cComma && tempc < 16);
     if (tempc > 15) {
        errput(1115, pos, NULL);
        /* Too many temporary variables in one with-statement */
 /* would lead to memory fault,please use several nested with-statements. */
     }
       if (chkc (cDO))
          binget () ;
       if (binstm)  {      /* append statements created by bintemp */
         binprev = binappend(binprev, bincreate(cSemicolon) );
         binlside(binprev, binstm);
         binstm = NIL;           /* binstm is not needed any more */
         if (binend)
          begin            /* append freeing statements  */
            binprev = binappend(binprev, bincreate(cSemicolon) );
            binlside(binprev, binend);
            binend = NIL;           /* binend is not needed any more */
          end
       }
       else if (binend)   errput (9005, binpos(binprev), NULL) ;

       stm () ;     /* Only the with-block remains in the program tree. */
       pop_parsloc();
       for (ic = 0; ic < withc; ic++)    blkend ();
       for (ic = 0; ic < tempc; ic++) {
       /* binchange (temp[ic], cRegister) ;  /* free temp var */
          binchange (temp[ic], cTempvar) ;  /* free temp var */
       }
   break ; /* WITH */

   /*---------*/
   /*  goto   */
   /*---------*/
   case cGOTO:
       binsuffix () ;      /* append "GOTO" */
       binget () ;
       sprintf (lab, "_l%ld", symvalue) ;    /* generate C label Name */
                                             /* by means of bincurr */
       idp = idlclfnd (symins( lab)) ;
       if ( not idp )  {  /* label declared ? */
          errput(1109, pos, NULL);
                           /* Undeclared label. */
       }
       binprev = binappend(binprev, binsycreate(symins( lab)) );
            /* generate symbolnode from label name and append */
       binget () ;
   break ; /* GOTO */

   /*---------*/
   /*  begin  */
   /*---------*/
   case cBEGIN:
       binget () ;
       setparsloc(STM, cBEGIN);
       stms () ;                   /* list of statements */
       if ( chkc (cEND) )
          binget () ;
       pop_parsloc();
   break ; /* BEGIN */

   default:
     /*
        begin
          errput (11, pos, NULL) ;
          /* No statement found.
        end */
   break ;
  end ; /* switch symc */

 contpars(STM);         /* after recovery action STM is continued anyway */
 binprev = root ;
END /*stm*/                                             /*    s t m      */
