/*
 *  MODULE:  std.c
 *  analysis and tree modification for
 *  standard procedures, functions and Operators
 *  initialization of standard identifiers
{*  last modification:  29.10.92  14:36   }


 * uli 14.11.90 : compatible  checks idSTRING instead of cSTRING
 *                cAssign: s_asta added for dynamic string := static string
 * uli 15.11.90 : ins_sizeof handles string constants, cast to string and
 *                string assignment modified, handles string to string.
 *  uli 19.11.90 : cTemptype   added
 *  uli 28.11.90 : tempvar called in dynamic array assignment
 *  uli 04.12.90 : stdinit calls idsetbin
 *  DS 08.01.91 : illroutine improved because of subprogs. as params.
 *  DS 10.01.91.: prototypes are added for local functions
 *  uli 05.02.91: local variable pos added in "TYPE conversion function"
                    when deleting cast-op for arrays.
 *  uli 12.02.91: idBAD_ID defined.
 *  uli 08.03.91: maxint has value LONG_MAX now
 *  Dima 15.04.91: : For-variables cannot be assigned to.
 *  Dima 15.04.91: : Added reset(f,fname) and rewrite(f,fname)
 *  uli 24.04.91: stdinit: idTRUE, idFALSE, idMAXINT defined.
 *  uli 08.05.91 : stdinit: rconstype added.
 *  uli 13.05.91 : ORD accepts pointer type.
 *  uli 13.05.91 : stdinit: idruconv and idrdconv added provisional.
 *  uli 13.05.91 : stdroutine: uses cPCast now.
 *  uli 14.05.91 : RESET: do not generate filevarname, if 2. par is string.
 *  uli 29.05.91 : cAssign:  y_desc*  replaced by  y_dscp .
 * Dima 18.06.91.: LBOUND & UBOUND : for static arrays improved.
 * Dima 18.06.91.: SUCC  : on_index control added
 * Dima 18.06.91.: stdinit  CHR : on_index control added
 *  uli 19.06.91 : LBOUND & UBOUND : return index type.
 * Dima 20.06.91 : LBOUND & UBOUND : index type return corrected
 *  uli 26.06.91 : stdinit: realconstant conversion no longer initialized.
 *  uli 01.07.91 : compatible: array := stringconstant checks length.
 *  uli 01.07.91 : stdroutine: handling of type conversion moved
                   from default case to in front of switch symc.
 *  uli 02.07.91 : stdroutine: cSTRING and cSCALP deleted.
 *  uli 05.07.91 : compatible : handle of symbol nodes corrected.
 *  uli 05.07.91 : ds_compatible : corrected.
 *  uli 08.07.91 : relational Operators : "unname" add before "subtype"
 *  Dima 10.07.91 : compatible : sub_or_base_of added
                    subtypes are not compatible to each other now
 *  uli 12.07.91 : compatible: expression simplified.
 * Dima 06.08.91 : stdroutine: conversion text(...) added
 *  uli 06.08.91 : stdinit: idPTRCHAR and ptrchartype (type + coersion) added.
 * Dima 07.08.91 : stdroutine: conversion text(...) corrected
 * Dima 07.08.91 : stdroutine: sizeof(...) added;
 *  uli 09.08.91 : stdinit: idINT_OF_c and int_of_ctype (type + coersion) added.
 *  uli 12.08.91 : cSIZEOF: warning added.
 * Dima 17.11.91 : varexp moved from seman.c
 * Dima 19.11.91 : type_conv is singled out from stdroutine and corrected
 * Dima 21.11.91 : New compatible see compat.dok
 * Dima 22.11.91 : type_conv: moved to optab (coers)
 *  uli 28.11.91 : stdinit : idp used to define idBAD_ID.
 *  uli 09.12.91 : stdinit : nodecl flag set.
 *  uli 11.12.91 : namestring : level added.
 *  uli 12.12.91 : printname and printline deleted.
 *  uli 16.12.91 : type_of_verg: cString replaced by cSTRING
 *  uli 19.01.92 : comparisons : len1 and len2 inited with -1.
 *  uli 23.01.92 : cIDOT etc. added.
 *  uli 24.01.92 : namestring handles NIL.
 *  uli 11.02.92 : stdinit: string_of_c is char* instead of a_char* .
 *  uli 14.02.92 : stdinit: cdotprecisiontype got wrong idptr.
 *  uli 13.05.92 : ":=" : usage of lvalue to check C-variable.
 *  uli 13.05.92 : varexp : lvalue added.
 *  uli 23.06.92 : pointer_of_ctype changed to ptr_of_ctype.
 * Dima 21.10.92 : Assignment of cDot etc. added
 * Dima 21.10.92 : unnessary "unname" by the assignment of strings eliminated
 * Dima 22.10.92 : All statements belonging to "#ifdef OLD" deleted
 * Dima 26.10.92 : Processing of cALLOCATED, cFREE, cALLOCATE  is added.
 *  PJ  30.03.95 : Casts for ANSI compatibility inserted.
*/

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <limits.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 "arrx.h"

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

#define CHECK


#ifdef LINT_ARGS
local void illop            (binptr exp, binptr ltyp, binptr rtyp);
local char type_of_verg     ( binptr type, long int *arr_len );
#else
local void illop            ( );
local char type_of_verg     ( );
#endif

/*-------------------------------------------------------------------------*/
/* If an expression is passed to the formal VAR-parameter then the nesessary
   tempvar is inserted.
   If acttype in [#,string,set,dynamic] then destroy flag is set.
*/
#ifdef LINT_ARGS
global void varexp  ( binptr actpar,binptr acttype)
#else
global void varexp ( actpar,acttype )             /* v a r e x p*/
  binptr actpar;
  binptr acttype;
#endif
{
  binptr tempvar; /* 25.07.90 temporal vars. are not to be released so far*/
  binptr u,f ;  /* pointer to Untemp node and Free node */
  idptr idp = binid (acttype) ;
  /*int ind = 0;
  static char * undname[4] = { "d_utmp","s_utmp","s_eutp","y_utmp"};*/

  /* The next statement must be eventually outcommented !!! */
  if  (!idp)  acttype = binleft (acttype) ;

  /* temp var for Lohner trick */
  if  (sym_is[binsymc(actpar)].lvalue)
     tempvar = actpar ;
  else
     tempvar = tempdecl("lo", (idp ? idbin(idp) : acttype) );

  if  ( (idp ? id_is (idp, dynamic) or id_is (idp, hasdyn)
             : not  sym_is [binsymc(acttype)].scalartype  ) )
               /* hasdyn assumed for nonscalar unnamed types */
  {
       varparam(bintemp( actpar, binsym(tempvar)), false);

     /* create a node for  "undestroy(&temp);" */
      u = bincreate( cUntemp);
      f = bincreate( cFree);
      if  (idp)    /* name actual type */
        binllink (u,idbin(idp)),
        binllink (f,idbin(idp));
        /* It is not possible to hang up the pure acttype,
           since it will be destroyed together with palist later on
        */
      else         /* unnamed actual type */
        binllink (u, acttype) ,
        binllink (f, acttype) ;

      binappend(u, binsycreate(binsym(tempvar)));
      binappend(f, binsycreate(binsym(tempvar)));
      /* create and add "temp = actpar;" to binstm list
                    add "free(temp);" to binend list
         and change actpar to "&temp"
      */
     /* add undestroy-node to binstm list*/
       binlist ( u, &binstm );
     /* add Free-node to binend list*/
       binlist ( f, &binend );
  } else { /* not dynamic */
     /* add "temp = actpar;" to binstm list*/
      if (tempvar != actpar) /* avoid: "actpar = actpar" */
       varparam(bintemp( actpar, binsym(tempvar)), false);
  }
}                                                      /*  v a r e x p  */
                                                       /*---------------*/

                                                /*-----------------------*/
#ifdef LINT_ARGS
global char * namestring  (  binptr p )         /*  n a m e s t r i n g  */
#else
global char * namestring (p)
  /* returns a textual representation of the */
  /* identifier node *p or a data type,  used for errormessages. */
  binptr p ;
#endif
BEGIN(namestring)
  static char res [266] ;
  symctype symc = binsymc (p) ;
  idptr innerid ;

  if  (symc == cTemptype or symc == cCsymbol)  then   /* temp. type */
    p = binright(p) ,  symc = binsymc (p) ;

  if  (binid(p))  then
   begin
     innerid = idfnd (idsym(binid(p))) ;
     if  (innerid == binid(p))
       return (symtab(idsym(binid(p)))) ;   /* identifier */
     else
       sprintf (res, "%s.%d", symtab(idsym(binid(p))),
                               (int) idlevel(binid(p)) - 1);
       return (res) ;
    end
  else
  if  (binsym(p) != symNIL)  then
    return (symtab(binsym(p))) ;         /* symbol */
  else
   begin
     strcpy (res, symptext[symc]) ;
     if  (symc == cArrow and binright(p))  then /* pointer type */
       strcat (res, symtab(idsym(binid(binright(p))))) ;
     else
     if  (symc == cLParent)  then               /* enumeration type */
      begin
       strcat (res, symtab(idsym(binid(binright(p))))) ;
                                                /* only first constant */
       strcat (res, ",...)") ;
      end
     return (res) ;
   end ;
