{ > PasMain }

{ Tutu 19 feb 86 - bce repacked, with re-align after declaration end }
{ Tutu 17 feb 86 - brought into line with 1.06/7 bug fixes with packing }
{ Tutu 11 feb 86 - totaldescsize made manifest constant, array acc. changed.
                    also A4 type (&FF) identification byte added on code }
{ Tutu 30 jan 86 - fcbsize made manifest constant }
{ Tutu 16 dec 85 - altered version for ARMulation ! }

{ Sam altered version number 15 Nov 85 to 1.04 }

{ Tutu 08 nov 85 - got a CMOS front end : D1.03 etc. }

{ Tutu XX oct 85 - Changed pshK_ptr 0000 to pshK_nil : D1.02 }
{ And flush the keyboard buffer if we had any errors }


procedure align (var thing : si); { Tutu - align stack frame / vbl offsets }
var dif : integer;
begin
  dif := thing MOD 4;
  if dif <> 0 then thing := thing - dif + 4
end; { align }


FUNCTION BADSCOPE : BOOLEAN;
BEGIN
   BADSCOPE := (X.USED_AT_LEV = X.LEVEL) AND (X.USED_IN_PROC = X.THISPROCNO)
END;


PROCEDURE GETTYP (VAR TP          : TYPES;
                  VAR RF          : STP;
                  VAR SZ, ARECSIZ : SI;
                  VAR ELEMPAC     : BOOLEAN;
                      PAC, ARAYEL : BOOLEAN); FORWARD;


PROCEDURE VARLIST (VAR NoINLIST         : UB;
                       VARPARM, ISPARAM : BOOLEAN;
                       IDTIPE           : SYMBOLS;
                   VAR OFFSET, ARECSIZ  : SI;
                       PAC              : BOOLEAN;
                   VAR HASFILE          : BOOLEAN);
VAR TP : TYPES;
    RF : STP;
    SZ : SI;
    ID1, ID2 : SYMP;
    IDCOUNT : UW;
    HASFYLE, ELEMPAC : BOOLEAN;


PROCEDURE FUJENT;
{ IF THE VARIABLE NAME IS A PROGRAM PARAMETER THEN IT MUST BE MOVED FROM IT'S
  CURRENT POSITION IN THE LINKED LIST SYMBOL TABLE, TO A POSITION INSIDE THE
  SEQUENTIAL LINKED LIST OF THE ID LIST
}
BEGIN
   IF (SYM = VARID) AND (X.LEVEL <> 1)
   THEN ERROR (143) {PROGPARAMS ARE GLOBAL}

   ELSE IF (THISSYMP^.IDTYP = FYLE) AND (THISSYMP^.ADR = -3)
   THEN
   BEGIN
      IF THISSYMP <> LASTSYMP THEN
      BEGIN
         THISSYMP^.ADR := -4;
         NEXTSYMP^.LINK := THISSYMP^.LINK;
         IF THISSYMP = ID1 THEN ID1 := THISSYMP^.LINK;
         THISSYMP^.LINK := LASTSYMP;
         LASTSYMP := THISSYMP;
         DISPLAY[1]^.LASTSYM := LASTSYMP
      END
   END

   ELSE
   BEGIN
      IF (SYM <> NEWID) OR (THISSYMP^.OBJ = VARID) THEN ERROR (62);
     { Check that an id with the same spelling as the new id has not
       been used at the current level }
      IF BADSCOPE AND (SYM = NEWID) THEN ERROR (104)
   END;

   LASTSYMP^.OBJ := IDTIPE;
   LASTSYMP^.NRM := NOT VARPARM;
   NEXTSYM
END; { fujent }


BEGIN { varlist }
   ID1 := NIL;
   FUJENT;
   ID1 := LASTSYMP^.LINK;

   IDCOUNT := 1; { Loop over identically typed variables }
   WHILE ISCOMA DO
   BEGIN  { GET ANY MORE IDS IN ID LIST }
      NXTSYMOK;
      IDCOUNT := SUCC (IDCOUNT);
      FUJENT
   END;

   ISDEC := FALSE;
   ID2 := LASTSYMP; {SAVE LAST ID IN ID LIST}

   CHKNEXT (COLON);
   IF ISPARAM AND (SYM <> TIPE) THEN ERROR (115);

   GETTYP (TP, RF, SZ, ARECSIZ, ELEMPAC, PAC, FALSE); {Type not array element}

   HASFYLE := CONTAINSFILE (TP, RF^, TRUE);
   IF HASFYLE THEN HASFILE := TRUE;

   IF VARPARM THEN SZ := ptrsize { Tutu - was 2 }
   ELSE
      IF ISPARAM AND HASFYLE THEN ERROR (158);

   NoINLIST := IDCOUNT;
   OFFSET := OFFSET + IDCOUNT * SZ;
   IDCOUNT := OFFSET;
  { Assign ids in list to correct type }
   REPEAT
      ID2^.IDTYP := TP;
      ID2^.REF   := RF;
      IDCOUNT    := IDCOUNT - SZ;
      ID2^.ADR   := IDCOUNT;
      ID2^.PAK   := ELEMPAC;
      ID2        := ID2^.LINK
   UNTIL (ID2 = ID1) OR FUCKUP
END; { varlist }


FUNCTION CHKTYP (VAR RF : STP; VAR SZ : SI; PAC : BOOLEAN) : TYPES;
VAR LEVELCOPY : SI;

BEGIN { chktyp }
   LEVELCOPY := X.LEVEL;

   WHILE THISSYMP^.IDTYP = NOTYP DO
   BEGIN
      LEVELCOPY := PRED (LEVELCOPY);
      X.DEPTH := LEVELCOPY;
      LOOKUPID;
      IF THISSYMP = NIL THEN ERROR (115)
      ELSE IF THISSYMP^.OBJ <> TIPE THEN ERROR (115)
   END;

   RF := THISSYMP^.REF;
   SZ := THISSYMP^.ADR;
   IF PAC AND (THISSYMP^.IDTYP = SUBR) THEN SZ := BYTES (RF^.LOW, RF^.HIGH);
   CHKTYP := THISSYMP^.IDTYP;
END; { chktyp }


PROCEDURE CHKSZ (VAR SIZE : SI);
BEGIN
   IF SIZE >= MAXUW THEN { Tutu - to be maxmadr eventually }
   BEGIN
      SIZE := 1;
      ERROR (26) { Type too big for memory }
   END
END; { chksz }


PROCEDURE ORDTYP (VAR RF  : STP; VAR SZE : SI; PAC : BOOLEAN);
LABEL 13;

VAR COUNT : UW;
    THISLEV : UB;
    TP1 : TYPES;
    RF1 : STP;

