/*
 *  MODULE:  seman.c
 *  semantic expression analysis
{*  last modification:  28.10.92  13:05   }


 * uli 14.11.90 : coerse  checks idSTRING instead of cSTRING
                          and suppress s_stat for string -> string
 * tim 15.11.90 : reccfnd usable by decl to check doubly declared rec element
 *                reccfnd declared global
 * uli 15.11.90 : recclistfnd accepts cCsymbol and cIdlist mixed
 * uli 16.11.90 : reccfnd accepts constant part right of record node
 * uli 23.11.90 : seman checks left side of variable
 * uli 04.12.90 : konst accepts iddatyp (idrconv) as real type.
 * uli 20.12.90 : recclistfnd accepts cRecelem.
 * uli 04.01.91 : "if ( = )"  changed
 * Dima 08.01.91: palist and coerse accept subprogs. as parameters
 * Dima 10.01.91: prototypes are added for local functions
 * Dima 25.01.91: palist correction (isnt_comma)
 * Dima 30.01.91: In calls seman(...,asg,...) "asg" is changed
                  Call of idroutfnd are changed.
 * Uli  04.02.91: seman: cIdent changed to cRout, if subroutine call.
 * Uli  04.02.91: palist: call of idfset corrected:   = true added.
 * Uli  18.02.91: seman: assignment to function result sets the generated-flag
 * Uli  22.02.91: seman:   ""   in case cArry
 * Dima 15.04.91: aparupdate :For-variables cannot be used as VAR-parameter.
 * Dima 19.04.91: aparupdate & coerse :
                 By VAR_params. "(type_id *)&" instead of "&(type_id)"
 *Dima  23.04.91: varcast added:  "(type_id *)&"
 * Uli  23.04.91: seman:  cLParD and cLParU added.
 * Uli  02.05.91: varexp: cFree added.
 * Uli  02.05.91: seman: checks idcurrf before idsym(idcurrf).
 * Uli  07.05.91: seman: doesn't unname real constants.
 * uli  08.05.91: rconstype added.
 * uli  13.05.91: varcast and voidptr use cPCast now.
 * uli  21.05.91: varexp: unnamed type respected.
 * uli  21.05.91: subroutine call: change symc, if userdefined.
 * uli  27.05.91: palist: temp vars will not be freed, as cast not resp.
 * Dima 13.06.91: Templist stack is implemented
                  palist & seman
 *Dima 17.06.91 : CLR_TEMP moved from stm.c
 *Dima 17.06.91 : local var2list added
 *Dima 08.07.91 : case cArrow: root is not deleted
 *Dima 15.07.91 : var2list made void
 *Dima 15.07.91 : clrtmp moved from stm.c
 * uli 23.07.91 : constants: on_rename and id_is imported
 * uli 31.07.91 : palist : ":" appended with binllink instead of binlside
 * uli 19.08.91 : voidptr: cast to a_VOID added.
 * uli 18.09.91 : CLR_TEMP moved behind prototypes.
 * uli 26.09.91 : konst and symjustdef moved to stm.c.
 * Dima 17.11.91 : varexp moved to std.c
 * Dima 22.11.91 : coerse moved to optab.c (coers.c)
 * uli 12.12.91 : printname replaced by namestring.
 * uli 21.02.92 : realconst added.
 * uli 12.05.92 : seman : #-expressions return sc_expr.
 * uli 13.05.92 : seman : usage of lvalue to check C-variable.
 * PJ  13.07.92 : A warning will be given, if REAL-constants are passed to
                  reference parameter.
 * Dima 28.10.92: seman: Check for ALLOCATE is added
*/

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

#include "option.h"
#include "error.h"
#include "scan.h"
#include "symtab.h"
#include "idtab.h"
#include "optab.h"
#include "blktab.h"
#include "bintab.h"
#include "std.h"
#include "dp_main.h"
#include "arrx.h"
#include           "expor.t"
#include "seman.h"
#include           "implemen.t"

#define CHECK


#ifdef LINT_ARGS
local void realconst (binptr p) ;
local void   CLR_TEMP        (void);
local void   var2list        (binptr var);
local void   varcast         (binptr p ,binptr frm_type );
local boolean varchk         (binptr actpar, postype pos);
#ifdef KONST
local void    sharpconstant  (binptr root);
#endif
local binptr  recclistfnd    (symptr sym, binptr p);
local binptr  palist         (binptr exp);
local void    aparupdate     (binptr ca_p, binptr pa_p, binptr pf_p);
local binptr  setelement     (binptr root, binptr restyp);
local binptr  setconstr      (binptr root);
#else
local void    realconst     ( ) ;
local void    CLR_TEMP      ( );
local void    var2list      ( );
local void    varcast       ( );
local boolean varchk        ( );
#ifdef KONST
local void    sharpconstant ( );
#endif
local binptr  recclistfnd   ( );
local binptr  palist        ( );
local void    aparupdate    ( );
local binptr  setelement    ( );
local binptr  setconstr     ( );
#endif

                                                /*---------------------*/
#ifdef LINT_ARGS
local void realconst (binptr p)                 /*  r e a l c o n s t  */
 /* creates a temp variable for a real constant */
#else
local void realconst (p)
  binptr p ;
#endif
{ idptr idp ; /* name of temp variable */
  binptr q = bincpool ;  /* traverses constant pool */
  symctype symc = binsymc(p) ;

  while  (q)                            /* search for same value */
   begin
      if  (bincompare (p, unname(q)))   break ;
      q = binfather (q) ;
   end

  if  (q == NIL)
   begin                                /* create variable */
/*     idp = idcreate (uniquename("cn"), IDCONST) ; */
     idp = idcreate (moduniquename(), IDCONST) ;  /*neaga*/
     q = binidcreate (cIdlist, idp) ;
     idsetbin(idp, q);
     if  (bincpool) then                /* add to constant pool */
       bincpool = binappend (bincpool, q) ;
     else bincpool = q ;

     q = bincreate (symc) ;             /* copy node of constant value */
     binuppos (q, binpos (p)) ;
     if  (symc == cRcon)  binupcharp (q, bincharp (p)) ;
     else   binappend (q, binright(p)) ;
     idsetvalue(idp, q);                /* assign the value to the ident */
     idsetdatyp(idp, rconstype);        /* assign type to the ident */
   end
  else
    idp = binid (q) ;

  binchange (p, cIdent) ;       /* replace constant by temp variable */
  binupid (p, idp) ;
  binrlink (p, NIL) ;           /* unlink right side of variable node */

}                                               /*  r e a l c o n s t  */
                                                /*---------------------*/




