{ > PasExpr2 }

{ Created by Tutu 21-Feb-86 from overflow of code out of PasExpr }


PROCEDURE FACTOR;
{
  This procedure parses a factor.
  Declared FORWARD at the start of this file.
}
VAR NEGATE : BOOLEAN;
    STKP : UW;


PROCEDURE SETSTUFF;
{
  This procedure parses a set constant. Set members which are constants are
  stored in a set and code generated to push the constant set onto TOS.
}
LABEL 13;
VAR SETONSTK : BOOLEAN;
    SETSZ : SI;
    IBYTE : UB;
    SETCONSTS : RECORD
                   CASE BOOLEAN OF
                     TRUE : (A : PACKED ARRAY[0..31] OF UB);
                     FALSE: (S : SET OF UB)
                END;
    SETDESC,
    HIGHLIMIT : SYMREC;


PROCEDURE GETMEM;
{
  This procedure parses a set member.
}
BEGIN
   RETKONST := TRUE;
   EXPRESS (SETDESC);
   X.STKINC := X.STKINC - reasize { Tutu - was 5 }
END; { getmem }


PROCEDURE ADDSET;
{
  This procedure generates code to do set union on the 2 sets on top of stack.
}
BEGIN
   IF SETONSTK THEN
   BEGIN
      FLUSHNGEN (126{Op_add_set});
      STKUP (64);
      X.STKINC := X.STKINC - 64
   END;
   SETONSTK := TRUE
END; { addset }


BEGIN { setstuff }
   NXTSYMOK;

  { Initialise set constant array to empty set ie all zeros }
   SETCONSTS.S := [];
   IBYTE := MAXSET;

   SETSZ := PRED (0);

   SETONSTK := FALSE;

   IF SYM = RBRAK THEN
   BEGIN {Set is an empty set and therefore does not have a base type}
      CODEINFO.REF := NIL;
      FLUSHNGEN (4{PushK_set}); GENUB (0)
   END
   ELSE
   BEGIN
      GETMEM;
      CODEINFO := SETDESC;
  13: IF SETDESC.IDTYP <> SUBR THEN ERROR (122);
      IF NOT EQTYPS (CODEINFO,SETDESC,FALSE) THEN ERROR (147);

      IF SYM = DDOT THEN
      BEGIN
         NXTSYMOK;
         EXPRESS (HIGHLIMIT);
         X.STKINC := X.STKINC - reasize; { Tutu - was 5 }
         IF NOT EQTYPS (SETDESC,HIGHLIMIT,FALSE) THEN
            ERROR (118);
         IF ISINT (HIGHLIMIT) THEN FLUSHNGEN (45{Set_sbr_int})
         ELSE FLUSHNGEN (43{Set_sbr_bce});
         ADDSET
      END
      ELSE
         IF (SETDESC.OBJ = KONST) AND (RETKONST) THEN
         BEGIN { Add constant to set constant }
            IBYTE := SETDESC.VAL DIV 8;
            IF (IBYTE >= MAXSET) OR (SETDESC.VAL < 0) THEN
               ERROR (124)
            ELSE
            BEGIN
               SETCONSTS.S := SETCONSTS.S + [SETDESC.VAL];
               IF IBYTE > SETSZ THEN SETSZ := IBYTE
            END
         END
         ELSE
         BEGIN
            IF ISINT (SETDESC) THEN FLUSHNGEN (44{Set_elt_int})
            ELSE FLUSHNGEN (42{Set_elt_bce});
            ADDSET
         END;

      IF ISCOMA THEN
      BEGIN
         NXTSYMOK;
         GETMEM;
         GOTO 13 { Bad programming practice but Ben made me do it }
      END;

      IF IBYTE < MAXSET THEN
      BEGIN { set included constants so output set constant }
         FLUSHNGEN (4{PushK_set});
         GENUB (SUCC (SETSZ));
         FOR IBYTE := 0 TO SETSZ DO
            GENUB (SETCONSTS.A[IBYTE]);
         ADDSET
      END
   END;

   CODEINFO.IDTYP := SETT;
   CODEINFO.OBJ := KONST;
   RETKONST := FALSE;
   CHKNEXT (RBRAK)