BEGIN { ordtyp }
   IF SYM = TIPE THEN
   BEGIN
      IF CHKTYP (RF, SZE, PAC) <> SUBR THEN ERROR (120); {ORD TYPE EXPECTED}
      NXTSYMOK
   END

   ELSE {NUORDTYP}
   BEGIN
      NEW (RF1, SUBR);
      RF1^.SUBRSIZ := 1;
      SUBRP := RF1;
      IF SYM <> LPAREN THEN ORDCON;
      IF SYM = KONST THEN
      BEGIN
         RF1^.LOW := THISSYMP^.VAL;
         SUBRP^.SUBRREF := THISSYMP^.REF^.SUBRREF;
         TP1 := THISSYMP^.REF^.TYP;
         RF1^.TYP := TP1;
         NEXTSYM;
         CHKNEXT (DDOT);
         ORDCON;
         IF (TP1 <> THISSYMP^.REF^.TYP) OR
            (THISSYMP^.REF^.SUBRREF <> SUBRP^.SUBRREF) THEN ERROR (118);
         SUBRP^.HIGH := THISSYMP^.VAL;
         IF THISSYMP^.VAL < SUBRP^.LOW THEN ERROR (119);
         NEXTSYM;
         IF TP1 = INT THEN RF1^.SUBRSIZ := 4
      END

      ELSE
      BEGIN
         THISLEV := X.LEVEL;
         X.LEVEL := X.PROCLEV;
         ISDEC := TRUE;
         IF SYM <> LPAREN THEN ERROR (120); {ORDINAL TYPE EXPECTED}
         NEXTSYM;
         COUNT := 0;

         13:CHK (NEWID);
           { Check that an id with the same spelling as the new id has not
             been used at the current level }
            IF BADSCOPE THEN ERROR (104);
            SETSUBRTYP (THISSYMP^, SUBRP);
            THISSYMP^.VAL := COUNT;
            COUNT := SUCC (COUNT);
            NEXTSYM;
            IF ISCOMA THEN
            BEGIN
               NEXTSYM;
               GOTO 13
            END;

         X.LEVEL := THISLEV;
         ISDEC := FALSE;
         CHKNEXT (RPAREN);
         RF1^.LOW := 0;
         RF1^.TYP := ENUM;
         RF1^.SUBRREF := RF1;
         RF1^.HIGH := PRED (COUNT)
      END;
      SZE := RF1^.SUBRSIZ;
      IF PAC THEN SZE := BYTES (RF1^.LOW, RF1^.HIGH);
      RF := RF1
   END;  {OF NUORDTYP}

   CHKSZ (SZE)
END; { ordtyp }


PROCEDURE GETTYP; {ALREADY DECLARED BEFORE IDLIST}
VAR THISLEV : SI;
    TP1 : TYPES;
    RF1 : STP;
    SZ1 : SI;
    COULDBESTR,
    LOCALELEMPAC : BOOLEAN;
    THISCOPY : SYMP;


PROCEDURE ARAYTYP (VAR RF : STP; VAR SZE, ARECSIZ : SI; PAC, ARAYEL : BOOLEAN);
VAR TP : TYPES;
    RF1, ELRF, AP : STP;
    TEMP, ELSIZ : SI;
    DESCSIZ : UW;
    ELEMPAC : BOOLEAN;

BEGIN { araytyp }
   ORDTYP (RF1, SZE, TRUE);
   NEW (AP, ARAY, ARAY, ARAY); { CREATE NEW ARRAY RECORD }
   AP^.IREF := RF1;

   IF ISCOMA THEN
   BEGIN
      NXTSYMOK;
      ELEMPAC := PAC;
      ARAYTYP (ELRF, ELSIZ, ARECSIZ, PAC, TRUE);
      TP := ARAY;
      IF COULDBESTR THEN TP := STRNG
   END
   ELSE
   BEGIN
      CHKNEXT (RBRAK);
      CHKNEXT (OFSY);
      GETTYP (TP, ELRF, ELSIZ, ARECSIZ, ELEMPAC, PAC, TRUE)
   END;                                             {Type is element of array}

   TEMP := SUCC (RF1^.HIGH - RF1^.LOW);

   COULDBESTR := PAC AND (RF1^.LOW = 1) AND (ELRF = CHARDESC)
                 AND (RF1^.TYP = INT) AND (TEMP > 1);
{ Tutu - Strings are packed array [1..n] of char only }

   AP^.ELSIZE := ELSIZ;
   AP^.ELREF  := ELRF;
   AP^.TYP    := TP;
   CHKSZ (TEMP);
   SZE := TEMP * ELSIZ;
   CHKSZ (SZE);
   AP^.VARSIZ := SZE;
   RF1 := AP;

   IF NOT ARAYEL THEN
   BEGIN
{ Create array descriptor + plant code to load it onto the stack at run time }
      GENLORS (LOCATE, ARECSIZ);   { Locate current lev array descriptor adr }
      GENOPWTB (LOCILD+42{long version}, 0);
      DESCSIZ := 0;

      TP := ARAY;
      WHILE (TP = ARAY) OR (TP = STRNG) DO
      BEGIN
         GENUW (AP^.ELSIZE); genuw (0); { Tutu - need to pad out on beeb }
{ Tutu - was : (index type byte not needed for ARM)
         IF AP^.IREF^.SUBRSIZ = 1 THEN GENUB (1) ELSE GENUB (4);
}
         GENSI (AP^.IREF^.LOW);
         GENSI (AP^.IREF^.HIGH);
         DESCSIZ := DESCSIZ + totaldescsize; { Tutu - was 11 }
         TP := AP^.TYP;
         AP := AP^.ELREF
      END;

      STORPATCH (X.LASTADR, DESCSIZ);
      GENLORS (40{popI_blk}, DESCSIZ);
      RF1^.ADESCOFF := ARECSIZ;
      ARECSIZ := ARECSIZ + DESCSIZ { Descsize must be multiple of 4 }
   END;
   RF := RF1;
   RF1^.ALEV := (ORD (ELEMPAC) * 128) + X.PROCLEV
END; { araytyp }


PROCEDURE FIELDLIST (VAR OFFSET, ARECSIZ : SI;
                     VAR VARIENTS1       : VARIANTP;
                         PAC             : BOOLEAN);
LABEL 13;

VAR TP : TYPES;
    RF1 : STP;
    SAVELASTNAME, No_CONSTS : UW;
    SZ : SI;
    DINGO, SEMI : BOOLEAN;
    ID1 : SYMP;
    MAXVARIANT : SI;
    VARIENTS2, LASTVARIANT, NESTEDV : VARIANTP;
    CLIST, CLIST2, NEXTCONST : CONSTSP;
    PIGS_WILL_FLY : UB;