/** release temporary variables, will be a macro later **/
local void CLR_TEMP( )
{ if(tempvar){ binchange( tempvar,cTempvar);tempvar = NIL;}}

                                                /*---------------*/
#ifdef LINT_ARGS
global void clrtmp  (binptr root )              /*  c l r t m p  */
#else
global void clrtmp (root)
  binptr root ;
#endif
  /* Marks a list of tempvars as free */
{
 binptr p;
 IF not root  THEN return ; FI
 p = binright(root);
 IF not p THEN return ; FI
 WHILE true DO
   IF not p THEN break; FI
   binchange( binleft(p), cTempvar);
   binllink(p,NIL);
   p = binright(p);
 OD
 binldelete(binright(root));
 binrlink(root, NIL);
 tlistend = (root == tlist)? NIL: root;
}                                              /*  c l r t m p  */


/*------------------------------------------------------------------------*/
#ifdef LINT_ARGS
local void var2list (binptr var)   /*  v a r 2 l i s t  */
#else
local void var2list (var)
  /* Adds the var. decl. to the list  */
  /* Used to manage tempvars. */
  binptr var;
#endif
{
  binptr p;
  IF not tlist THEN
    tlist = bincreate(cSemicolon);
  FI
  p = binright(tlist) ;
  IF p THEN
    while(  binsymc(binright(p)) == cSemicolon)
      p = binright(p) ;
    p = binappend(p, bincreate(cSemicolon) );
  ELSE
    p = binappend(tlist, bincreate(cSemicolon) );
  FI
  tlistend = p;
  binllink(p,var);
}
                                              /*  v a r 2 l i s t  */

/*------------------------------------------------------------------------*/
/* "call(..)" -> "*(restyp *)call(...)" or "*call(...)"*/
#ifdef LINT_ARGS
global void voidptr  ( binptr call, binptr restyp)
#else
global void voidptr (call,restyp)  /* v o i d p t r */
  binptr call, restyp;
#endif
begin
  binptr p;
  static binptr a_void = NIL ;
  if  (a_void == NIL)   a_void = binsycreate (symins("a_VOID")) ;

  binexchange( bininsert(call,bincreate(cArrow)));

  p = bininsert(call,bincreate(cPCast));
  binexchange(p);
  binllink (p,restyp);

  p = bininsert(call,bincreate(cRParent));
  binexchange(p);
  binllink (p, a_void);
end                                 /* v o i d p t r */

/*------------------------------------------------------------------------*/
#ifdef LINT_ARGS
local boolean varchk  ( binptr actpar ,postype pos )
#else
local boolean varchk (actpar, pos)                     /* v a r c h k  */
  binptr actpar ;  /* data type of the actual parameter, */
                   /* includes storage class */
  postype pos ;    /* position of actual parameter */
#endif
{
  IF not( binsymc(actpar)==cVarparam or binsymc(actpar)==cVAR ) THEN
    if  (sym_is [binsymc(unname(actpar))].scalartype or
         binsymc(unname(actpar)) == cArrow or
         unname( actpar ) == realtype )     /* PJ 13.07.1992 */
      errput (131, pos, NULL) ;
    /* In standard Pascal this parameter must be a variable. */
    return false;
  ELSE
    return true;
  FI
}                                                      /* v a r c h k  */

#ifdef KONST
                                        /*-----------------------------*/
#ifdef LINT_ARGS
local void  sharpconstant  ( binptr root )
#else
local void  sharpconstant (root)        /*  s h a r p c o n s t a n t  */
  binptr root ;
#endif
BEGIN(sharpconstant)
  symctype     symc = binsymc (root) ;   /* symbol code of root */
  idptr idp ;

  if  (binsymc ( binright (root)) == cRcon)  then       /* real constant */
   begin
     if (symc == cDot)  errput (1418, binpos (root), NULL) ;
                                         /* dot constants not yet implemented */
     if (symc == cDotN)
       begin ;
         bindelete (root) ;      /* delete "#*" symbol */
         return ;                /* and finish */
       end
     binchange (root, cCall) ;
     if (symc == cDotD)  binupsym  (root, symins ("r_cnsd")) ;
     if (symc == cDotU)  binupsym  (root, symins ("r_cnsu")) ;
     if (symc == cDotS)  binupsym  (root, symins ("i_cnst")) ;
     binchange (binright (root), cScon) ;     /* change real to string */
   end
  else          /* integer constant */
   begin
     if (symc == cDot )  errput (1418,binpos (root), NULL) ;
                                         /* dot constants not yet implemented */
     if (symc == cDotS)  errput (1419,binpos (root), NULL) ;
                                         /* integer valued interval constant */
     idp = idfuncfnd (sREAL, idINTEGER, idREAL) ;
     if  (idp)  then
      begin                   /* coersion integer to real */
        binchange (root, cREAL) ;
        binupid   (root, idp) ;
      end
     else
      begin                   /* cast integer to real */
        binchange (root, cRParent) ;
        binllink  (root, rconstype) ;
      end
   end /* integer constant */
END /* sharpconstant */                     /*  s h a r p c o n s t a n t  */
                                            /*-----------------------------*/
#endif



local idptr reccidp = (idptr)0 ; /* used if record element is renamed */

/*-------------------------------------------------------------------------*/
#ifdef LINT_ARGS
local binptr recclistfnd  ( symptr sym ,binptr p )
#else
local binptr recclistfnd (sym, p)               /*  r e c c l i s t f n d  */
  symptr sym ;
  binptr p ;
#endif
BEGIN(recclistfnd)
  binptr restyp = voidtype ; /* means not yet found */
  boolean found = false ;

#ifdef CHECK
  if  (p and binsymc (p) != cIdlist and binsymc (p) != cCsymbol
         and binsymc (p) != cRecelem )
        begin
          errput (9011, binpos(p), NULL) ;
                     /* recclistfnd: Node is not idlist. */
        end ;