END; { setstuff }


PROCEDURE FUNCS (VAR CODEINFO : SYMREC);
{
  This procedure parses and generates code for standard and extension functions
}
VAR RNGCHKONSUCCANDPRED,
    INTP   : BOOLEAN;    { True if integer parameter }
    PARAMS,
    FUNKNO : UB;
    PARAMDESC : SYMREC;
    
BEGIN
   FUNKNO := CODEINFO.FUNCNO;
   NXTSYMOK;
   RNGCHKONSUCCANDPRED := FALSE;

   IF CODEINFO.OBJ = EFUNC THEN
   BEGIN
      ISOERR;

      IF ABS (241-FUNKNO) <> 8 { (FUNKNO <> 233) AND (FUNKNO <> 249)} THEN
      BEGIN { Time and Base have no args }
         PARAMS := PRED (0);
         CHK (LPAREN);
         REPEAT
            NXTSYMOK;
            PARAMS := SUCC (PARAMS);
            IF (FUNKNO = 237) AND (PARAMS = 2) THEN VARACCESS (PARAMDESC)
{ Tutu - I've taken over code1 -> fcall (addr, regs^). Above code still ok ! }
            ELSE
            BEGIN
               EXPRESS (PARAMDESC);
               IF FUNKNO <= 212 {rval} THEN
               BEGIN
                  IF PARAMDESC.IDTYP <> STRNG THEN ERROR (61)
               END
               ELSE
                  IF NOT ISINT (PARAMDESC) THEN ERROR (81)
            END
         UNTIL NOT ISCOMA;

         IF PARAMS > CODEINFO.NPARAMS THEN ERROR (60)
         ELSE IF PARAMS < CODEINFO.NPARAMS THEN ERROR (17);
         CHKNEXT (RPAREN)
      END
   END

   ELSE
      IF FUNKNO <= EOFFN THEN
         IF SYM = LPAREN THEN
         BEGIN
            NXTSYMOK;
            VARACCESS (PARAMDESC);
            IF (FUNKNO <> EOFFN) AND (PARAMDESC.REF <> CHARDESC) THEN ERROR (70);
            IF PARAMDESC.IDTYP < FYLE THEN ERROR (69);
            CHKNEXT (RPAREN)
         END
         ELSE GENMOV (LOCATE,INPTSYMP^)

      ELSE
      BEGIN
         CHKNEXT (LPAREN);
         EXPRESS (PARAMDESC);
        { INTP is used to hold boolean (is func param a integer)}
         INTP := ISINT (PARAMDESC);
        { Convert case of integer to char to save on code,
          case selector is scaled down by 142 therefore 192 = '0' }
         CASE CHR (FUNKNO-142) OF
          '0'{190odd},
          '1'{191chr}  : IF NOT INTP THEN ERROR (81);
          '2'{192ord}  : BEGIN
                            IF PARAMDESC.IDTYP <> SUBR THEN ERROR (68);
                            IF INTP THEN FUNKNO := 0
                         END;
          '3'{193succ},
          '4'{194pred} : BEGIN
                            IF PARAMDESC.IDTYP <> SUBR THEN ERROR (68);
                            CODEINFO.REF := PARAMDESC.REF;
                            FUNKNO := FUNKNO + ORD (INTP) * 2;
                            RNGCHKONSUCCANDPRED := TRUE;
                         END;
          '8'{198abs},
          '9'{199sqr}  : BEGIN
                            IF (PARAMDESC.IDTYP <> REEL)
                               AND (NOT INTP) THEN ERROR (80);
                            CODEINFO.IDTYP := PARAMDESC.IDTYP;
                            CODEINFO.REF := PARAMDESC.REF;
                            FUNKNO := FUNKNO + ORD (NOT INTP) * 3
                         END
         END {CASE}
         OTHERWISE
         BEGIN
            IF (FUNKNO < 209{sin,cos,exp,ln,sqrt,arctan}) AND INTP THEN
            BEGIN
               FLUSHNGEN (FLTROP);
               PARAMDESC.IDTYP := REEL
            END;
            IF PARAMDESC.IDTYP <> REEL THEN ERROR (79)
         END;
         CHKNEXT (RPAREN);
      END;

   IF FUNKNO <> 0 THEN FLUSHNGEN (FUNKNO);

   IF (FUNKNO = 212 {rval}) OR (FUNKNO = 211 {ival})
   THEN GENUB (LIMITS (PARAMDESC));

   IF RNGCHKONSUCCANDPRED THEN {Do range checking on succ + pred }
      RNGCHKONSUCCANDPRED := EQTYPS (PARAMDESC,PARAMDESC,TRUE)
END;


BEGIN { factor }
   NEGATE := (SYM = NOTSY);
   IF NEGATE THEN NXTSYMOK;

   CODEINFO := THISSYMP^;
   STKP := X.STKINC;

   CASE SYM OF
   KONST, NILSY :
      BEGIN
         UC;
         CODEINFO := THISSYMP^;
         IF CODEINFO.IDTYP = STRNG THEN
         BEGIN
            GENLORS (LOCILD,CODEINFO.STRLEN);
            GENSTR (SUCC (CODEINFO.STRPTR),CODEINFO.STRLEN);
            RETKONST := FALSE;
            NEXTSYM
         END
         ELSE
         BEGIN
            NEXTSYM;
            IF NOT RETKONST THEN
               GENMOV (PUSH,CODEINFO);
         END
      END;

   BOUNDID :
      BEGIN
         IF X.ACTIVLEV <> CODEINFO.LEV THEN SETLEV (CODEINFO.LEV);
         GENLORS (10{Push_ptr},CODEINFO.ADESC);
         GENLORS (41{Use_offset},CODEINFO.OFSET);
         GENMOV (IPUSH,CODEINFO);
         NXTSYMOK
      END;

   LPAREN :
      BEGIN
         NXTSYMOK;
         EXPRESS (CODEINFO);
         CHKNEXT (RPAREN)
      END;

   FUNC :
      BEGIN
         SETFUN (CODEINFO,THISSYMP^);
         PFCALL (THISSYMP);
         DEBLINE
      END;

   LBRAK : SETSTUFF;

   SFUNC, EFUNC :
      FUNCS (CODEINFO)
   END
   OTHERWISE
   BEGIN
      VARACCESS (CODEINFO);
      IF (CODEINFO.IDTYP < STRNG) AND (NOT NOCODE) THEN
         GENMOV (IPUSH,CODEINFO)
   END;

   IF NEGATE THEN
   BEGIN
      IF CODEINFO.REF <> BOOLDESC THEN ERROR (161);
      FLUSHNGEN (NOTOP)
   END;

   X.STKINC := STKP;

   STKEL := 0;
   IF CODEINFO.IDTYP < SETT
   THEN STKEL := reasize { Tutu - was 5 }
   ELSE IF CODEINFO.IDTYP = SETT THEN STKEL := 32;

   STKUP (STKEL)
END;


PROCEDURE BOOLEXP (VAR CODEINFO : SYMREC);
{
  This procedure 
}
VAR STKP : UW;

BEGIN
   STKP := X.STKINC;
   EXPRESS (CODEINFO);
   X.STKINC := STKP;
   IF BOOLDESC <> CODEINFO.REF THEN ERROR (161)
END; { boolexp }


PROCEDURE APARAMLIST;
{
  This procedure 
}
VAR ARGDESC,
    PARCOPY : SYMREC;
    ITP : TYPES;

    LASTP : SYMP;
    LASTCA,
    LASTAP : STP;

PROCEDURE GETARG (PARAM : SYMP; SYMAFTERARG : SYMBOLS);
{
  This procedure 
}
VAR CLAIM_PATCH : UW;


PROCEDURE CHKPROCPARAM (FPARAM, APARAM : SYMP);
{
  This procedure 
}
VAR PROCDESC : SYMP;
    ARGDESC,
    PARCOPY : SYMREC;
    FPLIST,
    APLIST : PARAMP;

BEGIN
   IF (APARAM^.OBJ <> PROC) AND (APARAM^.OBJ <> FUNC) THEN ERROR (53)
   ELSE
   BEGIN
      IF FPARAM^.OBJ = APARAM^.OBJ THEN
      BEGIN
         WITH APARAM^.REF^ DO
         BEGIN
            APLIST := PLIST;
            FPLIST := FPARAM^.REF^.PLIST;
            WHILE FPLIST <> NIL DO
            BEGIN
               IF (APLIST = NIL) OR (FPLIST^.No <> APLIST^.No) THEN ERROR (95);
               FPLIST := FPLIST^.NEXTNo;
               APLIST := APLIST^.NEXTNo
            END;
            IF APLIST <> NIL THEN ERROR (95);
            IF FPARAM^.REF^.FUNCREF <> FUNCREF THEN ERROR (49);
            PROCDESC := LASTPARAM
         END;
         FPARAM := FPARAM^.REF^.LASTPARAM;

         WHILE FPARAM <> NIL DO
         BEGIN
            PARCOPY := FPARAM^;
            ARGDESC := PROCDESC^;
         { If fparam = procedural param }
            IF PARCOPY.OBJ >= PROC THEN CHKPROCPARAM (FPARAM,PROCDESC)
            ELSE
               IF (PARCOPY.IDTYP = CARAY) THEN
               BEGIN { Check that conformant array specs are the same }
                  REPEAT
                    { Check that index types match and both are VARS or not }
                     IF (PARCOPY.REF^.IREF <> ARGDESC.REF^.IREF)
                     OR ((PARCOPY.REF^.ALEV>127) <> (ARGDESC.REF^.ALEV>127))
                     OR (ARGDESC.IDTYP <> CARAY) THEN ERROR (90);

                     PARCOPY.IDTYP := PARCOPY.REF^.TYP;
                     PARCOPY.REF := PARCOPY.REF^.ELREF;

                     ARGDESC.IDTYP := ARGDESC.REF^.TYP;
                     ARGDESC.REF := ARGDESC.REF^.ELREF

                  UNTIL PARCOPY.IDTYP <> CARAY;
                  IF ARGDESC.REF <> PARCOPY.REF THEN ERROR (90)
               END
               ELSE
                  IF (PARCOPY.REF <> ARGDESC.REF)
                  OR (PARCOPY.NRM <> ARGDESC.NRM) THEN ERROR (90);
            FPARAM := FPARAM^.LINK;
            PROCDESC := PROCDESC^.LINK;
            IF (FPARAM <> NIL) AND (PROCDESC = NIL) THEN ERROR (90)
         END; { while }

         IF FPARAM <> PROCDESC THEN ERROR (90)
      END
      ELSE ERROR (50)
   END
END; { chkprocparam }


BEGIN { getarg }
   IF PARAM^.LINK <> NIL THEN GETARG (PARAM^.LINK,COMMA);

   PARCOPY := PARAM^;

   IF PARCOPY.OBJ <> BOUNDID THEN
   BEGIN
      IF PARCOPY.OBJ >= PROC THEN
      BEGIN  { Procedural / functional parameter }
         CHKPROCPARAM (PARAM,THISSYMP);
         IF THISSYMP^.NRM THEN
         BEGIN
{ Tutu - was GENOPWTB (1,THISSYMP^.ADR); { Push_k_ptr }
            flushngen (2);
            gensi (thissymp^.adr); { Tutu - pshK_int proc.no }
            GENUB (67) { Push Display }
         END

         ELSE
         BEGIN
            IF X.ACTIVLEV <> THISSYMP^.LEV THEN SETLEV (THISSYMP^.LEV);
            GENLORS (16, THISSYMP^.ADR); { Locate proc adr and display }
            GENUB (31);                  { Push I blk Short }
            GENUB (dspNprocsize)         { Tutu - was block size = 18 }
         END;

         STKUP (dspNprocsize); { Tutu - was 18 }
         NEXTSYM
      END

      ELSE
      BEGIN
         IF PARCOPY.IDTYP = CARAY THEN
         BEGIN
            IF PARCOPY.NRM THEN
            BEGIN { Value param conformant array }
              { Make a copy of the array on the heap }
               writeln ('Value parm conformant array used !'); { Tutu }
               GENOPWTB (1,stracc); {Push pointer stracc onto stack}
               GENOPWTB (&DC,0); {Claim block from heap using long form of NEW
                                 address of block claimed goes into stracc}
               CLAIM_PATCH := X.LASTADR;

              { Get address of block claimed onto TOS }
               GENOPWTB (1,stracc); {Push pointer stracc onto stack}
               GENUB (&19); { PshI_ptr }

              { Get address of block claimed onto TOS }
               GENOPWTB (1,stracc); {Push pointer stracc onto stack}
               GENUB (&19); { PshI_ptr }

               EXPRESS (ARGDESC);
               IF ARGDESC.OBJ = KONST THEN
               BEGIN
                  STORPATCH (CLAIM_PATCH,ARGDESC.STRLEN);
                  GENLORS (40{PshI_blk_s},ARGDESC.STRLEN);
                  GENSI (&10B07{Locate_ild,0B,01,00});
                  GENUB (4); GENSI (1);
                  GENSI (ARGDESC.STRLEN);
                  GENOPWTB (1,ARGDESC.STRLEN) {Push size of array onto stack}
               END
               ELSE
               BEGIN
                  STORPATCH (CLAIM_PATCH,ARGDESC.REF^.VARSIZ);
                  GENLORS (40{PshI_blk_s},ARGDESC.REF^.VARSIZ);
                  IF X.ACTIVLEV <> (ADESCREF^.ALEV MOD 128) THEN
                     SETLEV (ADESCREF^.ALEV MOD 128);
                  GENLORS (16{Locate_var},ADESCREF^.ADESCOFF+ADESC);
                  GENOPWTB (1,ARGDESC.REF^.VARSIZ) {Push array size onto stack}
               END;
               IF ARGDESC.IDTYP = CARAY THEN ERROR (46);
               STKUP (ptrsize) { Tutu - was 2 }
            END

            ELSE { Var param conformant array }
            BEGIN
               VARACCESS (ARGDESC);
               if (not (simple or ext)) and argdesc.funcass then error (170);
{ Tutu - Filthy fudge for 6.6.3.7.3 - can't pass a component of a packed
  structure to a var conformant array - apart from if you set $X+ !!! }
               FLUSH;
               IF X.ACTIVLEV <> (ADESCREF^.ALEV MOD 128) THEN
                  SETLEV (ADESCREF^.ALEV MOD 128);
               IF ARGDESC.IDTYP = CARAY THEN
               BEGIN
                  GENLORS (10{Push_ptr},ADESCREF^.ADESCOFF{OPTYPVAL});
                  GENLORS (41{Use_offset},ADESC)
               END
               ELSE
                  GENLORS (16{Locate_var},ADESCREF^.ADESCOFF+ADESC);
            END;

            STKUP (twiceptrsize); { Tutu - was 4 }
           { Type check the conformant array }

            IF (PARCOPY.REF = LASTCA) AND
               ((ARGDESC.REF <> LASTAP) OR (ARGDESC.OBJ = KONST)) THEN
               ERROR (76); { Variable type is not the same as the last param }
            LASTCA := PARCOPY.REF;
            LASTAP := ARGDESC.REF;

            REPEAT
               IF (ARGDESC.IDTYP < STRNG) OR (ARGDESC.IDTYP > ARAY) THEN
                  ERROR (151);
              { Check that indicies match }
               IF ARGDESC.OBJ = KONST THEN ITP := INT
               ELSE ITP := ARGDESC.REF^.IREF^.TYP;

               WITH PARCOPY.REF^.IREF^ DO
               BEGIN
                  IF ((HIGH < LIMITS (ARGDESC)) OR (LOW > LLIM)) AND
                     (ARGDESC.IDTYP <> CARAY) THEN ERROR (108);
                  IF TYP <> ITP THEN ERROR (160)
               END;

               IF ARGDESC.PAK <> PARCOPY.PAK THEN ERROR (23);

               IF ARGDESC.OBJ = KONST THEN
               BEGIN
                  ARGDESC.IDTYP := SUBR;
                  ARGDESC.OBJ := VARID
               END
               ELSE
               BEGIN
                  ARGDESC.IDTYP := ARGDESC.REF^.TYP;
                  ARGDESC.PAK := ARGDESC.REF^.ALEV > 127;
                  ARGDESC.REF := ARGDESC.REF^.ELREF
               END;

               PARCOPY.IDTYP := PARCOPY.REF^.TYP;
               PARCOPY.PAK := PARCOPY.REF^.ALEV > 127;
               PARCOPY.REF := PARCOPY.REF^.ELREF

            UNTIL PARCOPY.IDTYP <> CARAY;
            IF PARCOPY.REF <> ARGDESC.REF THEN ERROR (90)
         END

         ELSE
         BEGIN
            IF PARCOPY.NRM THEN
            BEGIN  { Value parameter }
               EXPRESS (ARGDESC);
               IF ARGDESC.IDTYP >= STRNG THEN
               BEGIN
                  IF ARGDESC.IDTYP <> REKORD
                  THEN STKUP (LIMITS (ARGDESC))
                  ELSE STKUP (ARGDESC.REF^.VARSIZ);
                  IF ARGDESC.OBJ = KONST
                  THEN GENLORS (31{I_PUSH_BLK},ARGDESC.STRLEN)
                  ELSE GENMOV (IPUSH,ARGDESC)
               END;
               IF NOT EQTYPS (PARCOPY,ARGDESC,TRUE) THEN ERROR (90)
            END

            ELSE
            BEGIN  { Var parameter }
               VARP := TRUE;
               VARACCESS (ARGDESC);
               STKUP (ptrsize); { Tutu - was 2 }
               VARP := FALSE;
               IF (ARGDESC.PERM) AND (ARGDESC.IDTYP = SUBR) THEN ERROR (55);
               IF ARGDESC.OBJ = BOUNDID THEN ERROR (48);
               IF (ARGDESC.PAK) AND (NOT PARCOPY.PAK)
               AND (ARGDESC.IDTYP < STRNG)
               THEN
                  IF EXT THEN
                  BEGIN
                     IF ISINT (ARGDESC) THEN ERROR (18)
                  END
                  ELSE ERROR (18);
               IF ARGDESC.REF <> PARCOPY.REF THEN ERROR (90);
               IF ARGDESC.OBJ = TAG THEN ERROR (101);
               IF NOT EQTYPS (PARCOPY,ARGDESC,FALSE) THEN ERROR (90)
            END
         END
      END;

      CHKNEXT (SYMAFTERARG)
   END
END; { getarg }


BEGIN { aparamlist }
   NXTSYMOK;

   IF SYM = LPAREN THEN
   BEGIN
      NXTSYMOK;
      IF LASTPARAM = NIL THEN ERROR (91) {Should have no args}
      ELSE
      BEGIN
         LASTP := LASTPARAM;
         WHILE LASTP^.OBJ = BOUNDID DO LASTP := LASTP^.LINK;
         LASTCA := NIL;
         LASTAP := NIL;
         GETARG (LASTP,RPAREN)
      END
   END

   ELSE
   BEGIN
      IF LASTPARAM <> NIL THEN ERROR (17) { Missing args }
   END
END; { aparamlist }


{$S'PasStmt'}