BEGIN { fieldlist }
   SEMI := TRUE;
   ISDEC := TRUE;

   align (offset); align (arecsiz); { Tutu paranoia }

   WHILE (SYM = NEWID) OR (SYM = VARID) DO
   BEGIN
      IF NOT SEMI THEN ERROR (19);
      VARLIST (PIGS_WILL_FLY, FALSE{not var param}, FALSE{not param},
                                         FIELD, OFFSET, ARECSIZ, PAC, DINGO);
      ISDEC := TRUE;
      SEMI := ISSEMI;
      IF SEMI THEN NXTSYMOK;

      align (offset); align (arecsiz); { Tutu paranoia }
   END;

   IF SYM = CASEY THEN
   BEGIN  {VARIANT PART}
      IF NOT SEMI THEN ERROR (19);
      SEMI := FALSE;
      ISDEC := FALSE;
     { START OF VARIANT SELECTOR }
      NXTSYMOK;
      SAVESYM := SYM;
      ID1 := THISSYMP;
      NEXTSYM;
      IF SYM = COLON THEN
      BEGIN  {TAG-FIELD PRESENT}
         IF SAVESYM > NEWID THEN
         BEGIN  {MUST INSERT ID INTO SYMBOL TABLE AS NEW ID}
            NAMES.TADR := Y.LASTNAME;
            ENTERID (TAG, NOTYP);
            THISSYMP^.NAMLINK := ID1^.NAMLINK;
            ID1 := THISSYMP
         END
         ELSE
           IF SAVESYM = NEWID THEN ID1^.OBJ := TAG ELSE ERROR (62); {ID EXPECT}

         NEXTSYM;
         IF SYM <> TIPE THEN ERROR (120); {ORD TYPE EXPECTED}
         ORDTYP (RF1, SZ, PAC);
         ID1^.IDTYP := SUBR;
         ID1^.REF := RF1;
         ID1^.ADR := OFFSET;
         ID1^.PAK := PAC;
         OFFSET := OFFSET + SZ
      END

      ELSE
      BEGIN  {NO TAG-FIELD PRESENT, SHOULD BE TAG-TYPE}
         IF SAVESYM <> TIPE THEN ERROR (135);
         THISSYMP := ID1;
         SAVELASTNAME := Y.LASTNAME;
         Y.LASTNAME := THISSYMP^.NAMLINK;
         IF CHKTYP (RF1, SZ, PAC) <> SUBR THEN ERROR (120); {ORDINAL TYPE EXP}
         ID1 := THISSYMP;
         Y.LASTNAME := SAVELASTNAME
      END;

     { END OF VARIANT SELECTOR }

      CHK (OFSY); { START OF VARIANT }

      MAXVARIANT := OFFSET;
      LASTVARIANT := NIL;
      No_CONSTS := 0;
      REPEAT
         NEW (VARIENTS2);
         VARIENTS2^.LASTV := LASTVARIANT;
        { Create pointer to new list of constants }
         NEW (CLIST);
         VARIENTS2^.CONSTLIST := CLIST;
         CLIST^.NEXTC := NIL;

         13:IF NOT SEMI THEN NEXTSYM;
            SEMI := FALSE;
            ORDCON;
            No_CONSTS := SUCC (No_CONSTS);
            IF NOT EQTYPS (ID1^, THISSYMP^, FALSE) OR
               (LIMITS (ID1^) < THISSYMP^.VAL) OR (LLIM > THISSYMP^.VAL) THEN
               ERROR (141);
{
            IF (RF1^.TYP <> THISSYMP^.REF^.TYP) OR
               (RF1^.SUBRREF <> THISSYMP^.REF^.SUBRREF) OR
               (THISSYMP^.VAL > RF1^.HIGH) OR
               (THISSYMP^.VAL < RF1^.LOW) THEN ERROR (141);
}
            IF THISSYMP = BASESYMP THEN
            BEGIN { Case constant is only a temporary constant ie has not been
                   previously declared, so create a symbol table entry for it}
               NEW (LASTSYMP);
               LASTSYMP^ := THISSYMP^;
               THISSYMP := LASTSYMP
            END;

            NESTEDV := VARIENTS2;
            WHILE NESTEDV <> NIL DO
            BEGIN
               CLIST2 := NESTEDV^.CONSTLIST;
               WHILE CLIST2^.NEXTC <> NIL DO
               BEGIN
                  IF CLIST2^.CONS^.VAL = THISSYMP^.VAL THEN ERROR (71);
                  CLIST2 := CLIST2^.NEXTC
               END;
               NESTEDV := NESTEDV^.LASTV
            END;

            CLIST^.CONS := THISSYMP;
            NEXTSYM;
            IF ISCOMA THEN
            BEGIN
               NEW (NEXTCONST);
               CLIST^.NEXTC := NEXTCONST;
               CLIST := NEXTCONST;
               CLIST^.NEXTC := NIL;
               GOTO 13;
            END;

         CHKNEXT (COLON);
         ISDEC := TRUE;
         CHKNEXT (LPAREN);
         SZ := OFFSET;
         FIELDLIST (SZ, ARECSIZ, NESTEDV, PAC);

         VARIENTS2^.NESTEDV := NESTEDV;
         VARIENTS2^.MAXSIZE := SZ;
         LASTVARIANT := VARIENTS2;

         CHKNEXT (RPAREN);
         IF SZ > MAXVARIANT THEN MAXVARIANT := SZ;

         ISDEC := FALSE;
         SEMI := ISSEMI;
         IF SEMI THEN NXTSYMOK
      UNTIL NOT (SEMI AND ((SYM = KONST) OR (SYM IN [PLUS, MINUS])));

      OFFSET := MAXVARIANT;
      IF SUCC (RF1^.HIGH - RF1^.LOW) <> No_CONSTS THEN ERROR (100)

   END  { OF VARIANT-PART }
   ELSE VARIENTS2 := NIL;
   VARIENTS1 := VARIENTS2;

   IF ISSEMI THEN IF SEMI THEN ERROR (35) ELSE NXTSYMOK {END EXPECTED}
END; { fieldlist }


{PROCEDURE GETTYP (VAR TP          : TYPES;
                   VAR RF          : STP;
                   VAR SZ, ARECSIZ : SI;
                   VAR ELEMPAC     : BOOLEAN;
                       PAC, ARAYEL : BOOLEAN); FORWARD;}