#endif

   while  (binsymc (p) == cCsymbol  or  binsymc (p) == cRecelem  or
           binsymc (p) == cIdlist)
    begin                                       /* search record component */
      found =  (sym == binsym (p) or sym == idsym (binid (p))) ;
      if  (found)   break ;
      p = binnext (p) ;
    end ;
   if  (found)  then                            /* search component type */
    begin
      reccidp = binid (p) ;   /* C name of element */
      while  (binsymc (p) == cCsymbol  or  binsymc (p) == cRecelem  or
              binsymc (p) == cIdlist)
        p = binnext (p) ;
      restyp = p ;
    end ;

  RETURN (restyp) ;
END                                       /* r e c c l i s t f n d */

/*-------------------------------------------------------------------------*/
#ifdef LINT_ARGS
global binptr reccfnd  (  symptr sym ,binptr datyp ,binptr root )
#else
global binptr reccfnd (sym, datyp, root)                /*  r e c c f n d */
  /* searches in the recordtyp datyp for the record element sym. */
  /* Appends the union/struct names right of root, if root != NIL */
  /* Returns the data type of the element c. */
  symptr sym ;
  binptr datyp ;
  binptr root ;         /* == NULL when called by recordtyp (in decl.c) */
#endif
BEGIN(reccfnd)
  binptr p=NIL ;
  binptr restyp = voidtype ; /* means not yet found */
  binptr case_ptr=NIL, colon=NIL, sub_datyp=NIL;
  boolean next_node = false;

#ifdef CHECK
  if  (binsymc (datyp) != cRECORD)
        begin
          errput (9015, binpos(datyp), NULL) ;
                     /* reccfnd: Data type is not record. */
        end ;
#endif

  p = binleft (datyp) ;
  if (p)     /* constant part in recordtyp shifted to */
     ;                           /* the left side ? */
  else if ( root==NIL && binsymc(binright(datyp) ) != cCASE)
             /* called by recordtyp for constant-part-definition? */
     p = binright(datyp);
  while  (restyp == voidtype and binsymc (p) == cSemicolon)
   begin
     restyp = recclistfnd (sym, bincont (p)) ;
     p = binnext (p) ;
   end ;
  if  (restyp == voidtype and p)  then   restyp = recclistfnd (sym, p) ;

                               /* variant part processing, if any */
  case_ptr = binright(datyp);

#ifdef CHECK
    IF case_ptr and binsymc (case_ptr) != cCASE and root THEN
      errput (9016, binpos(datyp), NULL) ;
      /* reccfnd: Data type is not a variant record. */
    FI
#endif
  IF  (restyp != voidtype  or binsymc (case_ptr) != cCASE) THEN
    RETURN (restyp) ;
  FI

  FOR p = binright(case_ptr) ,
      next_node = ( binsymc (p) == cSemicolon or binsymc (p) == cColon);
      next_node;
  DO
    colon = (binsymc (p) == cSemicolon)? binleft(p): p;
    sub_datyp = binright(colon) ;

    IF   binsymc(sub_datyp) == cRECORD THEN
      restyp = reccfnd ( sym, sub_datyp, root ); /*???*/
    ELIF binsymc(sub_datyp) == cSemicolon THEN
      binptr t= sub_datyp;
      next_node = true;
      WHILE  next_node
      DO
        restyp = recclistfnd( sym,
                 (binsymc (t) == cSemicolon)? binleft(t): t);
        IF restyp != voidtype THEN break; FI

        next_node = ( binsymc (t) == cSemicolon);
        if(next_node)
          t = binnext (t) ;
        next_node &=  (t != NIL) ;
      OD
    ELSE
      restyp = recclistfnd( sym, sub_datyp );
    FI
    IF restyp != voidtype THEN break; FI

    next_node = ( binsymc (p) == cSemicolon);
    if(next_node)
       p = binnext (p) ;
    next_node &=  (p != NIL) ;

  OD

  IF restyp != voidtype and root THEN
    root = bininsert(root, bincreate(cPoint));
    binappend(root,binsycreate(binsym(binleft(case_ptr)))); /* union.-id*/
    root = bininsert(root, bincreate(cPoint));
    binappend(root,binsycreate(binsym(binleft(colon))));/* struct.-id*/
  FI

  RETURN (restyp) ;
END                                               /* r e c c f n d */

/*------------------------------------------------------------------------*/
/* macros to control the releasing of temp.vars.                        */
#define maxtemp  32 /*the maximal number of temp.var. in function call*/
#define DEF_TMP_LST        \
 binptr temp_list[maxtemp];\
 int tempc = 0;            \
 temp_list[0]= NIL;

#define ADD_TMP_VAR       \
IF tempvar THEN           \
  IF tempc == maxtemp THEN\
    errput(1407,pos,NULL);\
  FI                      \
  temp_list[ tempc++ ]= tempvar;\
  tempvar = NIL;          \
FI
    /*   error message 1407 is: */
    /* Too many temporary variables in one function call */
    /* would lead to memory fault,please use temporal assignments. */

#define CLEAR_TMP_LST                           \
  IF *temp_list THEN                            \
    repeat                                      \
      binchange( temp_list[ --tempc], cTempvar);\
    until ( !tempc ); /*till 0*/                \
  FI


/*-----------------------------------------------------------------------*/
#ifdef LINT_ARGS
local binptr palist  (  binptr exp )
#else
local binptr palist (exp)                               /*  p a l i s t  */
  /* returns a list of actual argument data types */
  /* built from the actual argument list of the call exp. */
  binptr exp ;