END /* namestring */                            /*  n a m e s t r i n g  */
                                                /*-----------------------*/


                                                /*---------------------*/
                                                /*  c h k s c a l a r  */
#ifdef LINT_ARGS
global void chkscalar  (  binptr datyp ,postype pos )
#else
global void chkscalar (datyp, pos)
  /* report an error at position pos, if the Pascal data type datyp is not */
  /* boolean, integer, char, enumeration nor a subrange of these.    */
  binptr datyp ;
  postype pos ;
#endif
BEGIN(chkscalar)
  if  (not sym_is [binsymc(unname(datyp))] .scalartype
       and datyp != anytype )  then
    begin
      errput (1601, pos, namestring (datyp)) ;
         /* "Scalar data type expected, datyp found."  */
    end
END /* chkscalar */                             /*  c h k s c a l a r  */
                                                /*---------------------*/

                                                /*-------------------*/
#ifdef LINT_ARGS
global void   varparam  (  binptr actpar ,boolean arr )
#else
global void   varparam (actpar, arr)            /*  v a r p a r a m  */
  /* updates the actual parameter actpar */
  /* by adding the address Operator in case of not arr. */
  binptr actpar ;  /* actual parameter  */
  boolean arr ;    /* "parameter is array type " */
#endif
BEGIN(varparam)
       IF not  arr THEN
         IF binsymc(actpar) == cArrow THEN /* optimisation  "&*" */
            bindelete(actpar);
         ELSE
           bininsert (actpar, bincreate (cAdres)) ;
           binexchange (binfather (actpar)) ;         /* add &-Operator */
         FI
       FI
END /* varparam */                              /*  v a r p a r a m  */
                                                /*-------------------*/


                                                /*---------------------*/
#ifdef LINT_ARGS
global unsigned long int rangesize  (  binptr p )
#else
global unsigned long int rangesize (p)           /*  r a n g e s i z e  */
  /* determines the size of a scalar data type p */
  binptr p ;
#endif
BEGIN(rangesize)
  long int size ;
  p = unname (p) ;
  switch  (binsymc (p))
   begin
     case  cTill :     /* subrange type */
         return( binvalue (binright (p)) -       /* ubound -  */
                 binvalue (binleft  (p)) + 1 );  /* lbound +1 */
     case  cCHAR :      return (256) ;
     case  cBOOLEAN :   return (2) ;
     case  cLParent :  /* enumeration type */
         size = 0; p = binright (p) ;
         while  (binsymc (p) == cIdlist)  size++, p = binright (p) ;
         return size ;
     default : return (0) ;
   end /* case */
END /* rangesize */                             /*  r a n g e s i z e  */
                                                /*---------------------*/


                                                /*-----------------------*/
#ifdef LINT_ARGS
global void ins_sizeof  (  binptr p, binptr typ1 )
#else
global void ins_sizeof (p, typ1 )               /*  i n s _ s i z e o f  */
  /* inserts the size of the arraytype typ1 */
  /* or the string constant typ1 above the node p. */
  binptr p, typ1 ;
#endif
BEGIN(ins_sizeof)
  unsigned long size = 1 ; /* product of index ranges */
  binptr  ntyp = typ1 ;     /* named component type */

  p= bininsert (p, bincreate (cComma)) ;        /* insert a comma */
  if  (binsymc (typ1) == cScon)
    begin                                       /* string constant */
       p = binappend (p, bincreate (cIcon)) ;
       binupvalue (p, (long) strlen (bincharp (typ1))) ;
       return ;
    end ;

  typ1 = unname (typ1) ;
  if  (binsymc (typ1) == cARRAY)  then
    begin
      do
        begin                         /* evaluate array size */
          size *= rangesize (unname (binleft (typ1))) ;
          typ1 = unname (ntyp= binright (typ1)) ;
        end
      while  (binsymc (typ1) == cARRAY) ;

      p = binappend (p, bincreate (cIcon)) ;        /* array size */
      binupvalue (p, size) ;
      if  (typ1 == chartype)  then   return ;  /* exit: no sizeof */

      p= bininsert (p, bincreate (cMult)) ;         /* add "*" */
      p= binappend (p, binsycreate (symins ("sizeof"))) ;
      binchange (p, cCall) ;                        /* add sizeof */
    end /* cARRAY */

  if  (binsymc (typ1) == cSET)  then
    binappend (p, binsycreate (symins ("s_SIZE"))) ; /* set size */
  else
    binrlink (p, ntyp) ;
END /* ins_sizeof */                            /*  i n s _ s i z e o f  */
                                                /*-----------------------*/

static standard = false; /* It is a standard routine */
boolean strong_comp = false;

#ifdef LINT_ARGS
global binptr stdroutine  (                     /*  s t d r o u t i n e  */
  binptr exp, binptr atyp,
  boolean *not_found, boolean *fcall, sc_type *sc )
#else

global binptr stdroutine (exp, atyp, not_found, fcall, sc)
  /* handles the routine call exp with the */
  /* argument types atyp (PA list) as a standard routine, */
  /* that is an undeclarable routine and */
  /* returns the result data type or anytype, if illegal */
  /* Sets a flag fcall : Is it a function call or type conversion function*/
  binptr exp, atyp ;
  boolean *not_found;
  boolean *fcall;
  sc_type *sc;