BEGIN { gettyp }
   ELEMPAC := PAC;

   IF SYM IN [ARRAYSY, FILESY, RECORDSY, SETSY, PACKSY] THEN
   BEGIN { Type is structured, possibly packed }
      PAC := (SYM = PACKSY);

      elempac := pac; { Tutu - fixes 6.4.3.1 bug == D1.06 }
                      { Tutu - was ELEMPAC := PAC OR ELEMPAC; }

      IF PAC THEN NXTSYMOK; { skip 'packed' }

      IF SYM = SETSY THEN
      BEGIN
         TP1 := SETT;
         NXTSYMOK;
         CHKNEXT (OFSY);
         ORDTYP (RF1, SZ1, FALSE);
         SZ1 := MAXSET;
         if (rf1^.low < 0) or (rf1^.high > 255) then error (28) { Tutu }
{ Tutu - was
         IF BYTES (RF1^.LOW, RF1^.HIGH) > 1 THEN ERROR (28)
  Isolates against packing changing definition of BYTES
}
      END

      ELSE IF SYM = FILESY THEN
      BEGIN
         NXTSYMOK;
         CHKNEXT (OFSY);
         NEW (RF1, FYLE);
         align (sz1); { Tutu }
         GETTYP (RF1^.TYP, RF1^.FILEREF, SZ1, ARECSIZ, RF1^.FILEPAC, PAC,
                                                      FALSE{not aray element});
         RF1^.FILESIZ := SZ1;
         SZ1 := SZ1 + fcbsize; { Tutu - was 5 : POINTER AND FLAGS FOR FCB }
         align (sz1); { Tutu }
         IF CONTAINSFILE (FYLE, RF1^, FALSE) THEN ERROR (123);
                                               {NO FILES OF FILES}
         TP1 := FYLE
      END

      ELSE IF SYM = ARRAYSY THEN
      BEGIN
         NXTSYMOK;
         CHKNEXT (LBRAK);
         ARAYTYP (RF1, SZ1, ARECSIZ, PAC, ARAYEL);
         TP1 := ARAY;
         IF COULDBESTR THEN TP1 := STRNG
      END

      ELSE IF SYM = RECORDSY THEN
      BEGIN
         IF X.LEVEL = MAXLEV THEN ERROR (166);
         X.LEVEL := SUCC (X.LEVEL);
         NEW (RF1, REKORD, REKORD, REKORD);
         DISPLAY[X.LEVEL] := RF1;
         RF1^.TYP := REKORD;
         RF1^.LASTSYM := NIL;
         SZ1 := 0; {SET OFFSET ADDRESS IN RECORD TO 0}
         ISDEC := TRUE;
         NXTSYMOK;
         FIELDLIST (SZ1, ARECSIZ, RF1^.VARIANTS, PAC);
         RF1^.VARSIZ := SZ1;
         X.LEVEL := PRED (X.LEVEL);
         LASTSYMP := DISPLAY[X.LEVEL]^.LASTSYM;
         CHKNEXT (ENDSY);
         TP1 := REKORD
      END

      ELSE ERROR (134) { Can't pack an unstructured type }
   END { of checking for structured types }

   ELSE
      IF SYM = TIPE THEN { already known type }
      BEGIN
         TP1 := CHKTYP (RF1, SZ1, PAC);
         if thissymp^.idtyp > pntr then elempac := thissymp^.pak; { Tutu }
{ Tutu - 6.4.3.1 bug again : thissymp^ only packed if structured }
{ Tutu - was ELEMPAC := ELEMPAC OR THISSYMP^.PAK; }

         NXTSYMOK
      END

      ELSE IF SYM = AT THEN { new pointer type }
      BEGIN
         ISDEC := ISTYPDECS;
         THISLEV := X.LEVEL;
         X.LEVEL := X.PROCLEV;
         NXTSYMOK;
         X.LEVEL := THISLEV;
         NEW (RF1, PNTR);
         THISCOPY := THISSYMP;

         IF SYM = TIPE THEN
         BEGIN
            IF THISCOPY^.IDTYP = NOTYP THEN
            BEGIN { Id used before as domain & has not been resolved, so add
                    it to list of uses of this unresolved type }
               RF1^.NEXTREF := THISCOPY^.REF^.NEXTREF;
               THISCOPY^.REF^.NEXTREF := RF1
            END
            ELSE
            BEGIN {ALL INFO AT HAND SO CREATE POINTER RECORD}
               RF1^.PNTRREF := THISCOPY^.REF;
               RF1^.TYP := THISCOPY^.IDTYP;
               RF1^.PSZ := THISCOPY^.ADR
            END
         END

         ELSE IF ISTYPDECS THEN
            IF SYM = NEWID THEN
            BEGIN
             { Check that an id with the same spelling as the new id
               has not been used at the current level }
               THISCOPY^.USED_LEV := THISLEV;
               THISCOPY^.USED_PROC:= X.THISPROCNO;
               THISCOPY^.OBJ := TIPE;
               THISCOPY^.REF := RF1;
               RF1^.NEXTREF := NIL
            END
            ELSE
               IF (SYM = BADUN) AND (THISSYMP = TYPID) THEN
               BEGIN  {LHS OF TYPE DEC IS REFERENCED ON RHS}
                  RF1^.NEXTREF := LHSPTR;
                  LHSPTR := RF1
               END
               ELSE ERROR (115) {TYPE ID EXPECTED}

         ELSE ERROR (115); {TYPE ID EXPECTED}

         TP1 := PNTR;
         SZ1 := ptrsize; { Tutu - was 2 }
         ISDEC := FALSE;
         NEXTSYM
      END  {OF NUPNTRTYP}

      ELSE
      BEGIN
         IF SYM IN [KONST, LPAREN, MINUS, PLUS]
         THEN ORDTYP (RF1, SZ1, PAC) {ENUMERATED OR SUBR}
         ELSE ERROR (115); {TYPE EXPECTED}
         TP1 := SUBR
      END;

   CHKSZ (SZ1);
   RF := RF1;
   SZ := SZ1;
   TP := TP1
END; { gettyp }


PROCEDURE TYPEDECS (VAR ARECSIZ : SI);
VAR RF, RF1, RF2 : STP;
    THISDISP : TYPREC;
    LAST, NEXT : SYMP;
    TP : TYPES;
    LASTNAME, TEMP, SZ : SI;
    DOMAIN : BOOLEAN;


PROCEDURE RESOLVEPTR;
BEGIN
   WHILE RF2 <> NIL DO
   BEGIN
      RF2^.PNTRREF := RF;
      RF2^.TYP     := TP;
      RF2^.PSZ     := SZ;
      RF2          := RF2^.NEXTREF
   END
END; { resolveptr }


BEGIN { typedecs }
   ISTYPDECS := TRUE;
   NXTSYMOK;

   REPEAT
      align (arecsiz); { Tutu - each time round the loop }

      DOMAIN := (SYM = TIPE);
      IF NOT ((SYM = NEWID) OR (DOMAIN AND (THISSYMP^.IDTYP = NOTYP)))
      THEN ERROR (62); { Newid expected }
      TYPID := THISSYMP;
     { Check that an id with the same spelling as the new id
       has not been used at the current level }
      IF BADSCOPE AND (SYM = NEWID) THEN ERROR (104);
      TYPID^.OBJ := BADUN;
      NEXTSYM;
      ISDEC := FALSE;
      LHSPTR := NIL;
      LAST := TYPID;
      CHKNEXT (EQUALS);
      GETTYP (TP, RF, SZ, ARECSIZ, LAST^.PAK, FALSE, FALSE{not array element});
      ISDEC := TRUE;
      RF1 := LHSPTR;
      LAST^.OBJ := TIPE;
      LAST^.IDTYP := TP;
      LAST^.ADR := SZ;

      IF DOMAIN THEN
      BEGIN
         RF2 := LAST^.REF;
         RESOLVEPTR;
      END;

      RF2 := RF1;
      RESOLVEPTR;

      LAST^.REF := RF;
      CHKNEXT (SEMICOLON)
   UNTIL SYM <= EOFILE;

{ LOOK FOR ANY UNRESOLVED POINTER TYPES }

   THISDISP := DISPLAY[X.LEVEL]^;
   LAST := THISDISP.LASTSYM;
   NEXT := LAST;
   LASTNAME := Y.LASTNAME;
   REPEAT
      IF (NEXT^.OBJ = TIPE) AND (NEXT^.IDTYP = NOTYP) THEN
      BEGIN
         X.DEPTH := PRED (X.LEVEL);
         REPEAT
            THISSYMP := DISPLAY[X.DEPTH]^.LASTSYM;
            Y.LASTNAME := NEXT^.NAMLINK;
            TEMP := CODE1 (EQID, X.DEPTH, X.DEPTH);
            X.DEPTH := PRED (X.DEPTH)
         UNTIL (X.DEPTH > 100) OR (THISSYMP <> NIL);

         IF THISSYMP = NIL THEN ERROR (132)
         ELSE IF THISSYMP^.OBJ = TIPE THEN
         BEGIN
            RF2 := NEXT^.REF;
            WITH THISSYMP^ DO
            BEGIN
               RF := REF;
               TP := IDTYP;
               SZ := ADR
            END;
            RESOLVEPTR;

           { REMOVE NEXT FROM SYMBOL TABLE LIST }
            IF NEXT = THISDISP.LASTSYM THEN
            BEGIN
               THISDISP.LASTSYM := NEXT^.LINK;
               LASTSYMP := THISDISP.LASTSYM
            END
            ELSE
            BEGIN
               LAST^.LINK := NEXT^.LINK;
               NEXT := LAST
            END
         END
         ELSE ERROR (133)
      END;
      LAST := NEXT;
      NEXT := NEXT^.LINK
   UNTIL NEXT = NIL;

   DISPLAY[X.LEVEL]^ := THISDISP;
   Y.LASTNAME := LASTNAME
END; { typedecs }


PROCEDURE PFDEC (NOTPARAM : BOOLEAN; PROCADR  : UW); FORWARD;


PROCEDURE FPARAMLIST (VAR PSIZE : SI; VAR PLIST : PARAMP);
VAR VALPARM, PACVAR : BOOLEAN;
    RF1, RF2 : STP;
    SZ1, IDCOUNT : SI;
    NEXTOFFSET, No_PACKED, CDESCADR : UW;
    TP, SAVETYP : TYPES;
    PLIST2 : PARAMP;
    ID1, ID2 : SYMP;


PROCEDURE FPARAMTYP (VAR TP      : TYPES;
                     VAR RF      : STP;
                     VAR SZ      : SI;
                     VAR ELEMPAC : BOOLEAN);


PROCEDURE CARAYTYP (VAR RF : STP;  PAC : BOOLEAN);
VAR AP : STP;
    LOWB,
    HIGHB : SYMP;
    TP1 : TYPES;
    RF1 : STP;
    SZ1 : SI;
    LOCALELEMPAC : BOOLEAN;


PROCEDURE BOUNDS (BOUND : SYMP);
BEGIN
   BOUND^.IDTYP := SUBR;
   BOUND^.OBJ   := BOUNDID;
   BOUND^.REF   := RF1;
   BOUND^.OFSET := NEXTOFFSET;
   NEXTOFFSET   := NEXTOFFSET + twiceptrsize { Tutu - was 4 }
END; { bounds }


BEGIN { caraytyp }
   CHKNEXT (NEWID);
  { Check that an id with the same spelling as the new id
    has not been used at the current level }
   IF BADSCOPE THEN ERROR (104);
   LOWB := THISSYMP;

   CHKNEXT (DDOT);

   CHKNEXT (NEWID);
  { Check that an id with the same spelling as the new id
    has not been used at the current level }
   IF BADSCOPE THEN ERROR (104);

   HIGHB := THISSYMP;
   ISDEC := FALSE;

   CHKNEXT (COLON);

   NEW (AP, CARAY, CARAY, CARAY);
   AP^.LOWB := LOWB;
   AP^.HIGHB := HIGHB;

   ORDTYP (RF1, SZ1, FALSE);
   AP^.IREF := RF1;
   BOUNDS (LOWB);
   BOUNDS (HIGHB);
   NEXTOFFSET := NEXTOFFSET + 3; { Tutu - watch for this one ! }

   LOCALELEMPAC := PAC;
   IF ISSEMI THEN
   BEGIN
      IF PAC THEN ERROR (144);
      ISDEC := TRUE;
      NXTSYMOK;
      CARAYTYP (RF, PAC)
   END
   ELSE
   BEGIN
      CHKNEXT (RBRAK);
      CHKNEXT (OFSY);
      FPARAMTYP (TP, RF, SZ, LOCALELEMPAC)
   END;

   AP^.ELREF := RF;
   AP^.TYP   := TP;

   TP := CARAY;
   RF := AP;
   RF^.ALEV := X.LEVEL + ORD (LOCALELEMPAC OR PAC) * 128
END; { caraytyp }


BEGIN { fparamtyp }
   IF SYM = PACKSY THEN
   BEGIN
      ELEMPAC := TRUE;
      No_PACKED := SUCC (No_PACKED);
      IF No_PACKED > 1 THEN ERROR (144); { Packed carays must be single dim }
      NXTSYMOK
   END
   ELSE ELEMPAC := FALSE;

   IF SYM = ARRAYSY THEN
   BEGIN
      NXTSYMOK;
      CHKNEXT (LBRAK);
      CARAYTYP (RF, ELEMPAC);
      SZ := twiceptrsize { Tutu - was 4 }
   END

   ELSE IF SYM = TIPE THEN
   BEGIN
      IF ELEMPAC THEN ERROR (106);
      WITH THISSYMP^ DO
      BEGIN
         TP := IDTYP;  SZ := ADR;  RF := REF;  ELEMPAC := PAK
      END;
      NXTSYMOK
   END

   ELSE ERROR (115) { Type id expected }
END; { fparamtyp }


BEGIN { fparamlist }
   REPEAT
      No_PACKED := 0;
      NEXTOFFSET := 3;
      ISDEC := TRUE;
      NEXTSYM; { Skip '(' }

      IF (SYM = PROCSY) OR (SYM = FUNCSY) THEN { Got a routine as a parameter }
      BEGIN
         PFDEC (FALSE, PSIZE);
         PSIZE := PSIZE + dspNprocsize; { Tutu - was 18 }
         X.LEVEL := PRED (X.LEVEL)
      END

      ELSE
      BEGIN {PARAMETER (S) SHOULD BE IDS}
         VALPARM := SYM <> VARSY;
         IF SYM = VARSY THEN NXTSYMOK;
        { GET ID LIST IN }
         CHKNEXT (NEWID);
         ID1 := LASTSYMP^.LINK;
         LASTSYMP^.NRM := VALPARM;
        { Check that an id with the same spelling as the new id
          has not been used at the current level }
         IF BADSCOPE THEN ERROR (104);

         IDCOUNT := 1; { Loop over identically typed parameters }
         WHILE ISCOMA DO
         BEGIN
            NXTSYMOK;
            CHKNEXT (NEWID);
           { Check that an id with the same spelling as the new id
             has not been used at the current level }
            IF BADSCOPE THEN ERROR (104);
            IDCOUNT := SUCC (IDCOUNT);
            LASTSYMP^.NRM := VALPARM
         END;
         ID2 := LASTSYMP;

        { GOT ID LIST }
         ISDEC := FALSE;
         CHKNEXT (COLON);

        { GET TYPE }
         FPARAMTYP (TP, RF1, SZ1, PACVAR);

         IF NOT VALPARM THEN SZ1 := ptrsize { Tutu - was 2 }
         ELSE
            IF CONTAINSFILE (TP, RF1^, TRUE) THEN ERROR (158);

         IF TP = CARAY THEN
         BEGIN
            CDESCADR := psize + ptrsize; { Tutu - was SUCC (SUCC (PSIZE))}
            SZ1 := sz1 + ptrsize;        { Tutu - was SUCC (SUCC (SZ1))}
            RF2 := RF1;
            REPEAT
               RF2^.ADESCOFF     := CDESCADR;
               RF2^.LOWB^.ADESC  := CDESCADR;
               RF2^.HIGHB^.ADESC := CDESCADR;
               SAVETYP           := RF2^.TYP;
               RF2               := RF2^.ELREF
            UNTIL SAVETYP <> CARAY
         END;

         NEW (PLIST2);
         PLIST2^.No     := IDCOUNT;
         PLIST2^.NEXTNo := PLIST;
         PLIST          := PLIST2;

         PSIZE := PSIZE + IDCOUNT * SZ1;
         align (psize); { Tutu }
         IDCOUNT := PSIZE - SZ1;
        { ASSIGN IDS IN LIST TO CORRECT TYPE }
         REPEAT
            ID2^.OBJ := VARID;
            ID2^.IDTYP := TP;
            ID2^.REF := RF1;
            ID2^.ADR := IDCOUNT;
            IDCOUNT  := IDCOUNT - SZ1;
            ID2^.PAK := PACVAR;
            ID2      := ID2^.LINK
         UNTIL (ID2 = ID1) OR FUCKUP
      END
   UNTIL (NOT ISSEMI) OR FUCKUP;

   CHKNEXT (RPAREN)
END; { fparamlist }


PROCEDURE BLOCK (VAR ARECSIZ : SI); FORWARD;


PROCEDURE PFDEC;
VAR NMRK : UW;
    BLKNAME : SYMP;
    TP : TYPES;
    LOCSIZ : SI;
    SAVESYM : SYMBOLS;
    FROGGY, VARPARM : BOOLEAN;
    PLIST2 : PARAMP;
    PNO : UB;
    PFNAM : PFNAMP;


PROCEDURE PFBLK;
VAR FUNCRES : SYMREC;
    ENTADR : UW; { Address of start of ENTER patches }


PROCEDURE REMOVE (VAR LP, LS : SYMP);
VAR ID, LS2 : SYMP;

BEGIN { remove }
   LS2 := LS;
   WHILE LS2 <> LP DO
   BEGIN
      IF (LS2^.OBJ = PROC) OR (LS2^.OBJ = FUNC) THEN
      BEGIN
         REMOVE (LS2^.REF^.LASTSYM, LS2^.REF^.LASTPARAM);
         DISPOSE (LS2^.REF)
      END;
      ID := LS2^.LINK;
      DISPOSE (LS2);
      LS2 := ID
   END;
   LS := NIL
END; { remove }


BEGIN { pfblk }
   DBUGNAME (BLKNAME^); { Tutu - This must now be generated at all times ! }

   FLUSHNGEN (221); { S_enter : proc/func }
   GENUB (PRED (X.LEVEL));
   ENTADR := X.CADR;
   GENSI (0); { arec size & SP offset - to be patched later on }

   BLOCK (LOCSIZ);

   WITH BLKNAME^.REF^ DO
   BEGIN
{ Check if this procedure has any value parameter conformant arrays; if it
  does then code must be generated to remove the copy array from the heap.
}
      X.LEVEL := SUCC (X.LEVEL);
      VAL_CONF_DISPOSE (LASTPARAM);

      X.LEVEL := X.PROCLEV;
      STORPATCH (ENTADR,   X.MAXSTK);
      STORPATCH (ENTADR+2, LOCSIZ-PARAMSIZ);
      VARSIZ := LOCSIZ;

      IF BLKNAME^.OBJ = FUNC THEN
      BEGIN
         FLUSHNGEN (181); { S_func_ret : from function }
         GENUW (FUNCVAR);
         GENUB (RESSIZ);
         IF NOT BLKNAME^.FUNCASS THEN ERROR (96)
      END
      ELSE FLUSHNGEN (125); { S_return : from procedure }

     { Release unwanted symbol table }
      Y.LASTNAME := NMRK;
      REMOVE (LASTPARAM, LASTSYM)
   END
END; { pfblk }


BEGIN { pfdec }
   SAVESYM := PROC;
   IF SYM = FUNCSY THEN SAVESYM := FUNC;
   ISDEC := TRUE;
   NXTSYMOK;
   BLKNAME := THISSYMP;
   BLKNAME^.NRM := NOTPARAM;
   NMRK := Y.LASTNAME;

   IF SYM = NEWID THEN {New PROC or FUNC declaration}
   BEGIN
     { Check that procedure id has not been used before defining occurence }
      IF X.USED_AT_LEV >= X.LEVEL THEN ERROR (164);
      IF NOTPARAM THEN PFLIST;
      X.THISPROCNO := X.PROCNO;
      BLKNAME^.ADR := PROCADR;
      LOCSIZ := hkfsize; { Tutu - was 9 }
      BLKNAME^.OBJ := SAVESYM;
      ENTBLK;
      NXTSYMOK;

      BLKNAME^.REF := DISPLAY[X.LEVEL];
      WITH BLKNAME^.REF^ DO
      BEGIN
         PLIST := NIL;
         IF SYM = LPAREN THEN
         BEGIN
            ISTYPDECS := FALSE;
            PHEAD := TRUE;
            FPARAMLIST (LOCSIZ, PLIST);
            LASTPARAM := LASTSYM;
            PHEAD := FALSE
         END;
         PARAMSIZ := LOCSIZ;

         X.PROCLEV := X.LEVEL;
         ISDEC := FALSE;
         IF SAVESYM = FUNC THEN
         BEGIN
            CHKNEXT (COLON);
            IF SYM = TIPE THEN
            BEGIN
               RESSIZ := THISSYMP^.ADR;
               TP := THISSYMP^.IDTYP;
               IF TP > PNTR THEN ERROR (128); {FUNC TYPE MUST BE ORD/REAL/PTR}
               FUNCVAR := LOCSIZ;
               LOCSIZ := LOCSIZ + RESSIZ;
               align (locsiz); { Tutu }
               BLKNAME^.IDTYP := TP;
               FUNCREF := THISSYMP^.REF;
            END
            ELSE ERROR (126);  {FUNCTION TYPE EXPECTED}
            NEXTSYM
         END;

         IF NOTPARAM THEN
         BEGIN
            CHKNEXT (SEMICOLON);
            BLKNAME^.ADR := X.PROCNO;
            IF SYM = FORWAD THEN
            BEGIN
               VARSIZ := LOCSIZ;
               BLKNAME^.PERM := TRUE;  {IE. UNDEFINED}
               X.LEVEL := PRED (X.LEVEL);
               NXTSYMOK
            END
            ELSE PFBLK
         END
         ELSE Y.LASTNAME := NMRK
      END {with}
   END

   ELSE
      IF (SYM = SAVESYM) AND (NOTPARAM) THEN { Definition of FORWARD procedure}
      BEGIN
         X.LEVEL := SUCC (X.LEVEL);
         DISPLAY[X.LEVEL] := BLKNAME^.REF;
         X.THISPROCNO := BLKNAME^.ADR;
         NXTSYMOK;
         CHKNEXT (SEMICOLON);
         LOCSIZ := BLKNAME^.REF^.VARSIZ;
         IF NOT BLKNAME^.PERM THEN ERROR (140);
         BLKNAME^.PERM := FALSE;
         PFNAM := PROCTAB;
         FOR PNO := 0 TO BLKNAME^.ADR DO PFNAM := PFNAM^.NEXT;
         PFNAM^.ADR := X.CADR;
         PFBLK
      END  {OF FORWARDEF}
      ELSE ERROR (138)
END;


PROCEDURE BLOCK;
LABEL 13;

VAR TEMPFS, SEMI : BOOLEAN;
    PIGS_WILL_FLY : UB;
    PJMP : UW;
    P1, P2 : LABP;
    ID1 : SYMP;
    LABVAL : SI;

BEGIN { block }
   X.PROCLEV := X.LEVEL;
   ISDEC := TRUE;

   ACCEPT := [LABELSY,CONSTSY,VARSY,TYPESY,BEGINSY,PROCSY,FUNCSY,SEMICOLON];

   LABS[X.LEVEL] := NIL;
   IF SYM = LABELSY THEN
   BEGIN
      REPEAT
         NEXTSYM;
         UC;
         LABVAL := THISSYMP^.VAL;
         IF (NOT ISLAB) OR (LABVAL < 0) OR (LABVAL > 9999)
         THEN ERROR (40) { Label must be a sequence of digits 0 - 9999}
         ELSE
         BEGIN
            P1 := LABS[X.LEVEL];
            P2 := P1;
            WHILE P1 <> NIL DO
            BEGIN
               IF P1^.VAL = LABVAL THEN
               BEGIN
                  ERROR (39); { Label already declared }
                  GOTO 13
               END;
               P2 := P1;
               P1 := P1^.NEXT
            END;

            NEW (P1);
            P1^.CA     := 0;
            P1^.VAL    := LABVAL;
            P1^.USED   := FALSE;
            P1^.NEXT   := NIL;
            P1^.USER   := NIL;
            P1^.PREFIX := FALSE;
            IF P2 = NIL THEN LABS[X.LEVEL] := P1 ELSE P2^.NEXT := P1
         END;
      13 : NEXTSYM
      UNTIL NOT ISCOMA;
      CHKNEXT (SEMICOLON)
   END; { of label declaration part }

   IF SYM = CONSTSY THEN
   BEGIN
      NXTSYMOK;
      REPEAT
         CHKNEXT (NEWID);
        { Check that an id with the same spelling as the new id has not
          been used at the current level }
         IF BADSCOPE THEN ERROR (104);
         ISDEC := FALSE;
         CHKNEXT (EQUALS);
         KONSTANT;
         LASTSYMP^.OBJ     := KONST;
         LASTSYMP^.IDTYP   := THISSYMP^.IDTYP;
         LASTSYMP^.REELVAL := THISSYMP^.REELVAL;
         LASTSYMP^.REF     := THISSYMP^.REF;
         IF THISSYMP^.IDTYP = STRNG THEN
         BEGIN
            IF THISSYMP = BASESYMP {SAVE STRING IN NAMES TABLE}
            THEN Y.LASTNAME := SUCC (NAMES.TADR);
            LASTSYMP^.PAK := TRUE
         END;
         ISDEC := TRUE;
         NEXTSYM;
         CHKNEXT (SEMICOLON)
      UNTIL SYM <= EOFILE
   END; { of constant declaration part }

   X.ACTIVLEV := X.LEVEL;
   IF SYM = TYPESY THEN TYPEDECS (ARECSIZ); { Try type declaration part }

   align (arecsiz); { Tutu paranoia }

   TEMPFS := FALSE;
   IF SYM = VARSY THEN
   BEGIN
      ISTYPDECS := FALSE;
      NXTSYMOK;
      ISDEC := TRUE;
      REPEAT
         align (arecsiz); { Tutu paranoia }
         VARLIST (PIGS_WILL_FLY, FALSE {not var param},
                  FALSE {not param}, VARID, ARECSIZ, ARECSIZ, FALSE, TEMPFS);
         ISDEC := TRUE;
         CHKNEXT (SEMICOLON)
      UNTIL SYM <= EOFILE
   END; { of variable declaration part }

   align (arecsiz); { Tutu paranoia }

   IF (SYM = PROCSY) OR (SYM = FUNCSY) THEN { Any embedded local routines ? }
   BEGIN
      GENJMP (68, 0); { jmp_now : Branch around any procedures }
      PJMP := X.LASTADR;

      REPEAT
         PFDEC (TRUE, 0); { Parse over procedure/ function declarations }
         CHKNEXT (SEMICOLON)
      UNTIL (SYM <> PROCSY) AND (SYM <> FUNCSY);

      STORPATCH (PJMP, X.CADR)
   END;                   

   ISDEC := FALSE;

   ID1 := DISPLAY[X.LEVEL]^.LASTSYM;
   WHILE ID1 <> NIL DO
   BEGIN
      IF (ID1^.OBJ >= PROC) AND (ID1^.PERM) THEN ERROR (31); {Und FORWARD dec}
      IF (ID1^.OBJ = VARID) AND (ID1^.ADR < -2)
      THEN ERROR (102); { File appeared in program header but was not defined }
      ID1 := ID1^.LINK
   END;

   CHK (BEGINSY); { Start to parse block body }
   X.STKINC  := ARECSIZ;
   X.MAXSTK  := X.STKINC;
   X.STMTLEV := 0;
   X.ACTIVLEV := X.LEVEL;
   X.SEQNO := 0;
   OKGOTOS := [];

   BLKSTMT (ENDSY);

   IF TEMPFS THEN FLUSHNGEN (219); { close_files }

   P1 := LABS[X.LEVEL];
   WHILE P1 <> NIL DO
   BEGIN
      IF NOT P1^.USED THEN ERROR (24); { Label declared but not defined }
      P2 := P1;
      P1 := P1^.NEXT;
      DISPOSE (P2)
   END;

   X.MAXSTK := X.MAXSTK + 32; { Tutu - arbitrary guess for hasp use, was 10 }
   DISPLAY[X.LEVEL] := NIL;
   X.LEVEL := PRED (X.LEVEL);

   THISSYMP := DISPLAY[X.LEVEL]^.LASTSYM;
   WHILE (THISSYMP <> NIL) AND (THISSYMP^.OBJ >= EPROC) DO
   BEGIN
      THISSYMP^.USED_LEV := 0;
      THISSYMP := THISSYMP^.LINK
   END;

   X.PROCLEV := X.LEVEL
END; { block }


BEGIN { main }
   writeln ('ARM Pascal Compiler 0.12 (01-Apr-86)');

   signed := FALSE; { RCM - avoids unassigned error }
   stack_size := 0; { Tutu - Use default stack unless told otherwise }

   X.MAXNAME     := 2000;
   X.ACTIVLEV    := 1;
   X.LEVEL       := PRED (0);
   X.LINENO      := 0;
   X.CADR        := 0;
   X.ERRORS      := 0;
   X.CHRNO       := 0;
   X.ERRNO       := 0;
   X.PROCNO      := PRED (0);
   X.THISPROCNO  := 0;
   PHEAD         := FALSE;
   ERRSET        := [];
   SINGLEOPS     := '@~,.:;^()[]*+-/====<> ';
   CBUFF.BASICOP := 0; { Sets code buffer to empty }
   ACTIVELIST    := NIL;

   NEW (PROCTAB);
   PFNAMES       := PROCTAB;

  {OPTYPVAL = OFFSETS TO ADD TO BL-OPERATOR-CODES DEPENDING ON OPERAND TYPES}

  {MOVTYPVAL = OFFSETS TO ADD TO BL-MOVEDATA-CODES DEPENDING ON OPERAND TYPES
   Also used in reads and writes }

   NEW (PATCH1); { Set up the list of patches to be made after compilation }
   NEW (PATCH1^.NEXT);
   PATCH1^.NEXT^.NEXT  := NIL;
   PATCH1^.NEXT^.ADDR  := 0;
   PATCH1^.NEXT^.VALUE := 0;

   NEW (BASESYMP);
   SETSUBRTYP (BASESYMP^, NIL);

{ COMPILER OPTIONS SET UP BY MACHINE CODE INIT }
{ Initialise display for standard ids and BOOLDESC, CHARDESC & INTDESC }
   ENTBLK;
   X.INDEX := CODE1 (PNTRINIT, 0, FUCKUP);
   DISPLAY[0]^.LASTSYM := LASTSYMP;

{ Reset sourcefile to the console }
   CLRSTR (SOURCEFILE);
   OPEN;

{ Get source file name from the command tail }
   GETNAME (SOURCEFILE);
   X.NAMESZ := PRED (X.INDEX);

   IF X.INDEX = 1 THEN
   BEGIN
      SOURCEFILE[1] := CHR (13);
      X.SRCLINE := 0;
      X.NAMESZ := 1;
      ERROR (167)
   END;

   SKIPSPACES;

{ Get code file name from the command tail }
   GETNAME (CODEFILE);
   IF X.INDEX = 1 THEN ERROR (167)
   ELSE
   BEGIN
      IF CODEFILE = SOURCEFILE THEN ERROR (168);
      X.INDEX := CODE1 (DELFILE, 0, CODEFILE)
   END;

   SKIPSPACES;

   genub (&FF); { Tutu - identification byte for A4 type code }

{ Get command line compiler options if any }
   CLO := (SOURCE^ = '{');
   IF NOT CLO THEN OPEN;

   NEXTSYM;
   CHANGE := FALSE;

   GENUB (175); { S_init }
   GENUB (ORD (TAIL));
   X.DBUGTAB := X.CADR;
   GENUW (0);
   genuw (stack_size); { Tutu - extra two bytes to say how much stack to use }

   ACCEPT := [EOFILE, DOT, SEMICOLON, VARID, BEGINSY, PROCSY,
              FUNCSY, CONSTSY, VARSY, TYPESY, LABELSY];

   CHKNEXT (PROGSY);
   PFLIST;
   DBUGNAME (THISSYMP^);
   LASTSYMP := LASTSYMP^.LINK;
   DISPLAY[X.LEVEL]^.LASTSYM := LASTSYMP;
   IF SYM < FORWAD THEN ERROR (1);

   ENTBLK;
   NAMES.TADR := X.GARECADR;
   GLOBSIZ := CODE1 (TABINIT, 0, NAMES.TPTR^);

{INPUT = FILE No 1, NEGATIVE = TEMPORARY FILE}
   ENTERID (VARID, TXT);
   LASTSYMP^.REF := CHARDESC;
   LASTSYMP^.ADR := PRED (0);
   LASTSYMP^.NAMLINK := X.GARECADR;
   INPTSYMP := LASTSYMP;

{OUTPUT = FILE No 2, NEGATIVE = TEMPORARY FILE}
   ENTERID (VARID, TXT);
   LASTSYMP^.REF := CHARDESC;
   LASTSYMP^.ADR := -2;
   LASTSYMP^.NAMLINK := X.GARECADR + 6; { :len: "input " }
   OTPTSYMP := LASTSYMP;

   Y.LASTNAME := X.GARECADR + 13; { :len: "input output " }

   GENUW (221); { S_enter, level zero - main program }
   X.GARECADR := X.CADR;
   GENSI (0); { arec size & SP offset to be patched later}

   GLOBSIZ := hkfsize; { Tutu - was 9 }
   NEXTSYM;

   IF SYM = LPAREN THEN { We have program parameters }
   BEGIN
      REPEAT
         NEXTSYM;
         THISSYMP^.PERM := TRUE;
         IF SYM = NEWID THEN
         BEGIN
            THISSYMP^.OBJ   := VARID;
            THISSYMP^.IDTYP := FYLE;
            THISSYMP^.ADR   := -3
         END

         ELSE IF (SYM = VARID) THEN
         BEGIN
            IF THISSYMP^.ADR = PRED (0) {FILE NOT BEEN MADE PERMANENT }
            THEN X.INDEX := &A7 {SET INPUT TO PERMANENT}
            ELSE
               IF THISSYMP^.ADR = -2
               THEN X.INDEX := &AB { SET OUTPUT TO PERMANENT }
               ELSE ERROR (131); {FILE ALREADY DECLARED PERMANENT}

            THISSYMP^.ADR := GLOBSIZ; {SET INPUT/OUTPUT TO PERMANENT}

            GENMOV (LOCATE, THISSYMP^);
            flushngen (&F2); { pshK_nil - GENUB would ignore above loc. ! }
{ Tutu - was GENOPWTB (1, 0); PshK_ptr 0000 replaced with above line D1.02 }
            GENUB (X.INDEX);  { RESET INPUT / REWRITE OUTPUT }
            GENSI (0);
            GLOBSIZ := GLOBSIZ + fcbsize + 4 { Tutu - was 6 : FCB + BV }
         END

         ELSE ERROR (110); {VARIABLE EXPECTED}

         NEXTSYM
      UNTIL NOT ISCOMA;

      CHKNEXT (RPAREN)
   END; { of program parms }

   CHKNEXT (SEMICOLON); { Need semicolon anyway }

   BLOCK (GLOBSIZ);

   STORPATCH (X.GARECADR,   X.MAXSTK); { Patch the enter code }
   STORPATCH (X.GARECADR+2, GLOBSIZ-hkfsize); { Tutu - was 9 }

   FLUSHNGEN (176); { S_exit }

   STORPATCH (X.DBUGTAB, X.CADR);

{ Output the procedure address table }

   REPEAT
      PROCTAB := PROCTAB^.NEXT;
      GENUW (PROCTAB^.ADR)
   UNTIL PROCTAB^.NEXT = NIL;
   GENUW (&FFFF);

   CHKNEXT (DOT);

999:
   WRITELN;
   ERRLINE;
   write (X.ERRORS:1, ' Compilation error');
   if x.errors <> 1 then write ('s'); { Tutu pedantry strikes again }
   writeln;

   if x.errors <> 0 then oscli ('fx21') ; { Tutu - flush kbd buffer D1.03 }


{ Patch the code file }

   IF GENCODE THEN
   BEGIN
      X.LASTADR := 0;
      RESET (PFILE);
      REWRITE (CODEF, CODEFILE);
      PATCH1 := PATCH1^.NEXT^.NEXT;

      REPEAT
         READ (PFILE, X.INDEX);
         IF PATCH1^.ADDR = X.LASTADR THEN
         BEGIN
            X.LASTADR := SUCC (X.LASTADR);
            READ (PFILE, X.INDEX);
            WRITE (CODEF, PATCH1^.VALUE MOD 256);
            X.INDEX := PATCH1^.VALUE DIV 256;
            IF PATCH1^.NEXT <> NIL THEN PATCH1 := PATCH1^.NEXT
         END;

         X.LASTADR := SUCC (X.LASTADR);
         WRITE (CODEF, X.INDEX)
      UNTIL X.CADR <= X.LASTADR
   END;

   WRITELN ('Code size = ', X.CADR:1, ' bytes')
END. { main }