#endif
BEGIN(palist)
 binptr par = exp ; /* actual argument list */
 binptr      res; /* Pascal actual parameter list to be returned */
 binptr   q1, q2,p,pl, colon; /* traverse the target list. */
 binptr    datyp; /* data type of an actual parameter */
 binptr   PF= NIL ; /* traverse the PF list. */
 symptr       idsy ;   /*  subroutine symbol */
 idptr id;
 int i ;
 boolean f_par,isnt_comma ;
 static sc_type  sc ;  /* storage class */
 /* DEF_TMP_LST ; */

  res = q1 = NIL ;
  f_par = id_is(binid(exp),nooverload); /*There is a subprog. as param.*/
  IF f_par THEN                         /* PF is therefore not empty*/
    PF = idparlist(binid(exp));
  FI

  IF not  binright(par) THEN return NIL ; FI

  repeat  /* until end of argument list */
    par = binright (par) ;
    isnt_comma = (binsymc(par) !=cComma);
    p= (isnt_comma)? par : bincont (par);
    id = binid(p);

    IF f_par and (not PF) THEN        /**/
      /* Too many arguments */
      errput ( 1422 , binpos (p), NULL) ;
      return res;
    FI

    IF  binsymc(PF) == cFUNCTION or  binsymc(PF) == cPROCEDURE THEN
      IF  binsymc(PF) == cFUNCTION THEN

        /*               |FUNCTION|     */
        /*                     /        */
        /*                    |:|       */
        /*                   /   \      */
        /*  formale Paramliste   Ergtyp */

        q2= bincreate(cFUNCTION);
        binllink(q2, bincreate(cColon));
        colon = binleft(q2);
        /* That can be a func. without params. */
        pl = binleft (binleft(PF));
        binllink(colon,  pl  );
        binrlink(colon, binright(binleft(PF)));
        idsy = idsym(id);
        id = idroutfnd ( (idkind)FCALL, idsy, pl, false /* NO coersion*/ );

      ELSE /*  binsymc(PF) == cPROCEDURE */

        /*      |PROCEDURE|          */
        /*            /              */
        /*    formale Paramliste     */

        q2= bincreate(cPROCEDURE );
        /* That can be a proc. without params. */
        pl = binleft (PF);
        binllink(q2,  pl );
        idsy = idsym(id);
        id = idroutfnd ( (idkind)PCALL, idsy, pl, false /* NO coersion */ )
;       FI
      IF not id  THEN
        boolean not_found; /*dummy**/
        boolean comp = strong_comp;
        strong_comp = false;
        binrlink(p,binleft(q2)); /*There shall be param.list*/
        illroutine(p, binleft(q2), &not_found );
        binrlink(p,NIL);         /* Throw it away*/
        strong_comp = comp;      /* Restore */

      ELIF idlevel(id) == IDPRELEVEL THEN
        /* This function can not be passed as actual parameter*/
        errput ( 1421 , binpos (p), NULL) ;
      ELSE
        binupid(p,id);
        idfset(id,parused) ;
      FI
    ELSE
      datyp = seman ( p, FCALL, &sc) ; /* recursiv call */

      IF tempvar THEN
        var2list(tempvar );     /* Add tempvar to the tlist */
        tempvar = NIL;
      FI
      IF  sym_is [binsymc (datyp)] .identifier THEN
        q2= bincreate    /* (binsymc (datyp)) ; */
            ( (sc == sc_var) ? cVarparam : cIdlist ) ;
        binupid (q2, binid (datyp)) ;
      ELSE   /* unnamed argument type */
        q2= bincreate ( (sc == sc_var) ? cVAR : cComma ) ;
        binllink (q2, datyp) ;
      FI
    FI
    IF res THEN
      binappend (q1, q2) ;
      q1 = q2 ;    /* further elements */
    ELSE
      q1 = res = q2 ;               /* or first element */
    FI
    PF = binright(PF);
  until ( isnt_comma );    /* until end of argument list */


 if  (on_dump)  then                            /* PA list dump */
  begin
    postype pos ;

    pos = binpos(exp) ;
    print (" Actual Argument types of ") ;
    print (namestring (exp)) ; /* functions name */
    print (" at line ") ;
    printint ((longint) pos.line) ;
    print (" col ") ;
    printint ((longint) pos.col) ;
    printline () ;
    dump (res) ;
    printline () ;
  end ;   /* PA list dump */
  /*mark temp.vars. for all the parametrs as free*/
  /* CLEAR_TMP_LST;     does not work for cast Operators */

  return res ;
END /* palist */                                        /*  p a l i s t  */

/*-----------------------------------------------------------------------*/
#ifdef LINT_ARGS
local void   varcast  (  binptr p ,binptr frm_type )
#else
local void   varcast  ( p, frm_type )
  binptr p , frm_type;
#endif
{ /*  v a r c a s t  */
  varparam (p, false);
  p = bininsert(binfather(p),bincreate(cPCast));
  binexchange(p);
  binllink (p,binidcreate ( cIdent ,binid(frm_type)) );
}
/*-----------------------------------------------------------------------*/

#ifdef LINT_ARGS
local void   aparupdate  (  binptr ca_p ,binptr pa_p ,binptr pf_p )
#else
local void   aparupdate (ca_p, pa_p, pf_p)      /*  a p a r u p d a t e   */
  /* updates the actual parameterlist actpar */
  /* by adding the address Operator in case of var-parameters variables */
  /* by adding the temp. assignment in case of var-parameters expressions*/
  binptr ca_p ;  /* actual parameter list (CA list) */
  binptr pa_p ;  /* actual parameter type list (PA list) */
  binptr pf_p ;  /* formal parameter type list (PF list) */
#endif
BEGIN(aparupdate)
 /* temp.vars. created in "varexp()" are not released !!! */
    binptr p = NIL;
    boolean isnt_comma = false;

  repeat  /* until the end of actual parameter list */
    if( ! pf_p )     /* No more formal parameters */
      return;

    isnt_comma = (binsymc(ca_p) != cComma);
    p= (isnt_comma)? ca_p : binleft (ca_p);

    IF binsymc (pf_p) == cVarparam and
       not sym_is [binsymc (unname (pf_p))] .arraytype
    THEN
      IF sym_is [binsymc(p)] .identifier  and
        id_is (binid(p), forvariable)
      THEN
        errput (1423, binpos(p), NULL ) ;
      FI

      IF varchk (pa_p, binpos (p)) THEN
        IF binid(pa_p) == binid(pf_p) THEN
          varparam (p, false);
        ELSE
          varcast( p, pf_p);
        FI
      ELSE
        varexp ( p, pa_p);
      FI
    FI
    IF not isnt_comma THEN  /*Is comma: not the last parameter */
      pa_p = binright (pa_p) ;
      pf_p = binright (pf_p) ;
      ca_p = binright (ca_p) ;
    FI
  until ( isnt_comma );    /* until end of argument list */