#endif
BEGIN(stdroutine)
  binptr typ1 =  atyp ;             /* first parameter type */
  binptr typ2 =  binright (typ1) ;  /* second parameter type */
  binptr typ3 =  binright (typ2) ;  /* third parameter type */
  binptr typ4 =  binright (typ3) ;  /* fourth parameter type */
  boolean varp1  =                  /* first parameter is variable */
          binsymc (typ1) == cVarparam  or  binsymc (typ1) == cVAR ;
  boolean varp2  =                  /* second parameter is variable */
          binsymc (typ2) == cVarparam  or  binsymc (typ2) == cVAR ;
  short int parcount ;             /* parameter counter */
  binptr restyp  = anytype;
  binptr filevar ;                 /* file variable in io */
  binptr p, p1  ;
  symctype symc  = binsymc (exp) ;
  idptr idp ;
  int Farg = 0  ;
  unsigned long int dimension  = 0;
  int dim_err=  0;
  int i;
  boolean is_alloc = false;

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



  restyp = type_conv( exp, atyp, not_found) ;
  *fcall = (restyp == anytype);
  IF not *fcall   THEN
    *sc = ( binsymc(atyp) == cVarparam or binsymc(atyp) == cVAR )
        ? sc_var : sc_expr ;
    /* It was a  type conversion function  and not a real C function call.
       If tempvar was produced in palist, it must not be freed
    */
    return restyp;
  FI

  *sc = sc_expr ;
  p = binright  (exp) ;
  IF  p  THEN
    parcount =  1 ;
    while  (binsymc (p) == cComma)              /* count parameters */
      parcount++ ,  p = binright (p) ;
  ELSE
    parcount = 0 ;                              /* no parameters */
  FI

  if  (typ1  and  not sym_is [binsymc (typ1)] .identifier)
    typ1 = binleft (typ1) ;    /* 1. param has unnamed data type */
  if  (typ2  and  not sym_is [binsymc (typ2)] .identifier)
    typ2 = binleft (typ2) ;    /* 2. param has unnamed data type */
  if  (typ3  and  not sym_is [binsymc (typ3)] .identifier)
    typ3 = binleft (typ3) ;    /* 3. param has unnamed data type */
  if  (typ4  and  not sym_is [binsymc (typ4)] .identifier)
    typ4 = binleft (typ4) ;    /* 4. param has unnamed data type */

  /*Default is FOUND, if not the flag is set back by "illroutine" or explicit */
  *not_found = false;

   switch  (symc )
   begin
       /*-------------------------*/
     case  cSIZEOF :
       /*-------------------------*/
         restyp = integertype ;
         IF parcount != 1 THEN
           illroutine (exp,atyp,not_found);
           return (strong_comp)?anytype: restyp;
         ELSE
           if  (id_is (binid (atyp), desctype))
             errput (173, binpos (exp), NULL) ;
                                        /* Warning: descriptor size only */
           binchange (exp, cCall) ;
           binupsym  (exp, symins ("sizeof")) ;    /* set runtime name */
         FI
     break;
       /*-------------------------*/
     case  cORD :                 /* case  cINTEGER :  handled above */
       /*-------------------------*/
         restyp = integertype ;
         IF parcount != 1 THEN
           illroutine (exp,atyp,not_found);
           return (strong_comp)?anytype: restyp;
         ELSE
            IF  (not sym_is [binsymc(unname(typ1))] .scalartype
                and binsymc (unname (typ1)) != cArrow   /* pointer */
                and typ1 != anytype )
            THEN
              illroutine (exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI
            FI
            binchange (exp, cRParent) ;          /* create cast Operator */
            binllink (exp, integertype) ;        /*  to integer          */
         FI
     break ; /* ord */

       /*-----------------------*/
     case  cSUCC :  case  cPRED :
       /*-----------------------*/
         restyp = typ1 ;
         if  (parcount != 1) then
           {illroutine (exp,atyp,not_found);
           return (strong_comp)?anytype:restyp;}
         else
          begin
            if  (not sym_is [binsymc(unname(typ1))] .scalartype
                and typ1 != anytype )
            then
              {illroutine(exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI}

            if  (symc == cSUCC)  then
              binchange (exp, cPlus) ;
            else
              binchange (exp, cMinus) ;
            binllink (exp, NIL) ;        /* kill id ptr */
            binexchange (exp) ;                          /* "+ 1" or "- 1" */
            binappend (exp, bincreate (cIcon)) ;
            binupvalue (binright(exp), (long int) 1) ;
          end

          IF on_index THEN
            p = subtype(typ1);
            IF binid(p) != idINTEGER THEN
              p = ixch(exp,p);
              p = bininsert( p, bincreate(cRParent)) ;
              binexchange(p);
              binllink (p, typ1) ;
            FI
          FI
     break ; /* succ, pred */

       /*--------------------------*/
     case   cALLOCATED :
       /*--------------------------*/
       restyp = booleantype ;             /* function call */
       IF (parcount != 1) or (binsymc (unname (typ1)) != cDYNAMIC) THEN
         illroutine (exp,atyp,not_found);
         return (strong_comp)? anytype:restyp;
         /* IF strong_comp THEN return anytype; FI */
       FI
       binchange (exp, cCall) ;
       varparam (binright (exp), false) ;
       /* cast Operator (y_dscp) */
         p = bininsert (binright (exp), bincreate (cRParent)) ;
         binappend (p, binsycreate (symins("y_dscp"))) ;
         binexchange (p) ;
       binupsym  (exp, symins ("y_aled")) ;    /* set runtime name */
       break;

       /*--------------------------*/
     case   cFREE :
       /*--------------------------*/
       restyp = voidtype ;             /* procedure call */
       IF (parcount != 1) or (binsymc (unname (typ1)) != cDYNAMIC) THEN
         illroutine (exp,atyp,not_found);
          return (strong_comp)? anytype:restyp;
         /* IF strong_comp THEN return anytype; FI*/
       FI
       binchange (exp, cCall) ;
       varparam (binright (exp), false) ;
       /* cast Operator (y_dscp) */
         p = bininsert (binright (exp), bincreate (cRParent)) ;
         binappend (p, binsycreate (symins("y_dscp"))) ;
         binexchange (p) ;
       binupsym  (exp, symins ("y_free")) ;    /* set runtime name */
       break;

       /*--------------------------*/
     case   cALLOCATE :
       /*--------------------------*/
        IF not is_alloc THEN
           illroutine (exp,atyp,not_found);
           return (strong_comp)? anytype: voidtype;
        FI

       /* Strong_comp is not considered since it is already
        * recognized by the parser
        * that it is a Std. procedure call
        */
       restyp = voidtype ;             /* procedure call */
       /* First Parametr must be a dynamic array*/
       IF not varp1 THEN
          errput (1618, binpos(binleft(binright(exp))), (char*)0);
          /* First Parameter must be a variable */
       ELSE
          IF binsymc (unname (typ1)) != cDYNAMIC THEN
            errput (1619, binpos(binleft(binright(exp))), (char*)0);
           /*First parameter must be a Dynamic Array*/
          ELSE
           /* The number of parameters must correspond to the number of dimensions*/
           i = n_dimensions(typ1);
           IF ((parcount-1 ) /2) != i THEN
             IF ((parcount-1 ) /2) > i THEN
               errput (1024, binpos(binright(exp)), (char*)0);
               /* ("Too many index ranges for dynamic array.")  */
             ELSE
               errput (1025, binpos(binright(exp)), (char*)0);
               /* ("Too few index ranges for dynamic array.")  */
             FI
           FI
         FI
       FI
       binchange (exp, cCall) ;
       varparam (binleft  (binright (exp)), false) ;
       /* cast Operator (y_dscp) */
         p = bininsert (binleft  (binright (exp)), bincreate (cRParent)) ;
         binappend (p, binsycreate (symins("y_dscp"))) ;
         binexchange (p) ;
       binupsym  (exp, symins ("y_new")) ;    /* set runtime name */

       break ; /* allocate*/

       /*--------------------------*/
     case   cREAD  :  case cWRITE  :
       /*--------------------------*/
         restyp = voidtype ;             /* procedure call */

         if  (symc == cWRITE and (binid (typ1) == idTEXT or         /* text or */
               binsymc (unname (typ1)) == cFILE and                 /* file of */
               binsymc (unname (binright (unname (typ1)))) == cCHAR  /*  char  */
              ) and (binsymc (typ2) == cScon                /* string constant */
               or
               binsymc (unname (typ2)) == cARRAY and       /* or array of char */
               binsymc (unname (binright (unname (typ2)))) == cCHAR )
             ) then                                  /*----------------------*/
          begin                                      /* write string to text */
           IF (parcount >= 3 and unname (typ3) != integertype)
              or
              parcount > 3
           THEN
              illroutine(exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI
           FI
           binchange (exp, cCall) ;
           varparam (binleft  (binright (exp)), false) ;
           if  (parcount >= 3)  then
            begin /* format specification in write string */
              binupsym  (exp, symins ("f_wrc2")) ;    /* set runtime name */
              exp = binright (binright (binright (exp))) ;
              bininsert (exp, bincreate (cComma)) ;   /* insert a Comma */
              exp = binfather (exp) ;
              binappend (exp, bincreate (cIcon)) ;    /* add string length */
              IF  (binsymc (typ2) == cScon)  THEN
          binupvalue (binright (exp),  (long int)
          strlen (bincharp (typ2))) ;
              ELSE
          p = binleft (unname(typ2));
          binupvalue (binright (exp), rangesize (p)) ;
                      /* ubound - lbound +1 */
          /*  binvalue (binright (p)) - binvalue (binleft  (p)) + 1) ; */
              FI
              binexchange (exp) ; /* format <-> stringlength */

            end /* format specification in write string */
           else
            begin /* no format specification in write string */
              binupsym  (exp, symins ("f_wrc1")) ;    /* set runtime name */
              exp = binright (binright (exp)) ;
              bininsert (exp, bincreate (cComma)) ;   /* insert a Comma */
              exp = binfather (exp) ;
              binappend (exp, bincreate (cIcon)) ;    /* add string length */
              IF  (binsymc (typ2) == cScon)  THEN
                binupvalue (binright (exp), (long int)
                            strlen (bincharp (typ2))) ;
              ELSE
                p = binleft (unname(typ2));
                binupvalue (binright (exp), rangesize (p)) ;
                     /* ubound - lbound +1 */
                 /*  binvalue (binright (p)) - binvalue (binleft  (p)) + 1) ; */
              FI
            end /* no format specification in write string */

          end  /* write string to text */
                                                              /*------------*/
         else                                                 /* binary I/O */
         if  (parcount != 2) then
           {illroutine(exp,atyp,not_found);
           return (strong_comp)?anytype:restyp;}
         else
          begin
            if  (binsymc (unname (typ1)) != cFILE)  then
              {illroutine(exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI}
            else
            if  (not compatible (binright (unname (typ1)), typ2))  then
              {illroutine(exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI}

            IF symc == cREAD  THEN
              if  (not varp1)  then
              begin
               IF not strong_comp THEN
                 errput (1602, binpos(binright(exp)), (char*)0);
                /* ("This Parameter must be a Variable.")  */
               ELSE
                 *not_found= true;
                 return anytype;
               FI
              end ;
              /*chkvarparam (typ2, binpos(binright(binright(exp))));*/
              binchange (exp, cCall) ;
              binupsym (exp, symins ("f_read")) ;        /* set runtime name */
            ELSE /* WRITE */
              binchange (exp, cCall) ;
              binupsym (exp, symins ("f_writ")) ;
              IF  not varp2
              THEN                               /* create temporary variable */
                                         /* because f_writ has var parameters */
                tempvar = tempdecl("wr",typ2 ) ;
                p = binright(binright(exp));
                bintemp (p, binsym(tempvar));
                /* mark temporary variable as free */
                  binchange (tempvar, cTempvar) ;
                /* modify assignment, if necessary */
                  stdOperator(binfather(p),typ2,typ2,sc_var,sc_expr);
              FI
            FI
            varparam (p = binleft (binright (exp)), false) ;
            if (binid (typ1) != idTEXT)
             begin    /* add cast Operator to pointer to text */
               p = bininsert (binfather (p), bincreate (cPCast)) ;
                                                 /* cast Operator above & */
               binrlink (p, texttype) ;       /* to pointer to  text type */
               binexchange (p) ;
             end ;
            varparam (binright (binright (exp)), (boolean)
                      sym_is[binsymc(unname(typ2))].arraytype) ;
          end
     break ; /* read, write */

       /*---------*/
     case   cEOF  :
       /*---------*/
         restyp = booleantype ;
         IF parcount > 1 THEN
           illroutine(exp,atyp,not_found);
           IF strong_comp THEN return anytype; FI
         FI
         if  (parcount >= 1)  then
          begin         /* one argument */
            IF binsymc (unname (typ1)) != cFILE THEN
              illroutine(exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI
            FI
            binchange (exp, cPoint) ;    /* create ".eof" */
            binllink (exp, NIL) ;
            binexchange (exp) ; /* shift file left */
            binappend (exp, binsycreate (symins ("eof"))) ;
          end
         else  /* no argument */
          begin
            binchange (exp, cCsymbol) ;
            binupsym  (exp, symins ("f_inpu.eof")) ;     /* set runtime name */
          end ;
     break ; /* eof */

       /*----------*/
     case   cEOLN  :
       /*----------*/
         restyp = booleantype ;
         IF  (parcount > 1) THEN
           illroutine(exp,atyp,not_found);
           IF strong_comp THEN return anytype; FI
         FI
         if  (parcount >= 1)  then
          begin         /* one argument */
            IF  (binid (typ1) != idTEXT)  THEN
              illroutine(exp,atyp,not_found);
              IF strong_comp THEN return anytype; FI
            FI
            binchange (exp, cPoint) ;    /* create ".eoln" */
            binllink (exp, NIL) ;
            binexchange (exp) ; /* shift file left */
            binappend (exp, binsycreate (symins ("eoln"))) ;
          end
         else  /* no argument */
          begin
            binchange (exp, cCsymbol) ;
            binupsym  (exp, symins ("f_inpu.eoln")) ;    /* set runtime name */
          end ;
     break ; /* eoln */

       /*-----------------------*/
     case   cGET  :  case cPUT  :
       /*-----------------------*/
         restyp = voidtype ;             /* procedure call */
         IF (parcount != 1) THEN
           illroutine(exp,atyp,not_found);
           return (strong_comp)?anytype:restyp;
         FI
         IF  (binsymc (unname (typ1)) != cFILE)  THEN
           illroutine(exp,atyp,not_found);
           IF strong_comp THEN return anytype; FI
         FI
            varparam (p = binright (exp), false) ;
            if (binid (typ1) != idTEXT)
             begin    /* add cast to text */
               p = bininsert (binfather (p), bincreate (cPCast)) ;
                                                 /* cast Operator above & */
               binrlink (p, texttype) ;       /* to pointer to  text type */
               binexchange (p) ;
             end ;
            binchange (exp, cCall) ;
            if  (symc == cGET)  then
              binupsym  (exp, symins ("f_get_")) ;       /* set runtime name */
            else
              binupsym  (exp, symins ("f_put_")) ;
     break ; /* get, put */

       /*----------------------------*/
     case  cRESET :  case  cREWRITE  :
       /*----------------------------*/
         restyp = voidtype ;             /* procedure call */
         IF  (parcount == 0  or  parcount > 2) THEN
           illroutine(exp,atyp,not_found);
           return (strong_comp)?anytype :restyp;
         FI

#define ut1 p
#define ut2 p1

         ut1 = unname(typ1);
         ut2 = unname(typ2);
         IF  (binsymc (ut1) != cFILE) or
             ( (parcount == 2) and  not
               ( binsymc (typ2) == cScon        /* string constant */
                or
                 ut2 == chartype        /* char constant */
                or
                 binsymc (ut2) == cARRAY and       /* or array of char */
                 binsymc (unname (binright (ut2))) == cCHAR
                or
                 binid(ut2) == idSTRING
               )
             )
         THEN
           illroutine (exp,atyp,not_found);
           IF strong_comp THEN return anytype; FI

         ELSE /* set runtime name */
           binchange (exp, cCall) ;
           IF (binsymc (ut1) == cFILE) and
               binid(ut2) == idSTRING
           THEN
             binupsym  (exp, symins ( (symc == cRESET)?"f_srse":"f_srwi ")) ;
           ELSE
             binupsym  (exp, symins ( (symc == cRESET)?"f_rset":"f_rwri")) ;
           FI
         FI

         filevar = binright (exp);
         if  (parcount >= 2)
           filevar = binleft (filevar) ;
         /* first parameter is var parameter */
         varparam (filevar, false) ;
         IF binid (typ1) != idTEXT THEN /* add cast to text */
             p = bininsert (binfather (filevar), bincreate (cPCast)) ;
                                                /* cast Operator above & */
             binrlink (p, texttype) ;       /* to pointer to  text type */
             binexchange (p) ;
         FI

         IF  (parcount < 2)  THEN   /* add NULL as file name */
           bininsert (binright (exp), bincreate (cComma)) ;
           binappend (binright (exp), binsycreate (symins ("NULL"))) ;
         ELIF  unname (typ2) == chartype  THEN
           /* P.J. 30.03.95 Cast to char* inserted */
           char * str = (char *) malloc(1+1);  /* change char const to string const */
           if  (str==NULL)
             memerror (pos) ;
           p = binright(binright(exp));
           sprintf( str, "%c", binvalue(p));
           str[1] = 0;
           binchange(p, cScon);
           binupcharp(p, str);
         FI

         if  (binid(ut2) != idSTRING)
          begin
            /* p  == binright (exp) */        /* add Pascal file name */
            p = bininsert (binright (binright(exp)), bincreate (cComma)) ;
            p = binappend (p,  bincreate (cScon)) ;
            binupcharp (p, symtext (idsym (binid (filevar))));
            binexchange (binfather (p)) ;
          end
           /* # of parameter ok */
      break ; /* reset, rewrite */


       /*--------------------------*/
     case  cNEW :  case  cDISPOSE  :
       /*--------------------------*/
         restyp = voidtype ;             /* procedure call */
         IF parcount == 0 THEN
           illroutine(exp,atyp,not_found);
           return (strong_comp)?anytype:restyp;
         FI
         IF binsymc (unname (typ1)) != cArrow THEN
           illroutine(exp,atyp,not_found);
           IF strong_comp THEN return anytype; FI
         FI
         p = (parcount==1)?binright(exp):binleft(binright(exp)) ;
         IF parcount > 1 THEN
           IF not strong_comp THEN
             errput (171, binpos (binright (exp)), (char*)0) ;
            /* ("Further Parameters ignored.") ;*/
           ELSE
             *not_found= true;
             return anytype;
           FI
         FI
         IF not binisvariable( p ) THEN
           IF not strong_comp THEN
             errput (1602, binpos(p ), (char*)0 );
            /* "This Parameter must be a Variable.") ; */
           ELSE
             *not_found= true;
             return anytype;
           FI
         FI
         IF parcount > 1 THEN   /* delete constants: */
            typ2 = binright (binright(exp)) ;
            bintdelete (&typ2) ;              /* delete tree */
            binrlink (binright (exp), NIL) ;
            bindelete (binright (exp)) ;      /* delete Comma */
         FI

         binchange (exp, (symc == cNEW)? cNew: cDispose) ;

         IF atyp == typ1 THEN             /* arg type is named */
           binllink (exp, NIL) ;
           binlside (exp, binidcreate (binsymc (typ1), binid (typ1))) ;
           /* copies type node from PA list */
         ELSE
           binllink (exp, typ1) ;
         FI
     break ; /* new, dispose */


    /*-------------------------------------------------*/
     case cLBOUND : case cUBOUND : case cLB : case cUB :
    /*-------------------------------------------------*/

     restyp= integertype;
     /*check the number of arguments*/
     /* first argument must be static or dynamic array */
     Farg= binsymc (unname(typ1));

 IF  parcount == 0  or  parcount > 2 or
    (parcount == 2 and unname(typ2) != integertype) or
    not(Farg == cDYNAMIC or Farg == cARRAY)
 THEN
        illroutine(exp,atyp,not_found);
        return (strong_comp)?anytype:restyp;
 FI

 IF  parcount >= 2  THEN
         IF   binsymc(binright(binright(exp)))==cIcon
            or
              (idgetkind(binid(binright(binright(exp)))) == IDCONST)
         THEN
           dimension= binvalue(binright(binright(exp)));
           IF dimension < 1 THEN dim_err = 1 ; FI
         ELSE
           dim_err= 1;
         FI
         IF dim_err THEN
           IF not strong_comp THEN
             errput (1604, binpos(binleft(binright(exp))), (char*)0) ;
            /* "Dimension specif. must be an integer constant >=1" */
           ELSE
             *not_found = true;
             return anytype;
           FI
         FI
 ELSE
         dimension = 1;
 FI
       /* find the necessary dimension*/
       p= unname(typ1);
 WHILE dimension--  DO
         IF binsymc(p) != Farg THEN
           IF not strong_comp THEN
             errput (1605, binpos(binright (binright (exp))), (char*)0) ;
            /* "Dimension specification exeeds the number of dimensions" */
             dim_err = 1;
             break;
           ELSE
             *not_found = true;
             return anytype;
           FI
         FI
         IF dimension THEN p = unname(binright(p)); FI
 OD

 IF Farg == cARRAY  THEN
         IF not dim_err THEN
           restyp = binleft (p) ;
           IF symc==cLBOUND or symc==cLB THEN
             p = bound(restyp,ZLBOUND);
           ELSE
             p = bound(restyp,UBOUND);
           FI
         ELSE
           /* restyp is integertype */
           p = bincreate(cIcon);
           binupvalue(p, (long) 0);
         FI
         /*  create an integer constant node instead of function call*/
         bininsert(exp,p);
         /*delete tree*/
         p= binleft(exp);
         bintdelete( &p );
ELSE  /* Dynamic array */
         binchange( exp, cCall );
         binupsym( exp,
                   symins( (symc==cLBOUND or symc==cLB)?"y_lbnd":"y_ubnd") );

         IF not varp1 THEN
           /* function or Operator call */
           p = binright(exp);
           IF typ2 THEN p = binleft(p); FI
           IF not strong_comp THEN
             errput (1606, binpos(p), (char*)0) ;
            /* "In that context expressions are not implemented yet" */
           ELSE
             *not_found = true;
             return anytype;
           FI
         FI

         IF  parcount == 1  THEN  /* add 1 as dimension */
           varparam( binright(exp),false); /* add &*/
           bininsert ( binright(exp), bincreate (cComma)) ;
           binappend ( binright(exp), bincreate (cIcon)) ;
           binupvalue (binright (binright(exp)), (longint) 1) ;
         ELSE
           varparam(binleft(binright(exp)),false); /* add &*/
         FI
 FI

 break; /* lb, ub */

 default :      /* routine not found */
     standard = false;
     restyp= illroutine(exp,atyp,not_found);
     return restyp;
 end /* switch standard identifier */

  return (restyp) ;
END /* stdroutine */                            /*  s t d r o u t i n e  */
                                                /*-----------------------*/


                                                /*-------------*/
#ifdef LINT_ARGS
local void illop  (  binptr exp, binptr ltyp, binptr rtyp )
#else
local void illop (exp, ltyp, rtyp)              /*  i l l o p  */
  /* reports the error "Operator not declared */
  binptr exp, ltyp, rtyp ; /* see stdOperator */
#endif
BEGIN(illop)
  IF strong_comp THEN return; FI
  if    ( symprio(binsymc(exp)) == priomonop ?
          rtyp != anytype :
         (ltyp != anytype) and (rtyp != anytype) )
  then
   begin char st [1000] ;
     if  (symprio (binsymc (exp)) != priomonop) then
      begin
        strcpy (st, "s ") ;
        strcat (st, namestring (ltyp)) ;               /* left type */
        strcat (st, " ") ;
          strcat (st, namestring (exp) ) ;             /* Operator */
        strcat (st, " ") ;
        strcat (st, namestring (rtyp) ) ;              /* right type */
      end
     else               /* monadic op */
      begin
        strcpy (st, "  ") ;
          strcat (st, namestring (exp) ) ;             /* Operator */
        strcat (st, " ") ;
        strcat (st, namestring (rtyp) ) ;              /* right type */
      end

     errput (1607, binpos(exp), st) ;
   end
END /* illop */                                 /*  i l l o p  */
                                                /*-------------*/

#ifdef LINT_ARGS
local  char type_of_verg  ( binptr type, long int *arr_len)
#else
local  char type_of_verg ( type, arr_len )
  binptr type;
  long int *arr_len;
#endif
begin
  switch ( binsymc(unname(type)) )
  begin
    case cCHAR :
      return 'c' ;
    case cSTRING :
      return 's' ;
    case cSET :
      return 'e' ;
    case cScon :
                *arr_len = strlen(bincharp(type));
      return 'a';
    case cARRAY :
      IF  binsymc(binright(unname(type))) == cCHAR THEN
        /* detetmine arrays' sizes */
          *arr_len = rangesize (binleft (unname(type))) ;
                                  /* ubound*/
           /* binvalue (binright (binleft (unname(type)))) - */
                                  /* lbound*/
           /* binvalue (binleft  (binleft (unname(type)))) + 1 ; */
        return 'a' ;
      ELSE
        return '?' ;
      FI
   default :
     return '?' ;
   end
end



                                                /*-------------------------*/
                                                /*  s t d o p e r a t o r  */
#ifdef LINT_ARGS
global binptr stdOperator (binptr exp, binptr ltyp, binptr rtyp,
                           sc_type lsc, sc_type rsc)
#else
global binptr stdOperator (exp, ltyp, rtyp, lsc, rsc)
  /* handles the Operator call exp with the */
  /* operand types ltyp and rtyp as a standard Operator, */
  /* that is an undeclarable Operator and */
  /* returns the result data type or anytype, if illegal */
  binptr exp, ltyp, rtyp ;
  sc_type lsc, rsc ;    /* storage class of left resp. right operand */
#endif
BEGIN(stdOperator)
  binptr restyp = NIL;
  binptr p ;
  char left_type = '?', right_type = '?';
  long int len1 =  -1, len2 = -1;

  switch  (binsymc (exp))
  begin
      /*--------------------*/
    case     cAssign        :
      /*--------------------*/
        IF compatible (ltyp, rtyp)  THEN
          IF (binsymc (unname(ltyp)) == cFILE) or
             (binsymc (unname(rtyp)) == cFILE) THEN        /* neaga */
              errput (1608, binpos(exp), (char*)0) ;
             /* "Assignment of files is not declared." ;*/
          FI
        ELSE
          illop (exp, ltyp, rtyp) ;
          IF strong_comp THEN return anytype ; FI
        FI

        IF  (lsc != sc_var)  THEN
          errput (1205, binpos(exp), (char*)0) ;
          /* "Left side must be a variable." ;*/
        ELSE
          p = binleft(exp);
          IF id_is (binid(p), forvariable) THEN
           errput (1423, binpos(p), NULL ) ;
          FI
        FI

        restyp = ltyp ;
        /* ltyp is unnamed thereafter */
          ltyp = unname (ltyp) ;

        IF      binid(restyp) /*named type*/
             and
                id_is(binid(restyp), hasdyn) /* The type has a dyn. comp.*/
          or
                (not binid(restyp)) /*unnamed type*/
             and
                /* A simple var.: neither array nor record access*/
                (not binright(p= binright(exp)))
             and
                id_is(binid(p), hasdyn)      /* The var. has a dyn. comp.*/
        THEN
          IF binsymc(ltyp)== cDYNAMIC and
              rsc != sc_var and /* 13.05.92 */
                 not sym_is[binsymc(binright(exp))].lvalue   THEN
            tempvar = tempdecl("dy",restyp);
            bintemp(binright(exp),binsym(tempvar));
          FI
          p = bininsert(binleft(exp), bincreate(cTYPE));
          binrlink(p, restyp);
          binexchange(p);

        ELIF  binid (ltyp) == idSTRING  THEN
          if  (binid (unname(rtyp)) == idSTRING) then
           begin                                /* dyn string := dyn string */
             varparam(binleft(exp),false);
             binfunc (exp, symins ("s_asgn")) ;
           end
          else
           begin                                /* dyn string := stat string */
             varparam(binleft(exp),false);
             ins_sizeof (binright (exp), rtyp) ;
             binfunc (exp, symins ("s_asta")) ;
           end
         ELIF  binid (rtyp) == idDOTPRECISION THEN
                                            /* DOT := DOT */
              varparam(binleft(exp),false);
              binfunc (exp, symins ("d_ass")) ;

         ELIF  binid (rtyp) == idIDOTPRECISION  THEN
                                            /* IDOT := IDOT */
              varparam(binleft(exp),false);
              binfunc (exp, symins ("d_assi")) ;

         ELIF  binid (rtyp) == idCDOTPRECISION  THEN
                                            /* CDOT := CDOT */
              varparam(binleft(exp),false);
              binfunc (exp, symins ("d_assc")) ;

         ELIF  binid (rtyp) == idCIDOTPRECISION  THEN
                                            /* CIDOT := CIDOT */
              varparam(binleft(exp),false);
              binfunc (exp, symins ("d_assz")) ;

        ELIF  sym_is [binsymc (ltyp)]. arraytype THEN
          /* array type or set type assignment */
          binfunc (exp, symins ("memcpy")) ;

          ins_sizeof (binright (binright (exp)), ltyp) ;

        ELIF binsymc(ltyp)== cDYNAMIC THEN /* dynamic array assignment */
          IF  rsc != sc_var  and /* 13.05.92 */
                 not sym_is[binsymc(binright(exp))].lvalue   THEN
            tempvar = tempdecl("dy",restyp);
            bintemp(binright(exp),binsym(tempvar));
          FI
          binfunc (exp, symins ("y_asgn")) ;
          exp =  binright (exp) ;
          varparam(binleft(exp),false);
                                        /* cast Operator (y_dscp) */
          p = bininsert (binleft (exp), bincreate (cRParent)) ;
          binappend (p, binsycreate (symins("y_dscp"))) ;
          binexchange (p) ;

          varparam(binright (exp) ,false);
                                        /* cast Operator (y_dscp) */
          p = bininsert (binright (exp), bincreate (cRParent)) ;
          binappend (p, binsycreate (symins("y_dscp"))) ;
          binexchange (p) ;

        FI
    break ; /* :=  found */

      /*-----------------------------------------------*/
    case  cPlus :      case  cMinus :     case  cMult  :
      /*-----------------------------------------------*/
      IF binsymc(unname(ltyp)) == cSET and
         binsymc(unname(rtyp)) == cSET and
         compatible( binright(unname(ltyp)), binright(unname(rtyp)) )
      THEN
          static char *set_operation[3] = { "s_add" , "s_sub", "s_mul" }  ;
          restyp = ltyp;

          /* temp. var. creation*/
          tempvar = tempdecl( "se", restyp );

          /* tree transformation */
          binfunc (exp, symins ( set_operation[binsymc(exp) - cPlus] )) ;
          p  = bininsert( binright(exp), bincreate(cComma) );
          binappend( p, binsycreate(binsym(tempvar)) );
          binexchange( p );
      ELSE
        illop( exp, ltyp, rtyp );
        restyp = anytype ;
      FI
      break;
      /*----------------*/
    case     cIN        :
      /*----------------*/
        restyp = booleantype ;
        IF binsymc (unname (rtyp)) != cSET or
           binright (unname (rtyp)) != anytype  and
           not compatible ( unname(ltyp), binright (unname (rtyp)) )
        THEN
          illop (exp, ltyp, rtyp) ;
          IF strong_comp THEN return anytype ; FI
        FI
        chkscalar (ltyp, binpos (binleft(exp))) ;
        if (subtype (ltyp) != integertype)
            begin    /* add cast to integer */
              bininsert (binleft (exp), bincreate (cRParent)) ;
              binrlink (binleft (exp), integertype) ;
              binexchange (binleft(exp)) ;
            end ;
        binfunc (exp, symins ("s_etin")) ;
    break ; /* IN  found */

      /*------------------------------------------------------------*/
    case cEQ : case cNE : case cGE : case cGT : case cLE : case cLT :
      /*------------------------------------------------------------*/
        /* relational Operators are predeclared for scalar types */
        /*                                     and pointer types */
        restyp = booleantype ;

        IF sym_is [binsymc(unname(ltyp))] .scalartype and
             unname (subtype (ltyp)) == unname (subtype (rtyp))
             or
             binsymc(unname(ltyp)) == cArrow and
             compatible (ltyp, rtyp)

         THEN
           break;
         FI
            left_type = type_of_verg (ltyp,&len1) ;
            IF not (
               ( (left_type) != '?' )
                       and
               (left_type == 'e' ?
               compatible( binright(unname(ltyp)), binright(unname(rtyp)) )
               : (right_type = type_of_verg(rtyp,&len2)) != '?'
               ))
            THEN
              illop( exp, ltyp, rtyp );
              IF strong_comp THEN return anytype ; FI
            ELSE
              static char fname[7] = "s_$$##";
              static char *verg_Operator[6] =
                 {"eq","ne","ge","gt","le","lt"};
              char *s = fname + 2;

              IF left_type == 'e' THEN /* set vergleich*/
                *s++ = 'e';
                *s++ = 't';
              ELSE /* string vergleich*/
                *s++ = left_type;
                *s++ = right_type ;
              FI
              strcpy( s, verg_Operator[binsymc(exp) - cEQ]);
              binfunc (exp, symins( fname ) );

              if (len1 != -1 or len2!= -1)
                p = binright(binright (exp)) ;

              IF len1 != -1 THEN
                  p = bininsert (p, bincreate (cComma)) ;
                  binappend (p, bincreate (cIcon)) ;
                  binupvalue (binright(p),len1);
                  binexchange(p);
                  p = binright(p);
              FI
              IF len2 != -1 THEN
                  p = bininsert (p, bincreate (cComma)) ;
                  p = binappend (p, bincreate (cIcon)) ;
                  binupvalue (p,(long int)len2);
              FI

            FI
    break;
                /* illegal Operator */
    default :
        illop (exp, ltyp, rtyp) ;
        restyp = anytype ;
  end /* switch standard Operator symbol */

  return (restyp) ;
END /* stdOperator */                           /*  s t d o p e r a t o r  */
                                                /*-------------------------*/


                                                /*-----------------*/
#ifdef LINT_ARGS
global void stdinit  ( void)
#else
global void stdinit ( )                         /*  s t d i n i t  */
  /* Initializes standard identifiers  */
#endif
{ binptr st;
  idptr idp;

  /*-----------------------*/
  /*  standard data types  */
  /*-----------------------*/

  anytype   =bincreate (cTYPE) ;

  idp = idins (sNosym, IDNONE) ;
  idsetdatyp (idp, anytype) ;
  idsetbin (idp, binidcreate(cIdent, idp)) ;
  idfset (idp, nodecl) ;
  idBAD_ID = idp ;

  voidtype  =bincreate (cNIL) ; /* result type of procedure call */
/*
  notype    =binidcreate(cIdent, idins(symins("-NOTYPE-"), IDTYPE));
  priotype  =binidcreate(cIdent, idins(symins("-PRIOTYPE-")  ,IDTYPE));
*/
  idINTEGER=   idins (sINTEGER, IDTYPE);
  integertype= binidcreate (cINTEGER, idINTEGER);
  idsetbin    (idINTEGER, integertype);
  idsetdatyp  (idINTEGER, integertype);
  idsetcsym   (idINTEGER, symins("a_intg")) ;
  idfset      (idINTEGER, nodecl) ;

  idREAL=      idins (sREAL, IDTYPE);
  realtype=    binidcreate (cREAL, idREAL);
  idsetbin    (idREAL, realtype);
  idsetdatyp  (idREAL, realtype);
  idsetcsym   (idREAL, symins("a_real")) ;
  rconstype =  realtype ;
  idfset      (idREAL, nodecl) ;

  idBOOLEAN=   idins (sBOOLEAN, IDTYPE);
  booleantype= binidcreate (cBOOLEAN, idBOOLEAN);
  idsetbin    (idBOOLEAN, booleantype);
  idsetdatyp  (idBOOLEAN, booleantype);
  idsetcsym   (idBOOLEAN, symins("a_bool")) ;
  idfset      (idBOOLEAN, nodecl) ;

  idCHAR=      idins (sCHAR, IDTYPE);
  chartype=    binidcreate (cCHAR, idCHAR);
  idsetbin    (idCHAR, chartype);
  idsetdatyp  (idCHAR, chartype);
  idsetcsym   (idCHAR, symins("a_char")) ;
  idfset      (idCHAR, nodecl) ;

  idPTRCHAR=   idins (sPTRCHAR, IDTYPE);
  ptrchartype= binidcreate (cPTRCHAR, idPTRCHAR);
  idsetbin    (idPTRCHAR, ptrchartype);
  idsetdatyp  (idPTRCHAR, bincreate(cArrow));
  binappend   (iddatyp (idPTRCHAR), chartype);
  idsetcsym   (idPTRCHAR, symins("char*")) ;
  idfset      (idPTRCHAR, nodecl) ;

  idINT_OF_C=  idins (sINT_OF_C, IDTYPE);
  int_of_ctype= binidcreate (cINT_OF_C, idINT_OF_C);
  idsetbin    (idINT_OF_C, int_of_ctype);
  idsetdatyp  (idINT_OF_C, integertype);
  idsetcsym   (idINT_OF_C, symins("int")) ;
  idfset      (idINT_OF_C, nodecl) ;

  pointertype =bincreate(cArrow);       /* data type of NIL */
  binappend (pointertype, anytype) ;

  idPOINTER_OF_C=  idins (sPOINTER_OF_C, IDTYPE);
  ptr_of_ctype= binidcreate (cPOINTER_OF_C, idPOINTER_OF_C);
  idsetbin    (idPOINTER_OF_C, ptr_of_ctype);
  idsetdatyp  (idPOINTER_OF_C, pointertype);
  idsetcsym   (idPOINTER_OF_C, symins("a_VOID")) ;
  idfset      (idPOINTER_OF_C, nodecl) ;
/*
  idLITERAL=   idins (symins ("string constant"), IDTYPE);
  literaltype= bincreate (cScon);
  idsetdatyp  (idLITERAL, literaltype) ;
*/
  idSTRING=    idins (sSTRING, IDTYPE);
  stringtype=  binidcreate (cSTRING, idSTRING) ;
  idsetbin    (idSTRING, stringtype);
  idsetdatyp  (idSTRING, stringtype);
  idsetcsym   (idSTRING, symins("s_trng")) ;
  idfset      (idSTRING, dynamic) ;
  idfset      (idSTRING, nodecl) ;

  idTEXT=      idins (sTEXT, IDTYPE);
  texttype=    binidcreate(cTEXT, idTEXT);
  idsetbin    (idTEXT, texttype);
  idsetdatyp  (idTEXT, bincreate (cFILE));
  binappend   (iddatyp (idTEXT), chartype) ;     /* file of char */
  idsetcsym   (idTEXT, symins("f_text"));
  idfset      (idTEXT, nodecl) ;

  idDOTPRECISION=  idins (sDOTPRECISION, IDTYPE);
  dotprecisiontype=binidcreate (cDOTPRECISION, idDOTPRECISION);
  idsetbin        (idDOTPRECISION, dotprecisiontype);
  idsetdatyp      (idDOTPRECISION, dotprecisiontype);
  idsetcsym       (idDOTPRECISION, symins("d_otpr")) ;
  idfset          (idDOTPRECISION, dynamic) ;
  idfset          (idDOTPRECISION, nodecl) ;

  idIDOTPRECISION=  idins (sIDOTPRECISION, IDTYPE);
  idotprecisiontype=binidcreate (cIDOTPRECISION, idIDOTPRECISION);
  idsetbin        (idIDOTPRECISION, idotprecisiontype);
  idsetdatyp      (idIDOTPRECISION, bincreate (cRECORD));
  st= binsycreate (sINF);
  binappend   (iddatyp (idIDOTPRECISION), st ) ;
  st= binsycreate (sSUP);
  binappend   (binright (iddatyp (idIDOTPRECISION)), st ) ;
  binrlink (st, dotprecisiontype) ;
  binexchange (iddatyp (idIDOTPRECISION));
  idsetcsym       (idIDOTPRECISION, symins("d_otpi")) ;
  idfset          (idIDOTPRECISION, dynamic) ;
  idfset          (idIDOTPRECISION, nodecl) ;

  idCDOTPRECISION=  idins (sCDOTPRECISION, IDTYPE);
  cdotprecisiontype=binidcreate (cCDOTPRECISION, idCDOTPRECISION);
  idsetbin        (idCDOTPRECISION, cdotprecisiontype);
  idsetdatyp      (idCDOTPRECISION, bincreate (cRECORD));
  st= binsycreate (sRE);
  binappend   (iddatyp (idCDOTPRECISION), st ) ;
  st= binsycreate (sIM);
  binappend   (binright (iddatyp (idCDOTPRECISION)), st ) ;
  binrlink (st, dotprecisiontype) ;
  binexchange (iddatyp (idCDOTPRECISION));
  idsetcsym       (idCDOTPRECISION, symins("d_otpc")) ;
  idfset          (idCDOTPRECISION, dynamic) ;
  idfset          (idCDOTPRECISION, nodecl) ;

  idCIDOTPRECISION=  idins (sCIDOTPRECISION, IDTYPE);
  cidotprecisiontype=binidcreate (cCIDOTPRECISION, idCIDOTPRECISION);
  idsetbin        (idCIDOTPRECISION, cidotprecisiontype);
  idsetdatyp      (idCIDOTPRECISION, bincreate (cRECORD));
  st= binsycreate (sRE);
  binappend    (iddatyp (idCIDOTPRECISION), st ) ;
  st= binsycreate (sIM);
  binappend   (binright (iddatyp (idCIDOTPRECISION)), st ) ;
  binrlink (st, idotprecisiontype) ;
  binexchange (iddatyp (idCIDOTPRECISION)) ;
  idsetcsym       (idCIDOTPRECISION, symins("d_otpz")) ;
  idfset          (idCIDOTPRECISION, dynamic) ;
  idfset          (idCIDOTPRECISION, nodecl) ;

                                                 /* create COMPLEX type */
  idCOMPLEX=   idins (sCOMPLEX, IDTYPE) ;
  complextype= binidcreate (cCOMPLEX, idCOMPLEX);
  idsetbin    (idCOMPLEX, complextype);
  idsetdatyp  (idCOMPLEX, bincreate (cRECORD));
  st= binsycreate (sRE);
  binappend   (iddatyp (idCOMPLEX), st ) ;
  st= binsycreate (sIM);
  binappend   (binright (iddatyp (idCOMPLEX)), st ) ;
  binrlink (st, realtype) ;
  binexchange (iddatyp (idCOMPLEX)) ;
  idsetcsym   (idCOMPLEX, symins("a_cmpx")) ;
  idfset      (idCOMPLEX, nodecl) ;

                                                 /* create INTERVAL type */
  idINTERVAL=  idins (sINTERVAL, IDTYPE) ;
  intervaltype=binidcreate (cINTERVAL, idINTERVAL);
  idsetbin    (idINTERVAL, intervaltype);
  idsetdatyp  (idINTERVAL, bincreate (cRECORD));
  st= binsycreate (sINF);
  binappend   (iddatyp (idINTERVAL), st ) ;
  st= binsycreate (sSUP);
  binappend   (binright (iddatyp (idINTERVAL)), st ) ;
  binrlink (st, realtype) ;
  binexchange (iddatyp (idINTERVAL)) ;
  idsetcsym   (idINTERVAL, symins("a_intv")) ;
  idfset      (idINTERVAL, nodecl) ;

                                                 /* create CINTERVAL type */
  idCINTERVAL=  idins (sCINTERVAL, IDTYPE) ;
  cintervaltype=binidcreate (cCINTERVAL, idCINTERVAL);
  idsetbin     (idCINTERVAL, cintervaltype);
  idsetdatyp   (idCINTERVAL, bincreate (cRECORD));
  st= binsycreate (sRE);
  binappend    (iddatyp (idCINTERVAL), st ) ;
  st= binsycreate (sIM);
  binappend   (binright (iddatyp (idCINTERVAL)), st ) ;
  binrlink (st, intervaltype) ;
  binexchange (iddatyp (idCINTERVAL)) ;
  idsetcsym   (idCINTERVAL, symins("a_cinv")) ;
  idfset      (idCINTERVAL, nodecl) ;

                                                 /* create RVECTOR type */
  idRVECTOR=   idins (sRVECTOR, IDTYPE) ;
  rvectortype= binidcreate (cRVECTOR, idRVECTOR);
  idsetbin    (idRVECTOR, rvectortype);
  idsetdatyp  (idRVECTOR, bincreate (cDYNAMIC));
  binappend   (iddatyp (idRVECTOR), realtype) ;
  idsetcsym   (idRVECTOR, symins("a_rvty")) ;
  idfset      (idRVECTOR, nodecl) ;

                                                 /* create CVECTOR type */
  idCVECTOR=   idins (sCVECTOR, IDTYPE) ;
  cvectortype= binidcreate (cCVECTOR, idCVECTOR);
  idsetbin    (idCVECTOR, cvectortype);
  idsetdatyp  (idCVECTOR, bincreate (cDYNAMIC));
  binappend   (iddatyp (idCVECTOR), complextype) ;
  idsetcsym   (idCVECTOR, symins("a_cvty")) ;
  idfset      (idCVECTOR, nodecl) ;

                                                 /* create IVECTOR type */
  idIVECTOR=   idins (sIVECTOR, IDTYPE) ;
  ivectortype= binidcreate (cIVECTOR, idIVECTOR);
  idsetdatyp  (idIVECTOR, bincreate (cDYNAMIC));
  idsetbin    (idIVECTOR, ivectortype);
  binappend   (iddatyp (idIVECTOR), intervaltype) ;
  idsetcsym   (idIVECTOR, symins("a_ivty")) ;
  idfset      (idIVECTOR, nodecl) ;

                                                 /* create CIVECTOR type */
  idCIVECTOR=   idins (sCIVECTOR, IDTYPE) ;
  civectortype= binidcreate (cCIVECTOR, idCIVECTOR);
  idsetbin     (idCIVECTOR, civectortype);
  idsetdatyp   (idCIVECTOR, bincreate (cDYNAMIC));
  binappend    (iddatyp (idCIVECTOR), cintervaltype) ;
  idsetcsym    (idCIVECTOR, symins("a_civt")) ;
  idfset       (idCIVECTOR, nodecl) ;

                                                 /* create RMATRIX type */
  idRMATRIX=   idins (sRMATRIX, IDTYPE) ;
  rmatrixtype= binidcreate (cRMATRIX, idRMATRIX);
  idsetbin    (idRMATRIX, rmatrixtype);
  idsetdatyp  (idRMATRIX, bincreate (cDYNAMIC));
  binappend   (iddatyp (idRMATRIX), rvectortype) ;
  idsetcsym   (idRMATRIX, symins("a_rmty")) ;
  idfset      (idRMATRIX, nodecl) ;

                                                 /* create CMATRIX type */
  idCMATRIX=   idins (sCMATRIX, IDTYPE) ;
  cmatrixtype= binidcreate (cCMATRIX, idCMATRIX);
  idsetbin    (idCMATRIX, cmatrixtype);
  idsetdatyp  (idCMATRIX, bincreate (cDYNAMIC));
  binappend   (iddatyp (idCMATRIX), cvectortype) ;
  idsetcsym   (idCMATRIX, symins("a_cmty")) ;
  idfset      (idCMATRIX, nodecl) ;

                                                 /* create IMATRIX type */
  idIMATRIX=   idins (sIMATRIX, IDTYPE) ;
  imatrixtype= binidcreate (cIMATRIX, idIMATRIX);
  idsetbin    (idIMATRIX, imatrixtype);
  idsetdatyp  (idIMATRIX, bincreate (cDYNAMIC));
  binappend   (iddatyp (idIMATRIX), ivectortype) ;
  idsetcsym   (idIMATRIX, symins("a_imty")) ;
  idfset      (idIMATRIX, nodecl) ;

                                                 /* create CIMATRIX type */
  idCIMATRIX=   idins (sCIMATRIX, IDTYPE) ;
  cimatrixtype= binidcreate (cCIMATRIX, idCIMATRIX);
  idsetbin     (idCIMATRIX, cimatrixtype);
  idsetdatyp   (idCIMATRIX, bincreate (cDYNAMIC));
  binappend    (iddatyp (idCIMATRIX), civectortype) ;
  idsetcsym    (idCIMATRIX, symins("a_cimt")) ;
  idfset       (idCIMATRIX, nodecl) ;


#ifdef ottmann
  filetype        =binidcreate(i=idins(sFILE          ,IDTYPE));
  idsetdatyp(i,binsycreate(symins("???")));
  binchange (filetype, cFILE) ;

  settype         =binidcreate(idins(sSET                  ,IDTYPE));
  arraytype       =binidcreate(idins(sARRAY                ,IDTYPE));
  dynamictype     =binidcreate(idins(sDYNAMIC              ,IDTYPE));
  recordtype      =binidcreate(idins(sRECORD               ,IDTYPE));
#endif


   /*----------------------*/
   /*  standard constants  */
   /*----------------------*/

   idsetdatyp (idTRUE = idins (sTRUE, IDCONST), booleantype);
   st=bincreate(cBcon); binupvalue (st, (long)1);
   idsetbin   (idTRUE, st);
   idsetvalue (idTRUE, st);
   idsetcsym  (idTRUE, symins ("a_true")) ;
   idfset     (idTRUE, nodecl) ;

   idsetdatyp (idFALSE = idins (sFALSE, IDCONST), booleantype);
   st=bincreate(cBcon); binupvalue (st, (long)0);
   idsetbin   (idFALSE, st);
   idsetvalue (idFALSE, st);
   idsetcsym  (idFALSE, symins ("a_flse")) ;
   idfset     (idFALSE, nodecl) ;

/* idsetdatyp (idp = idins (sNIL, IDCONST), pointertype) ;
   st=bincreate(cIcon); binupvalue (st, (long)0);
   idsetbin   (idp, st);
   idsetvalue (idp, st);
   idsetcsym  (idp, symins ("NULL"));
*/
   idsetdatyp (idMAXINT = idins (sMAXINT, IDCONST), integertype);
   st=bincreate(cIcon); binupvalue (st, (long)LONG_MAX);
   idsetbin   (idMAXINT, st);
   idsetvalue (idMAXINT, st);
   idsetcsym  (idMAXINT, symins ("a_imax")) ;
   idfset     (idMAXINT, nodecl) ;

   /*---------------------------------*/
   /*       standard variables        */
   /*---------------------------------*/

   idINPUT = idins (sINPUT, IDVAR);
   idsetdatyp (idINPUT, texttype );
   idsetcsym  (idINPUT, symins ("f_inpu")) ;
   idfset     (idINPUT, nodecl) ;
   idOUTPUT= idins (sOUTPUT, IDVAR);
   idsetdatyp (idOUTPUT, texttype );
   idsetcsym  (idOUTPUT, symins ("f_outp")) ;
   idfset     (idOUTPUT, nodecl) ;

   /*---------------------------------*/
   /*       standard functions        */
   /*---------------------------------*/

   /* The following functions may be implemented as macros. They are not */
   /* module declared in order to avoid extern declarations. */

   idsetdatyp (idp= idins(sCHR, IDFUNCTION), chartype) ;        /* CHR */
   idsetparlist (idp, st= binidcreate (cIdlist, idINTEGER)) ;
   if ( on_index )
     idsetcsym (idp, symins ("a_chrx")) ;
   else
     idsetcsym (idp, symins ("a_chr_")) ;
   idfset     (idp, nodecl) ;

   idsetdatyp (idp= idins(sODD, IDFUNCTION), booleantype) ;     /* ODD */
   idsetparlist (idp, st) ;
   idsetcsym (idp, symins ("a_odd_")) ;
   idfset    (idp, nodecl) ;

   idp= idins(sPTRCHAR, IDFUNCTION) ;                        /* PTRCHAR */
   idsetdatyp (idp, ptrchartype) ;
   idsetparlist (idp, binidcreate (cIdlist, idSTRING)) ;
   idsetcsym (idp, symins ("s_ytos")) ;
   idfset    (idp, nodecl) ;

/* idrdconv = idins (symins ("r_cnsd"), IDFUNCTION) ;  must be deleted, if */
/* idruconv = idins (symins ("r_cnsu"), IDFUNCTION) ;  realconstantconversion */
/*                                                     may be exported. */

}                                               /*  s t d i n i t  */
                                                /*-----------------*/



                                                /*-----------------------*/
#ifdef LINT_ARGS
global binptr illroutine  (  binptr exp, binptr atyp ,boolean *not_found)
#else
global binptr illroutine (exp, atyp, not_found ) /*  i l l r o u t i n e  */
  /* returns the result voidtype or anytype  */
  binptr exp, atyp ;
  boolean *not_found;
#endif
BEGIN(illroutine)
  binptr typ1 = atyp ;             /* first parameter type */
  binptr typ2 = binright (typ1) ;  /* second parameter type */
  binptr typ3 = binright (typ2) ;  /* third parameter type */
  binptr typ4 = binright (typ3) ;  /* fourth parameter type */
  binptr restyp ;
  binptr p ;
  int errnr ;   /* error number */
  char * addstr  ; /* additional error string */
  char str [1000]; /* buffer for addstr */

  *not_found = true;

  IF strong_comp THEN return anytype ; FI

  if  (typ1  and  not sym_is [binsymc (typ1)] .identifier
             and  binsymc (typ1) != cFUNCTION
             and  binsymc (typ1) != cPROCEDURE)
    typ1 = binleft (typ1) ;    /* 1. param has unnamed data type */

  if  (typ2  and  not sym_is [binsymc (typ2)] .identifier
             and  binsymc (typ2) != cFUNCTION
             and  binsymc (typ2) != cPROCEDURE)
    typ2 = binleft (typ2) ;    /* 2. param has unnamed data type */

  if  (typ3  and  not sym_is [binsymc (typ3)] .identifier
             and  binsymc (typ3) != cFUNCTION
             and  binsymc (typ3) != cPROCEDURE)
    typ3 = binleft (typ3) ;    /* 3. param has unnamed data type */

  if  (typ4  and  not sym_is [binsymc (typ4)] .identifier
             and  binsymc (typ4) != cFUNCTION
             and  binsymc (typ4) != cPROCEDURE)
    typ4 = binleft (typ4) ;    /* 4. param has unnamed data type */



  if  (binid (exp)  and  (typ1 == anytype  or  typ2 == anytype  or
                          typ3 == anytype  or  typ4 == anytype) ) then
            /* suppress followup error */
    return  (idgetkind (binid (exp)) == IDPROCEDURE ? voidtype : anytype) ;

  IF not binid(exp)  THEN
    IF standard THEN
      errput (1610, binpos(exp), (char*)0) ;
      restyp = anytype;
     /*  "This standard routine is not defined "  */
      return anytype;
    ELSE
      errput (1213, binpos(exp), (char*)0) ;
     /*  "Identifier not declared."  */
      return anytype;
    FI

  ELIF idgetkind (binid (exp)) == IDPROCEDURE  THEN
     errnr = 1612 ;
     restyp = voidtype ;
    /*  "No Procedure name declared"  */
  ELSE
     errnr = 1610 ;
     restyp = anytype;
    /*  "No Function name declared "  */
  FI

  if  (not binright (exp))  then
     addstr = namestring (exp) ;
    /*  ("without arguments.") ; */
  else
  begin
    switch  (binsymc (exp))
     begin
       case cREAD    : errnr = 1614 ; break ;
       case cREADLN  : errnr = 1615 ; break ;
       case cWRITE   : errnr = 1616 ; break ;
       case cWRITELN : errnr = 1617 ; break ;
       default       : errnr++ ;
     end ;

    addstr = str ;
    if  (binsymc (binright (exp)) != cComma)  then
     begin                                      /* just one argument */
       strcpy (str, "  ") ;
       strcat (str, namestring (typ1)) ;
     end
    else
     begin                                              /* >= 2 args */
       strcpy (str, "s ") ;
       strcat (str, namestring (typ1)) ;
       strcat (str, ", ") ;
       strcat (str, namestring (typ2)) ;
       if  (binsymc (binright (binright (exp))) == cComma)  then
        begin                                            /* >= 3 args */
          strcat (str, ", ") ;
          strcat (str, namestring (typ3)) ;
          if  (binsymc (binright (binright (binright (exp)))) == cComma)  then
           begin
             strcat (str, ", ") ;
             strcat (str, namestring (typ4)) ;
             if  (binsymc (binright (binright (binright (binright
                  (exp))))) == cComma)  then
                strcat (str, ", ...") ;
           end
        end   /* more than 2 args */
     end   /* more than 1 arg */
  end ; /* any arguments */

  errput (errnr, binpos (exp), addstr) ;
  return restyp ;
END /* illroutine */