END /* aparupdate */                            /*  a p a r u p d a t e   */
                                                /*------------------------*/


                                                /*-----------------------*/
#ifdef LINT_ARGS
local  binptr setelement  (  binptr root ,binptr restyp )
#else
local  binptr setelement (root, restyp)         /*  s e t e l e m e n t  */
  /* performs the semantic analysis of one */
  /* element of the Pascal set constructor. */
  binptr root ;
  binptr restyp ; /* data type of previous element */
#endif
BEGIN(setelement)
  binptr datyp ;        /* data type of the list element */
  sc_type sc ;          /* storage class returned by seman */

  datyp = seman (root, FCALL, &sc) ;

  chkscalar (datyp, binpos (root)) ;
  if  (restyp != anytype  and  datyp != anytype  and
       unname (subtype (restyp)) != unname (subtype (datyp)) ) then
   begin
     errput (1408, binpos(root), NULL) ;
                 /* Incompatible set element type. */
   end ;
  if (subtype (datyp) != integertype)
      begin    /* add cast to integer */
        root = bininsert (root, bincreate (cRParent)) ;
        binrlink (root, integertype) ;
        binexchange (root) ;
      end ;
  return datyp ;
END /* setelement */                            /*  s e t e l e m e n t  */
                                                /*-----------------------*/

                                                /*---------------------*/
#ifdef LINT_ARGS
local  binptr setconstr  (  binptr root )
#else
local  binptr setconstr (root)                  /*  s e t c o n s t r  */
  /* performs the semantic analysis of the */
  /* Pascal set constructor [x, y..z]. */
  binptr root ;
#endif
BEGIN(setconstr)
  binptr restyp = anytype ;
  binptr p            ; /* walks thru element list */
# define maxelem 100    /* maximal element number, ".." counts 1 */
  char   ctrlstring [maxelem] ;
  char * chp = ctrlstring ;  /* index to ctrlstring */

  binchange (root, cCall) ;
  p= binright (root) ;
  if  (p)  then
   begin       /* non empty set constructor */

     while  (binsymc (p) == cComma)                /* all elements except */
      begin                                        /*     last            */
        p = binleft (p) ;
        if  (binsymc (p) == cTill)  then
         begin                                     /* element range */
           restyp = setelement (binleft  (p), restyp) ;
           restyp = setelement (binright (p), restyp) ;
           binlift (p) ; /* lift ".." to comma level */
           binchange (p, cComma) ;
           *(chp++) = '2' ;
         end /* element range */
        else
         begin                                     /* single element */
           p = binfather (p) ; /* go back to Comma */
           restyp = setelement (binleft (p), restyp) ;
           *(chp++) = '1' ;
         end /* single element */ ;
        p = binnext (p) ;
      end /* until last element */ ;
                                                /* last element */
     if  (binsymc (p) == cTill)  then
      begin                                     /* element range */
        restyp = setelement (binleft  (p), restyp) ;
        restyp = setelement (binright (p), restyp) ;
        binchange (p, cComma) ;
        *(chp++) = '2' ;
      end /* element range */
     else
      begin                                     /* single element */
        restyp = setelement (p, restyp) ;
        *(chp++) = '1' ;
      end /* single element */ ;

                               /* now construct call of runtime procedure */
     binupsym  (root, symins ("s_cons")) ;
     *chp = '\0' ;
     p= bincreate (cSET) ;                      /* create "set of restyp" */
     binrlink (p, restyp) ;
     restyp = p ;
     tempvar = tempdecl ("se", restyp) ;           /* result variable */
     p= bininsert (binright (root), bincreate (cComma)) ;
     binappend (p, binsycreate (binsym (tempvar))) ;  /* result added */
     binexchange (p) ;                             /*  to argument list */

     p= bininsert (binright (p), bincreate (cComma)) ;
     p= binappend (p, bincreate (cScon)) ;
     binupcharp (p, (char*) malloc (strlen (ctrlstring) + 1) ) ;
     strcpy (bincharp (p), ctrlstring) ;        /* control string added */
     binexchange (binfather (p)) ;              /*   to argument list */
   end /* non empty set */
  else

   begin                                        /* empty set */
     binupsym  (root, symins ("s_zero")) ;
     restyp = bincreate (cSET) ;                /* set of anytype */
     binrlink (restyp, anytype) ;
     tempvar = tempdecl ("se", restyp) ;        /* result variable added*/

     binappend (root, binsycreate (binsym (tempvar))) ;/* to argument list*/
   end ;

  return restyp ;
END /* setconstr */                             /*  s e t c o n s t r  */

                                                /*-------------*/
#ifdef LINT_ARGS
global binptr seman  (  binptr root ,callclass asg ,sc_type *sc )
#else
global binptr seman (root, asg, sc)             /*  s e m a n  */
  /* performs the semantic analysis of expressions. */
  /* root refers the node to be checked. */
  /* seman returns the data type of the expression. */
  binptr root ;
  callclass asg ; /* "first token of a statement" */
  sc_type *sc ; /* storage class */
#endif
BEGIN(seman)
  binptr  tempend= NIL, p= NIL ;  /* scans index lists or parameterlists */
  binptr ltyp, rtyp ;   /* data type of left and right operand */
  binptr     restyp ;   /* data type of the (sub)expression */
  symctype     symc ;   /* symbol code of root */
  symptr       opsy ;   /* prio-defined Operator symbol */
  symptr       idsy ;   /* prio-defined subroutine symbol */
  opptr          op ;   /* pointer to Operator */
  idptr         idp ;   /* pointer to identifier */
  sc_type  lsc, rsc ;   /* storage class of left resp. right side */
  int i= 0;
  boolean comp = (boolean) false;
  boolean not_found = (boolean) true;
  boolean is_alloc = false;

  IF binsymc (binright( root)) == cSemicolon THEN
    bindelete (binright( root));
    is_alloc= true;
  FI

 if  (root)  then
 begin
   *sc = (binisvariable (root))?  sc_var: sc_expr  ;
   rtyp = NIL ;
   symc = binsymc (root) ;

   IF sym_is [symc] .leftbin THEN
     ltyp = seman (binleft (root), asg, &lsc) ;   /* left operand */
   ELSE
     ltyp = NIL; lsc = sc_unknown ;
   FI

  if  (sym_is [symc] .identifier  and  symc != cArry )  then
    if  (idp = binid(root))  then
     begin
       if  (idgetkind (idp) == IDNONE)  then
         restyp = anytype ,
         *sc = sc_unknown ;
       else
       /*----------------*/
       /*  const or var  */
       /*----------------*/
       if  (idgetkind (idp) == IDCONST  or
            idgetkind (idp) >= IDRES1VAR) then
        begin
          restyp = iddatyp (idp) ;
          IF idgetkind (idp) == IDCONST THEN
            *sc = sc_const ;
            IF  (on_rename or id_is (idp, imported))
                and  restyp != rconstype  THEN
              binchange(root, binsymc(idvalue(idp)));
              IF sym_is[ binsymc(root)].value THEN
                 binupvalue( root, binvalue(idvalue(idp)));
              ELIF sym_is[ binsymc(root)].constant THEN
                 binupcharp( root, bincharp(idvalue(idp)));
              FI
            FI
          ELSE   *sc = sc_var ;
          FI
          if  (binright (root))  then
           begin
             errput (1409, binpos(root), NULL) ;
             /* This Identifier is declared as a constant or a variable */
             /* and must not have arguments.                            */
           end
        end /* const or var */
       else
        if  (asg == FASGN and idcurrf and idsym (idp) == idsym (idcurrf)) then
        /*---------------------------------*/
        /*  assignment to function result  */
        /*---------------------------------*/
         begin
           IF binright (root) THEN
              errput (1410, binpos(root), NULL) ;
             /* Illegal recursive call. */
           FI

           idfset (idcurrf, generated) ; /* mark as assigned */
           restyp = iddatyp (idcurrf) ;
           *sc = sc_var ;
           binchange (root, cCsymbol) ;         /* change to result id */
           binupsym  (root, symresid) ;
         end
        else
        /*-------------------*/
        /*  subroutine call  */
        /*-------------------*/
         begin
           boolean fcall = true;         /*Flag: To free tempvars or not */
           /* if  (symc == cIdent)                moved behind stdroutine() */
           /*  symc = cRout, binchange (root, cRout) ; */
           IF  asg==FCALL and idgetkind(idp) == IDPROCEDURE  THEN
              errput (1411, binpos(root), NULL) ;
              /* Illegal procedure call in expression. */
              restyp = anytype ;
           FI
           IF asg==PCALL and idgetkind(idp) == IDFUNCTION    THEN
              errput (1412, binpos(root), NULL) ;
              /* Illegal use of function at the beginning of statement. */
              restyp = anytype ;
           FI

           /* actual parameter list */
           tempend = tlistend;
           rtyp = (binright (root))? palist (root): NIL  ;

           idsy = idsym(idp);
           FOR i= 0, comp = true, not_found = true;
               i < 2 and not_found ;
               ++i,  comp = false
           DO
             /* search user routine */
             strong_comp = comp;

       /*27.10.92*/
       /* Check, if it is a call to ALLOCATE: VERY SPECIAL  CONVENTION !!!*/
       IF is_alloc THEN
         idp = (idptr)NIL;
       ELSE
         idp = idroutfnd ((idkind)asg, idsy , rtyp, not strong_comp ) ;
       FI
       /*idp = idroutfnd ((idkind)asg, idsy , rtyp, not strong_comp ) ;*/
             strong_comp = false;
             not_found = not idp;
             IF idp THEN
               binptr lista = rtyp,
                      listf = idparlist(idp),
                      clist = binright(root) ;

               binupid (root, idp) ;             /* userdefined routine */
               /* update actual parameters */
               IF not comp THEN
                 FOR ; listf and lista ;
                   lista = binright (lista) ,
                   listf = binright (listf) ,
                   clist = binright (clist)
                 DO
                   coerse(lista, listf, clist );
                 OD
               FI
               aparupdate (binright (root), rtyp, idparlist (idp)) ;

               IF sym_is[binsymc(unname(iddatyp(idp)))].arraytype THEN
                 tempvar = tempdecl ("af",iddatyp(idp) );
                 p = binright(root) ;
                 IF  p  THEN
                   p = bininsert( p , bincreate(cComma));
                   binappend( p,binsycreate(binsym(tempvar)));
                   binexchange(p);
                 ELSE
                   binappend( root,binsycreate(binsym(tempvar)));
                 FI
               FI
               restyp= (idgetkind(idp) == IDPROCEDURE)? voidtype:iddatyp(idp);
               *sc = sc_expr ;
             ELSE
               /* search standard routine */
               /* not userdefined routine */
               /*not_found is set by stdroutine*/
                 strong_comp = comp;
     /*Flag: for cALLOC processing */
     IF is_alloc THEN
     /* VERY SPECIAL  CONVENTION !!!*/
     /* The node will be deleted by stdroutine*/
        bininsert(binright(root),bincreate(cSemicolon));
     FI
                 restyp= stdroutine (root, rtyp,  &not_found, &fcall, sc ) ;
                 strong_comp = false;
             FI
           OD

           if  (idp and not binright(root)) /* if user defined routine, */
              binchange (root, cRout) ;     /* change to routine call */
           if  (restyp != rtyp)
             binldelete( rtyp);  /* clear palist */

           /*Clear tlist if necessary */
           IF fcall and tlistend  THEN
             IF tempend and tlistend != tempend THEN
               clrtmp(tempend);
             ELSE
               clrtmp(tlist);
             FI
           FI

         end /* routine call */
     end  /* idtab entry found */
    else                                        /* must be standard routine */
     begin
       boolean fcall = true;
       tempend = tlistend;

       /*28.10.92*/
       /* Check, if it is a call to ALLOCATE: VERY SPECIAL  CONVENTION !!!*/
       IF binsymc (binright( root)) == cSemicolon THEN
         bindelete (binright( root));
         rtyp = palist (root);

       FI
       rtyp = palist (root);
       /* looks up with coersions: "strong_comp" is set to false*/
       strong_comp = comp;

       IF is_alloc THEN
         /* VERY SPECIAL  CONVENTION for cALLOC!!!*/
         /* The node will be deleted by stdroutine*/
         bininsert(binright(root),bincreate(cSemicolon));
       FI
       restyp = stdroutine (root, rtyp ,&not_found, &fcall, sc) ;
       strong_comp = false;
       if  (restyp != rtyp)  binldelete( rtyp);  /* clear palist */

       /*Clear tlist if necessary */
       IF fcall and tlistend  THEN
         IF tempend and tlistend != tempend THEN
           clrtmp(tempend);
         ELSE
           clrtmp(tlist);
         FI
       FI

     end

   else  /* not identifier */
   /*------------*/
   /*  Operator  */
   /*------------*/
   if  (sym_is [symc] .Operator or symc == cAssign)  then
    begin
       binptr ltemp = NIL, rtemp = NIL;
       binptr op_ptr =
            (sym_is [symc] .userdefined and (symprio(symc) != priomonop))
                ? binright(root)
                : root;

       IF sym_is [symc] .userdefined and (symprio(symc) != priomonop) THEN
         ltyp= seman (binleft (op_ptr),FCALL, &lsc) ; /* left operand */
         IF tempvar THEN
            ltemp = tempvar;
            tempvar= NIL;
         FI
         rtyp= seman (binright(op_ptr),FCALL, &rsc) ; /* right operand */
         IF tempvar THEN
            rtemp = tempvar;
            tempvar= NIL;
         FI

/*         CLR_TEMP();
         IF ltemp THEN
            tempvar= ltemp;
            CLR_TEMP();
         FI
*/
         opsy= binsym (root) ;
      ELSE
         IF tempvar THEN
            ltemp = tempvar;
            tempvar= NIL;
         FI
         /* Left operand is already processed at the beginning of the
            proc.
         */
         rtyp = seman (binright(op_ptr), FCALL, &rsc) ; /* right operand */
         IF tempvar THEN
            rtemp = tempvar;
            tempvar= NIL;
         FI
/*         CLR_TEMP();
         IF ltemp THEN
            tempvar= ltemp;
            CLR_TEMP();
         FI
*/
         opsy = (( sym_is [symc] .userdefined ) )?binsym (root): symNIL;
      FI

   FOR i= 0, strong_comp = true,  not_found = true;
       i < 2 and not_found;
       ++i, strong_comp = false
   DO

      op = opfnd (symc, opsy, ltyp, rtyp,binpos(root)) ;
      not_found = not op;
      IF op THEN                                    /* Operator found */
         IF op_is (op,varpl) THEN
           IF not sym_is [binsymc (unname (ltyp))] .arraytype THEN
             p = binleft(op_ptr);
             IF  lsc != sc_var and /*  13.05.92 */
                 not sym_is[binsymc(p)].lvalue  THEN
               varexp( p, ltyp );
             ELIF optypl(op) != binid(ltyp) THEN
               varcast( p, idbin(optypl(op)));
             ELSE
               varparam( p,false);
             FI
           FI
         ELIF ltyp and not strong_comp THEN
          binptr t  = binidcreate( cIdent, optypl(op) );
          IF not sym_is [binsymc (ltyp)] .identifier THEN
            /* unnamed argument type */
            p= bincreate ( cComma ) ;
            binllink (p, ltyp) ;
            ltyp = p;
          FI
          coerse (ltyp, t, binleft(op_ptr));
          /*bindelete(t);*/
         FI
         IF op_is (op,varpr) THEN
           IF not sym_is [binsymc (unname (rtyp))] .arraytype THEN
             p = binright(op_ptr);
             IF  rsc != sc_var and /* 13.05.92 */
                 not sym_is[binsymc(p)].lvalue  THEN
               varexp( p, rtyp);
             ELIF optypr(op) != binid(rtyp) THEN
               varcast( p, idbin(optypr(op)) );
             ELSE
               varparam( p,false);
             FI
           FI
         ELIF rtyp and not strong_comp THEN
          binptr t = binidcreate( cIdent, optypr (op) );
          IF not sym_is [binsymc (rtyp)] .identifier THEN
            /* unnamed argument type */
            p= bincreate ( cComma ) ;
            binllink (p, rtyp) ;
            rtyp = p;
          FI
          coerse(rtyp, t, binright(op_ptr));
          /*bindelete(t);*/
         FI
         restyp = opresult (op) ;                       /* result type */
         IF  opcsym(op) != symNIL THEN
           IF  symprio (symc) == priomonop  THEN
             binchange (root, cCall) ;
             binupsym (root, opcsym (op)) ;
           ELSE
             binfunc (root, opcsym(op)) ;
           FI
           IF sym_is[binsymc(unname(restyp))].arraytype THEN
             tempvar = tempdecl ("af",restyp );
             p = binright(root) ;
             IF  p  THEN
               p = bininsert( p , bincreate(cComma));
               binappend( p,binsycreate(binsym(tempvar)));
               binexchange(p);
             ELSE
               binappend( root,binsycreate(binsym(tempvar)));
             FI
           FI
         FI
      ELSE
         restyp = stdOperator (root, ltyp, rtyp, lsc, rsc) ;
         not_found = (restyp == anytype);
      FI
   OD
   IF ltemp THEN
     tempvar= ltemp;
     CLR_TEMP();
   FI
   IF rtemp THEN
     tempvar= rtemp;
     CLR_TEMP();
   FI
      *sc = sc_expr ;
    end  /* Operator symbol */

   else
   switch (symc)
   begin
     /*---------*/
     /*   "^"   */
     /*---------*/
     case cArrow :
         idp = binid (ltyp) ;   /* type identifier of array type */
         if  (idp and id_is (idp, imported) and not id_is (idp, globalglobal))
            errput (1420, binpos(root), namestring (ltyp)) ;

         ltyp = unname (ltyp) ;
         if  (lsc != sc_var)
            errput (1205, binpos (root), NULL) ;

         IF binsymc (ltyp) == cFILE  THEN
            binchange (root, cPoint) ;
            binappend (root, binsycreate (symins ("win.dow"))) ;
            restyp = binright (ltyp) ;
         ELIF binsymc (ltyp) != cArrow  THEN
            errput (1413, binpos(root), NULL) ;
            /* Left side is neither a pointer nor a file type. */
            restyp = ltyp ;
         ELSE
           restyp = binright (ltyp) ;
           IF on_index  THEN
             /* create "*(restyp *)a_nilc(...)" */
             binptr call = bincreate( cComma);
             binexchange(root);
             binexchange( bininsert(binright(root),call));
             binchange(call,cCall);
             binupsym( call, symins("a_nilc"));

             IF binid(restyp) THEN
               p = bininsert(call,bincreate(cPCast));
               binexchange(p);
               binllink (p,restyp);
             FI
           FI
         FI
         *sc = sc_var ;
     break ;    /* arrow found */

     /*---------*/
     /*   "."   */
     /*---------*/
     case cPoint :
         idp = binid (ltyp) ;   /* type identifier of record type */
         if  (idp and id_is (idp, imported) and not id_is (idp, globalglobal))
            errput (1420, binpos(root), namestring (ltyp)) ;

         ltyp = unname (ltyp) ;
         if  (lsc != sc_var)
            errput (1205, binpos (root), NULL) ;

         if  (binsymc (ltyp) != cRECORD)  then
          begin
            errput (1414, binpos(root), NULL) ;
                       /* Left side is not a record type. */
            restyp = ltyp ;
          end
         else
          begin
            restyp = reccfnd (binsym (p = binright (root)), ltyp,
                              binleft(root) ) ;
                                                        /* search component */
            if  (restyp == voidtype)  then
             begin
               errput (1415, binpos(p), NULL) ;
                        /* No such record component found. */
               restyp = ltyp ;
             end
            else  /* found */
             if  (reccidp)  then   /* element name renamed */
              begin
                binchange (p, cIdent) ;
                binupid (p, reccidp) ;
                reccidp = (idptr)0 ;
              end

            if  (binsymc (binleft (root)) == cArrow)  then
             begin
               binchange (root, cPArrow) ;              /* change to "^." */
               bindelete (binleft(root)) ;
             end
          end /* left is record */
         *sc = sc_var ;
     break ;    /* point found */


     /*---------*/
     /*  "id["  */
     /*---------*/
     case cArry :
         idp = binid (root) ;
         if  (asg==FASGN and idcurrf and idsym (idp) == idsym (idcurrf))
          begin
            idp = idcurrf;
            idfset (idcurrf, generated) ; /* mark as assigned */
          end
         if  (idgetkind (idp) < IDRES1VAR and
              not (asg==FASGN and idp == idcurrf) )  then
          begin
            errput (1416, binpos(root), NULL) ;
                     /* Identifier is not an array Variable. */
          end
         ltyp = iddatyp (idp) ;
         IF asg == FASGN and idp == idcurrf THEN
           binchange (root, cArrVar) ;                  /* change to "[" */
           binllink(root,NIL);
           binlside (root, binsycreate (symresid)) ;    /* append result id */
           binuppos (binleft (root), binpos (root)) ;
         FI

         lsc = sc_var ; /* prevents error */
         /* continue next case */
     /*---------*/
     /*   "["   */
     /*---------*/
     case cArrVar :
         idp = binid (ltyp) ;   /* type identifier of array type */
         if  (idp and id_is (idp, imported) and not id_is (idp, globalglobal))
            errput (1420, binpos(root), namestring (ltyp)) ;

         ltyp = unname (ltyp) ;
         if  (lsc != sc_var)
            errput (1205, binpos (root), NULL) ;


         IF  not (binsymc (ltyp) == cARRAY   or
                  binsymc (ltyp) == cDYNAMIC or
                  binid   (ltyp) == idSTRING )
         THEN
            errput (1417, binpos(root), NULL) ;
                                 /* Is not an Array type. */
            restyp = ltyp;
         ELSE
            restyp = arracc(ltyp, root );
         FI
         *sc = sc_var ;

     break ;    /* array access found */

     /*-----------*/
     /* constants */
     /*-----------*/
     case cIcon:  *sc = sc_const ; restyp = integertype ;   break ;
     case cCcon:  *sc = sc_const ; restyp = chartype ;      break ;
     case cBcon:  *sc = sc_const ; restyp = booleantype ;   break ;
     case cScon: /* ; case cS2con : ; case cS3con : ; case cS4con : */
                  *sc = sc_const ; restyp = root       ;    break ;
     case cRcon:  *sc = sc_const ;
                  realconst (root);restyp = rconstype ;     break ;

     /*------------------*/
     /*   "(<" or "(>"   */
     /*------------------*/
     case cLParD:  case cLParU:
         *sc = sc_const ;
         if  (idrdconv == (idptr)0  or  idruconv == (idptr)0)
            errput (1424, binpos (root), NULL) ;
                        /* Rounded real constant conversion not declared. */
         realconst (root);
         restyp = rconstype ;
                                                            break ;

     /*---------*/
     /*   "#"   */
     /*---------*/
     case  cDot : ; case cDotN : ;                       /* "#" found */
     case  cDotD: ; case cDotU : ; case cDotS :
          begin
            *sc = sc_expr ;
            restyp = dotseman (root) ;
            IF tempvar THEN
              var2list(tempvar );     /* Add tempvar to the tlist */
              tempvar = NIL;
            FI
          end
     break ;    /* sharp  found */

     /*---------*/
     /*   "]"   */
     /*---------*/
     case cRBrack :
         restyp = setconstr (root) ;
         *sc = sc_expr ;
     break ;    /* set constructor found */

     /*---------*/
     /*   NIL   */
     /*---------*/
     case cNIL :
         restyp = pointertype ;
         *sc = sc_const ;
     break ;    /* NIL found */

     /*-----------------------*/
     /*   '(' or ',' or '..'  */
     /*-----------------------*/
     case cLParent : case cComma : case cTill :         /* syntax error */
         restyp = seman (binleft  (root), FCALL, sc) ;  /* ignore left side */
         restyp = seman (binright (root), FCALL, sc) ;
     break ;    /* '(' found */

     default :
         errput (9012, binpos(root), symptext [symc]);
         /* Unknown symbol in seman: 'symptext [symc]' */
         restyp = anytype ;
         *sc = sc_expr ;
   end /* switch */ ;
 end /* root not NIL */
 else  *sc = sc_unknown , restyp = NIL ;
 RETURN (restyp) ;
END /* seman  */                                /*  s e m a n  */
                                                /*-------------*/









