*DECK     COMP
(*$A+,U+,L'COMPILER FOR PASCAL-6000.' *)
  
  
  
  
(*********************************************************************
 *                                                                   *
 *                                                                   *
 *                      COMPILER FOR PASCAL-6000                     *
 *                      ************************                     *
 *                                                                   *
 *                                                                   *
 * (FOR CDC 6000/7000, CYBER 70,170,700,800 SERIES COMPUTER SYSTEMS) *
 *                                                                   *
 *                                                                   *
 *             AUTHOR:  URS AMMANN                                   *
 *                      INSTITUT FUER INFORMATIK                     *
 *                      EIDG. TECHNISCHE HOCHSCHULE                  *
 *                      CH-8092 ZUERICH                              *
 *                      SWITZERLAND                                  *
 *                                                                   *
 *  RELEASE 1     - URS AMMANN.                                      *
 *   1974 MAY       ORIGINAL RELEASE IMPLEMENTING THE REVISED PASCAL *
 *                  REPORT.  KNOWN AS PASCAL 6000-3.4.  GENERATE     *
 *                  RELOCATABLE CODE; REMEMBER REGISTERS.            *
 *   UPDATES 1-10 - URS AMMANN.                                      *
 *    1974-1975     CORRECT ERRORS.                                  *
 *                                                                   *
 *  RELEASE 2     - URS AMMANN AND JOHN P. STRAIT.                   *
 *   1976 MAR       IMPROVE PERFORMANCE; PROVIDE DIAGNOSTIC SUMMARY  *
 *   UPDATES 1-2  - URS AMMANN.                                      *
 *    1976          CORRECT ERRORS.                                  *
 *                                                                   *
 *                                                                   *
 *  MAINTENANCE ASSUMED BY ANDY MICKEL AND JOHN P. STRAIT            *
 *   1977 JAN              UNIVERSITY COMPUTER CENTER: 227 EX        *
 *                         UNIVERSITY OF MINNESOTA                   *
 *                         MINNEAPOLIS, MN 55455                     *
 *                         U. S. A.                                  *
 *                                                                   *
 *  RELEASE 3     - JOHN P. STRAIT.                                  *
 *   1979 JAN       IMPLEMENT CHANGES WHICH WILL BECOME STANDARD:    *
 *                  NEW TYPE-COMPATIBILITY RULES, ETC.  IMPROVE      *
 *                  RUN-TIME CHECKS, USABILITY; CORRECT ERRORS.      *
 *   UPDATE 1     - JOHN P. STRAIT.                                  *
 *    1979 JUN      CORRECT ERRORS.                                  *
 *   UPDATE 2     - ANDY MICKEL.                                     *
 *    1980 APR      CORRECT ERRORS.                                  *
 *   UPDATE 3     - RICK L. MARCUS.                                  *
 *    1981 OCT      ERROR CORRECTIONS, SMALL PERFORMANCE CHANGES.    *
 *   UPDATE 4     - DANIEL E. GERMANN.                               *
 *    1982 FEB      CORRECT ERRORS.                                  *
 *                                                                   *
 *  RELEASE 4     - DAVE BIANCHI, DANIEL E. GERMANN,                 *
 *                  ANDY MICKEL, AND JIM MINER.                      *
 *   1982 SEP       IMPLEMENT CHANGES FOR ISO 7185 PASCAL STANDARD;  *
 *                  CORRECT ERRORS.                                  *
 *                  WORK SUPPORTED IN PART BY CONTROL DATA GRANTS.   *
 *                                                                   *
 *                                                                   *
 *  THIS COMPILER IS THE PROPERTY OF THE INSTITUT FUER INFORMATIK,   *
 *  E.T.H., ZUERICH, SWITZERLAND.  CONTROL DATA CORPORATION HAS THE  *
 *  NON-EXCLUSIVE RIGHT TO DISTRIBUTE IT.                            *
 *                                                                   *
 *********************************************************************) 
  
  
(*$L'INTERNAL DESCRIPTION.' *)
  
  
(*
**       BRIEF INTERNAL DESCRIPTION.
* 
*        THE PASCAL-6000 COMPILER IMPLEMENTS THE REVISED REPORT (1972)
* FOR PASCAL AND NOW THE ISO/DIS7185 STANDARD, 1982.  IT IS A REWRITE 
* OF AN EARLIER PASCAL COMPILER WRITTEN IN 1970-1972 WHICH IMPLEMENTED
* THE ORIGINAL PASCAL REPORT (1970).
* 
*        THE COMPILER WAS DEVELOPED IN 6 STEPS, EACH AN ENRICHMENT OF 
* ITS PREDECESSOR USING THE STEPWISE-REFINEMENT METHOD OF STRUCTURED
* PROGRAMMING:  
* 
*        STEP 1 - SYNTAX ANALYSIS FOR SYNTACTICALLY CORRECT PROGRAMS. 
*        STEP 2 - RECOVERY FROM SYNTAX ERRORS.
*        STEP 3 - ANALYSIS OF DECLARATIONS. 
*        STEP 4 - PROCESSING CONTEXT-SENSITIVE ERRORS.
*        STEP 5 - ADDRESS ASSIGNMENT. 
*        STEP 6 - CODE GENERATION.
* 
*        THE COMPILER COMPILES IN ONE PASS USING TOP-DOWN, ONE-SYMBOL-
* LOOKAHEAD SYNTAX ANALYSIS WITH NO BACKTRACKING.  HOWEVER, IN SEVERAL
* PLACES, MORE THAN ONE SYMBOL LOOKAHEAD IS REQUIRED AND SEMANTIC 
* ANALYSIS RESOLVES THE CHOICES.  THE SYNTAX ANALYSIS IS IMPLEMENTED
* AS A SET OF RECURSIVE-DESCENT PROCEDURES.  THESE PROCEDURES ARE 
* BASED ON THE SYNTAX OF THE REVISED REPORT AND ARE NESTED AS TIGHTLY 
* AS THEIR MUTUAL INTERACTION PERMITS.  THE ORDER, NAMES, AND NESTING 
* OF THESE PROCEDURES ARE:  
* 
*      BLOCK
*         CONSTANT
*         TYP 
*            SIMPLETYPE 
*            FIELDLIST
*         LABELDECLARATION
*         TYPEDECLARATION 
*         VARDECLARATION
*         PROCEDUREDECLARATION
*            PARAMETERLIST
*         BODY
*            STATEMENT
*               SELECTOR
*               VARIABLE
*               CALL
*               EXPRESSION
*                  SIMPLEEXPRESSION 
*                     TERM
*                        FACTOR 
*               ASSIGNMENT
*               COMPOUNDSTATEMENT 
*               GOTOSTATEMENT 
*               IFSTATEMENT 
*               CASESTATEMENT 
*               WHILESTATEMENT
*               REPEATSTATEMENT 
*               FORSTATEMENT
*               WITHSTATEMENT 
* 
*        ERROR RECOVERY IS INCORPORATED INTO THE SYNTAX ANALYSIS
* PROCEDURES.  EACH PROCEDURE IS PASSED AN ACTUAL PARAMETER 
* WHICH IS A SET OF SYMBOLS NOT TO BE SKIPPED IN THE EVENT
* OF AN ERROR.  THESE SYMBOLS ARE THOSE WHICH MAY LEGITIMATELY
* FOLLOW THE STRING OF SYMBOLS TO BE SCANNED AND USUALLY INCLUDE
* SUCH ADDITIONAL SYMBOLS AS A CALLING SYNTAX PROCEDURE MAY WISH
* TO HANDLE IN THE EVENT OF ERROR RECOVERY.  SEE CHAPTER FIVE IN: 
* ALGORITHMS + DATA STRUCTURES = PROGRAMS, BY NIKLAUS WIRTH, 1976.
* 
*        THE ANALYSIS OF DECLARATIONS USES AN IDENTIFIER TABLE AND
* A STRUCTURE TABLE.  THE IDENTIFIER TABLE IS ORGANIZED AS A STACK
* WITH ONE ENTRY FOR EACH DECLARATION SCOPE CURRENTLY OPEN.  EACH 
* STACK ENTRY POINTS TO AN UNBALANCED BINARY TREE OF IDENTIFIERS
* AND ALSO CONTAINS INFORMATION SUCH AS THE KIND OF SYNTACTIC UNIT
* (E.G. BLOCK, PARAMETER LIST) THAT CONSTITUTES THE SCOPE.  THE 
* STACK IS REPRESENTED BY THE ARRAY "DISPLAY", TOGETHER WITH THE
* GLOBAL VARIABLES "TOP" AND "LEVEL" THAT INDICATE THE TOPMOST SCOPE
* AND TOPMOST BLOCK SCOPE RESPECTIVELY. 
* 
*        INSERTION AND LOOKUP OF IDENTIFIERS WITHIN THE TABLE IS
* PROVIDED BY TWO PROCEDURES "ENTERID" AND "SEARCHID".  STANDARD
* IDENTIFIERS SUPPORTED BY THE LANGUAGE ARE HELD AS A SCOPE 
* CORRESPONDING TO A PSEUDO-BLOCK ENCLOSING THE MAIN PROGRAM AT 
* LEVEL 0.  ADDITIONAL, NON-STANDARD, PREDECLARED IDENTIFIERS ARE 
* SIMILARLY HELD AT LEVEL -1. 
* 
*        THE STRUCTURE TABLE HOLDS ENTRIES FOR ALL TYPES UNDERLYING 
* THE DATA DEFINED BY THE PROGRAM BEING COMPILED.  THE TYPE ENTRIES 
* ARE CATEGORIZED BY THE "FORM" OF THE TYPE SO REPRESENTED (SCALARS,
* SUBRANGES, POINTERS, SETS, ETC.).  THUS ALL IDENTIFIER-TABLE
* ENTRIES HAVE A COMMON FIELD "IDTYPE" WHICH POINTS TO THE TYPE ENTRY 
* THAT DESCRIBES THE IDENTIFIER'S TYPE.  A GENERAL-PURPOSE BOOLEAN
* FUNCTION "COMPTYPES" TESTS THE COMPATIBILITY OF TWO TYPES.
* 
*        RECOVERY FROM CONTEXT-SENSITIVE ERRORS IS PROVIDED BY
* HANDLING DUPLICATE, MISUSED, AND UNDECLARED IDENTIFIERS IN ENTERID
* AND SEARCHID.  TYPE AMBIGUITIES ARE HANDLED BY SETTING THE TYPE 
* POINTER TO NIL.  COMPTYPES IS DEFINED TO RETURN TRUE IF EITHER
* OF THE TWO TYPES IS UNDEFINED (= NIL).
* 
*        THE ADDRESS ASSIGNMENT AND CODE GENERATION PARTS OF THE
* COMPILER TRY TO MINIMIZE MEMORY REFERENCES AND RECALCULATION
* OF ACCESSES TO COMPONENTS OF STRUCTURED VARIABLES.  RUN-TIME STORAGE
* ORGANIZATION MANAGES BOTH A STACK AND A HEAP. 
* 
*        A GLOBAL VARIABLE GATTR (GLOBAL ATTRIBUTE RECORD) DESCRIBES
* THE EXPRESSION OR VARIABLE ACCESS BEING COMPILED.  IF A DYADIC
* OPERATION MUST BE COMPILED, A LOCAL VARIABLE LATTR IS ASSIGNED THE
* VALUE OF GATTR.  THE ATTRIBUTE RECORD DISTINGUISHES 4 KINDS OF
* EXPRESSIONS:  CONSTANTS, VARIABLES, CONDITIONS, AND OTHER, AND IS 
* ABLE TO MANAGE ASSOCIATED INFORMATION FOR ADDRESS CALCULATION.
* 
*        A REGISTER MAP IS MANAGED FOR THE X, A, AND B REGISTERS OF 
* THE CDC-6000 HARDWARE ARCHITECTURE.  THE REGISTER MAP IS
* MANIPULATED VIA THE PROCEDURES "LOAD", "NEEDX", "NEEDB", "DECREFX", 
* AND "STORE" WHICH IMPLEMENT SEVERAL HEURISTICS TO DECIDE WHICH
* REGISTERS ARE WORTH SAVING.  CONTROL STRUCTURES ARE COMPILED BY 
* DETERMINING THEIR DISTRIBUTOR AND CONCENTRATOR POINS OF 
* COMPUTATIONAL FLOW.  THE REGISTER MAP MUST BE SAVED AT
* ALL DISTRIBUTOR POINTS AND CLEARED AT THE CONCENTRATOR POINTS.
* SEE THE ARTICLE:  "ON CODE GENERATION IN A PASCAL COMPILER" 
* BY URS AMMANN IN SOFTWARE PRACTICE AND EXPERIENCE, (7:3), 
* JUNE-JULY, 1977, PP. 391-423. 
* 
*        RELEASE 3 INCORPORATED REMEMBRANCE OF CONSTANTS USING
* THE PROCEDURE "LOADCST".  CHANGES FROM THE ORIGINAL 
* CODE-GENERATION DESIGN ARE SKETCHILY DESCRIBED IN COMMENTS IN 
* PROCEDURES "INDEXCODE", "LOADFILEWORD", AND "SETADDRESS".  THE
* INSTALLATION NOTES ON THE RELEASE 2 AND RELEASE 3 TAPES PROVIDE 
* USEFUL INFORMATION. 
* 
*)
  
  
(*$B2  USE 401B WORD BUFFERS *) 
(*$E-  COMPILE WITH DEFAULT ENTRY POINTS. *)
(*$P0  COMPILE WITH ABSOLUTELY NO PMD INFO *) 
(*$T-  COMPILE WITHOUT RUNTIME TESTS *) 
(*$X5  PASS UP TO FIVE PARAMETERS IN X-REGISTERS *) 
(*$W10000B,R-  MINIMUM WORK SPACE, AND NO REDUCE *) 
  
  
PROGRAM (*$E'P6.MAIN'/'P6.VARS'*) PASCALCOMPILER(INPUT+,OUTPUT+,LGO); 
  
(*
 *  COPYRIGHT (C) E.T.H. ZUERICH AND UNIV. OF MINNESOTA.
 *  1974, 1975, 1976, 1977, 1978, 1979, 1980, 1981, 1982. 
 *) 
  
  
LABEL 13;   (*EXIT IF EOF ENCOUNTERED*) 
  
  
(*$L'GLOBAL CONSTANT DECLARATIONS.' *)
  
  
CONST 
   COPYRIGHT = 'COPYRIGHT (C) E.T.H. ZUERICH AND UNIV. OF MINNESOTA.';
   COPYRIGHT2 = '1974,1975,1976,1977,1978,1979,1980,1981,1982.';
   DISPLIMIT = 20;
   MAXLEVEL = 10; 
   MAXADDR = 377777B; 
   WORDSIZE = 60; 
   MAXLABEL = 9999; 
   SCOPEMAX = MAXADDR;
   RESWORDS = 38; 
   TWOTO17 = 400000B; 
   CODEMAX = 150; 
   RCODEMAX = 10 (* CODEMAX DIV 15 *);
   CHARSIZE = 6;
   ALFALENG = 10; 
   FUDGEWS = 10000B ;  (* DYNAMIC WORK SPACE FUDGE FACTOR *)
   MAXLINELEN = 120;
   OSNAME = ' NOS 2.0  '; 
   LISTINGNAME = '  SOURCE LISTING OF ';
   PRODUCTVERSION = '1.1  ';
   PRODUCTLEVEL = '567 '; 
   PRODUCTNAME = 'PASCAL/170 '; 
  
  
  
  
*CALL     COMSPAS 
  
  
(*$L'GLOBAL TYPE DECLARATIONS.' *)
  
  
TYPE                         (*DESCRIBING:*)
                             (*************)
  
  
                              (*BASIC SYMBOLS*) 
                              (***************) 
  
   SYMBOL = (IDENT,INTCONST,REALCONST,CHARCONST,STRINGCONST,NOTSY,NILSY,
        MULOP,ADDOP,RELOP,LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,
        PERIOD,ARROW,COLON,BECOMES,DOTDOT,LABELSY,CONSTSY,TYPESY,VARSY, 
        FUNCTIONSY,PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,
        BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,
        GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
        THENSY,PROGRAMSY,SEGMENTEDSY,OTHERWISESY,VALUESY,OTHERSY);
   OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP, 
         GTOP,NEOP,EQOP,INOP,NOOP); 
   SETOFSYS = SET OF SYMBOL;
  
                              (*CONSTANTS*) 
                              (***********) 
  
   CODERANGE = 0..CODEMAX;
   POSRANGE = 1..4; 
   ADDRRANGE = 0..MAXADDR;
   ADDRFIELD = -377777B..777777B; 
   SHRTINT = -377777B..377777B; 
   CSTCLASS = (INT,BOOL,REEL,PSET,STRG);
   CSP = ^ CSTHEADREC;
   LOCOFREF = ^ LOCREC; 
   CTAILP = ^ CSTTAILREC; 
   CSTHEADREC = PACKED RECORD NXTCSP: CSP;
                CSTP: CTAILP; 
                CREF: LOCOFREF
             END; 
   CSTTAILREC = RECORD NXTCSP: CTAILP; CSVAL: INTEGER END;
   ERRINDEX = 1 .. ERRMAX;
   ERLISTT = PACKED ARRAY [ERRINDEX] OF BOOLEAN;
  
   VALU = RECORD CASE CSTCLASS OF 
           INT: (IVAL: INTEGER);
           BOOL: (BVAL: BOOLEAN); 
           REEL: (RVAL: REAL);
           PSET: (PVAL: SET OF 0..58); (*IMPL. DEPENDANT RANGE*)
           STRG: (VALP: CTAILP) 
          END;
  
                              (*DATA STRUCTURES*) 
                              (*****************) 
  
   LEVRANGE = 0..MAXLEVEL;
   BITRANGE = 0..59 (*=WORDSIZE-1*);
   EPWRANGE = 1..60 (*=WORDSIZE*);
   STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,
                 VARIANTPART,VARIANT,BOUNDDESC);
   DECLKIND = (PREDECLARED,USERDECLARED); 
   WBSIZE = PACKED RECORD WORDS: ADDRRANGE; 
            BITS: BITRANGE
           END; 
   STP = ^ STRUCTREC; 
   CTP = ^ IDENTREC;
  
   STRUCTREC = PACKED RECORD
          FTYPE: BOOLEAN; 
          SIZE: WBSIZE; 
          CASE FORM: STRUCTFORM OF
           SCALAR:   (CASE SCALKIND: DECLKIND OF
                        PREDECLARED: ();
                       USERDECLARED: (FCONST: CTP));
           SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU); 
           POINTER:  (ELTYPE: STP; DBG: BOOLEAN); 
           POWER:    (PCKDSET: SET OF (UNPCKD, PCKD); ELSET: STP);
           ARRAYS:   (AELTYPE,INXTYPE: STP; 
                      CONFORMANT: BOOLEAN; DESCADDR: ADDRRANGE; 
                      CASE PCKDARR: BOOLEAN OF
                       FALSE: (); 
                       TRUE: (CASE PARTWORDELS: BOOLEAN OF
                              FALSE: ();
                              TRUE: (ELSPERWORD: 2..60)));
           RECORDS:  (PCKDREC: BOOLEAN; FIELDS,FSTFLD: CTP; 
                      RECVAR: STP); 
           FILES:    (PCKDFIL,TEXTFILE,SEGFILE: BOOLEAN;
                      BSIZE : ADDRRANGE;
                      BASEFILE: STP;
                      FILTYPE: STP);
           VARIANTPART: (TAGFIELDP: CTP; FSTVAR: STP);
           VARIANT:  (FSTVARFLD: CTP; NXTVAR,SUBVAR: STP; 
                      FIRSTVAL: BOOLEAN;  VARVAL: VALU);
           BOUNDDESC:(BOUNDTYPE: STP; LOWBOUND,HIGHBOUND: CTP)
          END;
  
   EXTIDP = ^ EXTID;
   EXTREFP = ^ EXTREF;
   EXTREF = PACKED RECORD LOC: 0..7777777777B; LINK: EXTREFP END; 
   EXTID = PACKED RECORD
            EXID: ALFA; L,R: EXTIDP; REF: EXTREFP 
           END; 
  
                              (*NAMES*) 
                              (*******) 
  
   KEYWORD = (* STANDARD AND PRE-DEFINED IDENTIFIERS AND DIRECTIVES *)
     (* PROCEDURES: *)
          (GETKW,PUTKW,RESETKW,REWRITEKW,READKW,READLNKW,WRITEKW, 
           WRITELNKW,PAGEKW,PACKKW,UNPACKKW,NEWKW,DISPOSEKW,
     (* FUNCTIONS: *) 
           EOFKW,EOLNKW,ODDKW,ROUNDKW,TRUNCKW,ABSKW,SQRKW,ORDKW,
           CHRKW,PREDKW,SUCCKW,SINKW,COSKW,ARCTANKW,EXPKW,SQRTKW,LNKW,
     (* ADDITIONAL, PRE-DEFINED PROCEDURES: *)
           GETSEGKW,PUTSEGKW, 
           MESSAGEKW,TIMEKW,DATEKW,HALTKW,
     (* ADDITIONAL, PRE-DEFINED FUNCTIONS: *) 
           EOSKW,UNDEFINEDKW,EXPOKW,CARDKW,CLOCKKW, 
     (* CONSTANTS: *) 
           FALSEKW,TRUEKW,MAXINTKW, 
     (* ADDITIONAL, PRE-DEFINED CONSTANTS: *) 
           COLKW,PERKW, 
     (* TYPES: *) 
           INTEGERKW,REALKW,CHARKW,BOOLEANKW,TEXTKW,
     (* ADDITIONAL, PRE-DEFINED TYPES: *) 
           ALFAKW,
     (* VARIABLES: *) 
           INPUTKW,OUTPUTKW,
     (* COMPILER DIRECTIVES: *) 
           FORWARDKW,EXTERNALKW,FORTRANKW,
     (* ALTERNATE INPUT: *) 
           INCLUDEKW);
   IDCLASS = (TYPES,KONST,VARS,BOUNDID, 
              FIELD,TAGFIELD,PROC,FUNC,UNKNOWNID);
   SETOFIDS = SET OF IDCLASS; 
   IDKIND = (ACTUAL,FORMAL);
   ORDERING = (LESSTHAN,EQUALTO,GREATERTHAN); 
   PFDECLCLASS = (DECL,FORWDECL,EXTDECL,FTNDECL); 
   ACCESSKIND = (DRCT,INDRCT,INXD); 
   DRCTINDRCT = DRCT..INDRCT; 
   SCOPERANGE = 0..SCOPEMAX;
  
   IDSEGMENT = ^ IDNAMEEXT; 
   IDNAME = RECORD
             TEN: ALFA; 
             EXT: IDSEGMENT 
            END;
   IDNAMEEXT = PACKED RECORD
                SEVEN: PACKED ARRAY[1..7] OF CHAR;
                EXTRA: IDSEGMENT
               END; 
   IDENTREC = PACKED RECORD 
          NAME: IDNAME; LLINK: CTP; RLINK: CTP; 
          IDTYPE: STP; NEXT: CTP; 
          LASTUSESCOPE: SCOPERANGE; 
          CASE KLASS: IDCLASS OF
           KONST: (VALUES: VALU); 
           TYPES: (); 
           VARS:  (VKIND: DRCTINDRCT; VLEV: LEVRANGE; 
                   VADDR: ADDRRANGE; VINIT: BOOLEAN;
                   FIRSTINPARMGROUP,CONFORMNT,
                   THREAT,CONTROLVAR: BOOLEAN); 
           BOUNDID:(BLEV: LEVRANGE; BADDR: ADDRRANGE);
           TAGFIELD,
           FIELD: (FLDADDR: ADDRRANGE;
                   CASE PCKDFLD: BOOLEAN OF 
                    FALSE: ();
                    TRUE: (BITADDR: BITRANGE)); 
           PROC,
           FUNC:  (CASE PFDECKIND: DECLKIND OF
                      PREDECLARED: (KEY: KEYWORD);
                     USERDECLARED: (PFLEV: LEVRANGE;
                                    PFXOPT: 0..6; 
                                    PARAMLIST: CTP; 
                                    CASE PFKIND: IDKIND OF
                                     ACTUAL: (PFDECL: PFDECLCLASS;
                                              FIRSTVAR: ADDRRANGE;
                                              EPT: ALFA); 
                                     FORMAL: (PFADDR: ADDRRANGE))); 
           UNKNOWNID: ()
          END;
  
   EXTFILEP = ^ FILEREC;
   FILEREC = PACKED RECORD
               FILENAME: ALFA;
               NXTP: EXTFILEP;
               TERMINAL,DECLARED: BOOLEAN;
               SYSLOC: 2..63B 
             END; 
  
   DISPRANGE = -1 .. DISPLIMIT; 
   WHERE = (BLCK,DREC,PFPAR,WREC);
  
  
                              (*LABELS*)
                              (********)
  
   LBP = ^LABREC; 
   LABREC = PACKED RECORD 
              LABVAL: INTEGER; EPT: ALFA; 
              NEXTLAB: LBP; LABLEV: LEVRANGE; 
              ACCESSIBLE: BOOLEAN;  LABSTMTLEVEL: ADDRRANGE;
              CASE DEFINED: BOOLEAN OF
               TRUE:  (LABADDR: ADDRRANGE); 
               FALSE: (FSTOCC: LOCOFREF)
            END;
  
  
                              (*FILES:*)
                              (********)
  
   LGOFILE = SEGMENTED FILE OF INTEGER; 
  
  
                (*FOR CODE GENERATION*) 
                (*********************) 
  
   OPCODE = (PS,RJ,JP,TESTX,EQ,NE,GE,LT,BXX,BXXTX,BXXPX,BXXMX,BXCX, 
        BXXTCX,BXXPCX,BXXMCX,LXJK,AXJK,LXBX,AXBX,NXBX,ZXBX,UXBX,PXBX, 
        FXXPX,FXXMX,DXXPX,DXXMX,RXXPX,RXXMX,IXXPX,IXXMX,FXXTX,RXXTX,
        DXXTX,MXJK,FXXDX,RXXDX,NO,CXX,SAAPK,SABPK,SAXPK,SAXPB,SAAPB,
        SAAMB,SABPB,SABMB,SBAPK,SBBPK,SBXPK,SBXPB,SBAPB,SBAMB,SBBPB,
        SBBMB,SXAPK,SXBPK,SXXPK,SXXPB,SXAPB,SXAMB,SXBPB,SXBMB); 
   CONDITION = (ZR,NZ,PL,NG,XIR,XOR,XDF,XID); 
   RELOCATION = (ABSR,UNUSEDR,PROGR,NEGPROGR,VARR,GLOBLR,TERAR);
   EXTERNALNAME = (* RUNTIME-SYSTEM PROCEDURE/FUNCTION EXTERNAL NAMES *)
       (GETBEX,PUTBEX,GETCEX,PUTCEX,GETCHEX,PUTCHEX,GETLNEX,PUTLNEX,
        RDIEX,RDREX,WRFEX,WRIEX,WREEX,WRCEX,WRCDEX,WRBEX,WRSEX,PAGEEX,
        RESETEX,REWRTEX,RWRTSEX,GETSEX,PUTSEX,
        NEWEX,NEWDEX,DISPEX,DISPDEX,
        CLOCKEX,TIMEEX,DATEEX,MSGEX,HALTEX, 
        SINCOEX,EXPEX,SQRTEX,LNEX,ATANEX);
  
   BOOLCOL = ARRAY[BOOLEAN] OF OPCODE;
   BOOLROW = ARRAY[BOOLEAN] OF BOOLCOL; 
   BOOLARRAY = ARRAY[BOOLEAN] OF BOOLROW; 
   REGTYPE = (REGA,REGX); 
   SETTYPE = (APK,BPK,XPK,XPB,APB,AMB,BPB,BMB); 
   SETTABL = ARRAY[SETTYPE,REGTYPE] OF OPCODE;
  
  
               (*TO DESCRIBE EXPRESSION CURRENTLY COMPILED*)
               (*******************************************)
  
   ATTRKIND = (CST,VARBL,COND,EXPR);
   REGKIND = (NONE,XREG); 
   REGNR = 0..7;
  
   ATTR = RECORD TYPTR: STP;
       CASE KIND: ATTRKIND OF 
        CST:   (CVAL: VALU);
        VARBL: (WORDACC: ACCESSKIND;  TAGF: BOOLEAN;
                VLEVEL: LEVRANGE; CWDISPL: SHRTINT; 
                VWDISPL: REGNR; 
                DCLPCKD: BOOLEAN; 
                CASE PCKD: BOOLEAN OF 
                 FALSE: (); 
                 TRUE: (CBDISPL: SHRTINT; 
                        BITREG: REGKIND; VBDISPL: REGNR));
        COND:  (CDR: REGNR; CONDCD: ZR..NG);
        EXPR:  (EXPREG: REGNR)
       END; 
  
  
               (*TO DESCRIBE REGISTER STATUS*)
               (*****************************)
  
   ARGSTR = (SIMPADDR,INDADDR,UNSPECADDR);
   XRGSTR = (AVAIL,SHRTCST,LONGCST,SIMPVAR,INDVAR,OTHER); 
   REMXRG = SHRTCST..INDVAR;
   BRGSTR = (FREE,BASADDR,SPECPURP);
  
   ARGSTAT =
      PACKED RECORD CASE ACONT: ARGSTR OF 
              UNSPECADDR: (); 
              SIMPADDR, 
              INDADDR:  (ADISPL: ADDRRANGE; 
                        CASE ARGSTR OF
                         UNSPECADDR: ();
                         SIMPADDR: (ALEV: LEVRANGE);
                         INDADDR:  (AREG: REGNR)) 
             END; 
  
   XRGSTAT =
     PACKED RECORD
      CASE XCONT: XRGSTR OF 
       AVAIL: (); 
       SHRTCST,LONGCST, 
       SIMPVAR,INDVAR,
       OTHER: 
        (REFNR: 0..100; LASTREF: ADDRRANGE; 
         CASE REMXRG OF 
         SHRTCST: 
           (CSTVAL: SHRTINT); 
         LONGCST: 
           (CPTR: CTAILP);
         SIMPVAR, 
         INDVAR:  
           (SHFTCNT: BITRANGE;
           CASE DRCTINDRCT OF 
            DRCT: 
             (XLEV: LEVRANGE; XADDR: ADDRRANGE; 
              VPADDR: BOOLEAN); 
            INDRCT: 
             (XREG: REGNR; XDISPL: ADDRRANGE))) 
      END;
  
   BRGSTAT =
      PACKED RECORD CASE BCONT: BRGSTR OF 
              FREE, SPECPURP: (); 
              BASADDR: (BLEV: LEVRANGE) 
             END; 
  
   ARGSTATUS = ARRAY [REGNR] OF ARGSTAT;
   XRGSTATUS = ARRAY [REGNR] OF XRGSTAT;
   BRGSTATUS = ARRAY [REGNR] OF BRGSTAT;
   BASREGS = ARRAY [LEVRANGE] OF REGNR; 
  
  
   PLACE = PACKED RECORD SIX: ADDRRANGE;
                    CIX: CODERANGE; CP: POSRANGE
                  END;
  
   LOCREC = PACKED RECORD NXTREF: LOCOFREF; LOC: PLACE END; 
  
  
                (*MISCELLANEOUS*) 
                (***************) 
  
   MARKREC = RECORD END;
   MARKER = ^MARKREC; 
   DOUBLE = RECORD UPPER: REAL; LOWER: REAL END;
   PMDKIND = (PMDON,PMDOFF,PMDSUPPRESS,PMDNONE);
   LINEBUFFER = ARRAY[1..MAXLINELEN] OF CHAR; 
  
   TITLEBUFFER = PACKED ARRAY[1..40] OF CHAR; 
  
   LANGUAGEKIND = (ENGLISH, FRENCH, GERMAN, USERDL);
  
   (*$T- TURN OFF POINTER VALIDATION *) 
   PCSIMAGE = ^CSIMAGE;  (*$T=*)
   CSIMAGE = PACKED ARRAY [1 .. 80] OF CHAR;
  
   OPTIONBLOCK =
     RECORD 
       LOADANDGO : BOOLEAN;  (* LOAD AND EXECUTE BINARY *)
       LISTOFF   : BOOLEAN;  (* LISTING IS TURNED OFF *)
       USEDPD    : BOOLEAN;  (* SPECIFIED PD PARAMETER *) 
       EIGHTLPI  : BOOLEAN;  (* EIGHT LPI PAGE DENSITY *) 
       PAGESIZE  : INTEGER;  (* LISTING PAGE SIZE *)
       LINELIMIT : INTEGER;  (* OUTPUT FILE LINE LIMIT *) 
     END; 
  
(*$L'GLOBAL VARIABLE DECLARATIONS.' *)
  
  
VAR 
                  (*RETURNED BY SOURCE PROGRAM SCANNER
                   INSYMBOL:  
                   **********)
  
  SY: SYMBOL;                     (*LAST SYMBOL*) 
  OP: OPERATOR;                   (*CLASSIFICATION OF LAST SYMBOL*) 
  IVAL: INTEGER;                  (*VALUE OF LAST INTEGER CONSTANT*)
  RVAL: REAL;                     (*VALUE OF LAST REAL CONSTANT*) 
  CONSTP: CTAILP;                 (*POINTER TO LAST STRING*)
  LGTH: INTEGER;                  (*LENGTH OF LAST STRING CONSTANT*)
  ID: IDNAME;                     (*LAST IDENTIFIER*) 
  IDSTART,IDEND,
  IDBREAK: IDSEGMENT;             (*POINTERS TO ID EXTENSION*)
  EMPTYID: IDNAME;                (*USED TO INITIALIZE IDS*)
  CH: CHAR;                       (*LAST CHARACTER*)
  
  
                  (*COUNTERS:*) 
                  (***********) 
  
  LC,IC: INTEGER;                 (*DATA LOCATION AND INSTR CNTER*) 
  LABCNT: 0..36;                  (*NUMBER OF EXTERNAL LABELS*) 
  EXTFILS: 0..50;                 (*NUMBER OF EXTERNAL FILES*)
  PCNT: INTEGER;                  (*NUMBER OF PROCEDURES/FUNCTIONS*)
  B6DPL: ADDRRANGE; 
  
  
                  (*SWITCHES:*) 
                  (***********) 
  
  DP,                             (*DECLARATION PART*)
  TOPEXPR: BOOLEAN;               (*TOP LEVEL EXPRESSION FLAG*) 
  INTYPEDEFINITION: BOOLEAN;      (*PARSING A TYPE DEFINTION*)
  LINENUMBERS: BOOLEAN; 
  
  
                  (*POINTERS:*) 
                  (***********) 
  
  INTPTR,REALPTR,CHARPTR,ALFAPTR,STEXTPTR,
  BOOLPTR,NILPTR,TEXTPTR: STP;    (*POINTERS TO PREDECLARED TYPES*) 
  UTYPPTR,UCSTPTR,UVARPTR,
  UFLDPTR,UPRCPTR,UFCTPTR,        (*POINTERS TO ENTRIES FOR UNDECL IDS*)
  INPUTPTR,OUTPUTPTR,             (*ENTRIES FOR INPUT AND OUTPUT*)
  FWPTR: CTP;                     (*HEAD OF CHAIN OF FORW  TYPE IDS*) 
  FSTLABP: LBP;                   (*HEAD OF LABEL CHAIN*) 
  FEXFILP: EXTFILEP;              (*HEAD OF LIST OF EXTERNAL FILES*)
  FSTCSP: CSP;                    (*HEAD OF CONSTANT CHAIN*)
  
  
                  (*BOOKKEEPING OF DECLARATION LEVELS:*)
                  (************************************)
  
  LEVEL: LEVRANGE;                (*CURRENT STATIC LEVEL*)
  DISX,                           (*LEVEL OF LAST ID SRCHD BY SEARCHID*)
  TOP: DISPRANGE;                 (*TOP OF DISPLAY*)
  
  THISSCOPE,                      (*CURRENT SCOPE FOR ENTERID*) 
  HIGHSCOPE: SCOPERANGE;          (*HIGHEST SCOPE NUMBER USED*) 
  
  DISPLAY:                        (*WHERE:   MEANS:*) 
   ARRAY [DISPRANGE] OF 
    PACKED RECORD 
     FNAME: CTP;
     CASE REGION: WHERE OF        (*=BLCK:   VARIABLE ID*)
      BLCK: (ASSIGNED: BOOLEAN; 
            PFCP: CTP (* PROC/FUNC NAME *) ); 
      DREC: (FFWPTR: CTP);        (*=DREC:    RECORD TYPE*) 
      PFPAR: ();                  (*=PFPAR:   PARAMETER LIST*)
      WREC: (WACC: DRCTINDRCT;    (*=WREC:    FIELD ID IN WITH-REC*)
         LEV: LEVRANGE; CWDSPL: ADDRRANGE;
         DCLPKD: BOOLEAN; 
         CASE PKD: BOOLEAN OF 
           FALSE: (); 
           TRUE: (BACC: DRCTINDRCT; BDSPL: SHRTINT))
     END; 
  
  
                  (*ERROR MESSAGES:*) 
                  (*****************) 
  
  ERRINX: 0..10;                  (*NR OF ERRORS IN CURR SOURCE LINE*)
  ERRORS: BOOLEAN;
  ERRLIST:  
   ARRAY [1..10] OF 
    PACKED RECORD POS: 1..1000000;
           NMR: ERRINDEX
        END;
  ERLIST : ERLISTT; 
  LANGUAGE: LANGUAGEKIND;         (* D - DIAGNOSTIC LANGUAGE *) 
  LANG: ARRAY [LANGUAGEKIND] OF ALFA; 
  
  
                  (*LISTING:*)
                  (**********)
  
  
  LINELENGTH,SOURCELENGTH,CHCNT: INTEGER; 
  LINELC: INTEGER;
  LINENUM,LINESZ : INTEGER; 
  NEXTNUM : INTEGER;
  SETLINENUM : BOOLEAN; 
  TITLE,SUBTITLE: TITLEBUFFER;
  PAGE,LINESLEFT: INTEGER;
  SETTITLE,FIRSTHEADING: BOOLEAN; 
  LINE: LINEBUFFER; 
  INPUTFILENAME: ALFA;
  OPTS: OPTIONBLOCK;
  
  
                  (*CODE GENERATION:*)
                  (******************)
  
  GATTR: ATTR;
  CATTR: ATTR;
  ARGS: ARGSTATUS; XRGS: XRGSTATUS; BRGS: BRGSTATUS;
  BRG: BASREGS; 
  LEVELS: SET OF LEVRANGE;
  REL : ARRAY[LEVRANGE] OF RELOCATION;
  EXTNAMES: ARRAY[VARR..TERAR] OF ALFA;  (* SPECIAL ENTRY POINTS *) 
  PC: PLACE; RBUF,CBUF: INTEGER;
  BOOLOPCD: BOOLARRAY;
  SETINST: SETTABL; 
  PMDOPCODE: ARRAY[BOOLEAN] OF OPCODE;
  EX: ARRAY[EXTERNALNAME] OF ALFA; (* PROC/FUNC EXTERNAL NAMES *) 
  NOI: ARRAY[BOOLEAN] OF INTEGER;  (* TABLE OF NO-OP INSTRUCTIONS *)
  
  
                  (*CODEFILE AND TABLES FOR EXT. REFERENCES*) 
                  (*****************************************) 
  
  LGO : LGOFILE;
  COMPILERNAME : ALFA;            (* 'PASCAL R.V' *)
  VALUES : ^LGOFILE;
  PROGNAME: ALFA; 
  PROGBLOCK: ALFA;
  EXT, EXTROOT: EXTIDP; EXTIDX, EXTRX: INTEGER; 
  CADDR,                          (*ADDRESS FOR NEXT TEXTTABLE*)
  CODEADDR: ADDRRANGE;            (*ADDRESS OF
                                   CURRENT CODE SEGMENT*) 
  ALFINT: RECORD CASE BOOLEAN OF
          FALSE: (A: ALFA); 
          TRUE:  (I: INTEGER) 
          END;
  
  
                   (*COMPILER OPTIONS*) 
                   (******************) 
  
  ASCII,OLDASCII : BOOLEAN;       (* A - ASCII CHARACTER SET *) 
  BUFFSZ,OLDBUFFSZ: INTEGER;      (* B - BUFFER SIZE *) 
  EXTON,OLDEXTON: BOOLEAN;        (* E - ENTRY POINT NAME CONTROL *)
  EPT1,EPT2: ALFA;
  (* SEE *ALTERNATE INPUT FILE*      I - ALTERNATE INPUT FILE *)
  LISTON,OLDLISTON: BOOLEAN;      (* L - LISTING CONTROL *) 
  LCHANGED: BOOLEAN;
  OPTALLOWED,OLDOPTALWD: BOOLEAN; (* O - OPTIONS ALLOWED *) 
  PMDOPT,OLDPMDOPT: PMDKIND;      (* P - POST-MORTEM DUMP *)
  REDUCEMODE,OLDREDUCE: BOOLEAN;  (* R - REDUCE MEMORY *) 
  STDFLAG,OLDSTDFLAG: BOOLEAN;    (* S - STANDARD USAGE *)
  DEBUG,OLDDEBUG: BOOLEAN;        (* T - RUN TIME TESTS *)
  MAXSRCLEN,OLDMAXSL: INTEGER;    (* U - LINE WIDTH *)
  USERWS,OLDUSERWS: INTEGER;      (* W - WORKSPACE SIZE *)
  COMPWS,PRINTWS: INTEGER;
  XPARMAX,OLDXPARMAX: INTEGER;    (* X - PARAMETER PASSING *) 
  
  
                  (*ALTERNATE INPUT FILE*)
                  (**********************)
  
  ALTFILE : TEXT; 
  ALTLINENUMBERS,ALTERNATEINPUT,ALTERINGINPUT : BOOLEAN;
  
  
                  (*STRUCTURED CONSTANTS:*) 
                  (***********************) 
  
  DIGITS: SET OF '0'..'9';
  CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
     STATBEGSYS,TYPEDELS,VALSPECBEGSYS: SETOFSYS; 
  TENBLANKS: ALFA;
  RW: ARRAY [1..RESWORDS] OF ALFA;
  LRW: ARRAY [0..ALFALENG] OF 0..RESWORDS;
  FLRW : ARRAY[1..ALFALENG] OF SET OF 'A'..'Z'; 
  RSY: ARRAY [1..RESWORDS] OF SYMBOL; 
  ROP: ARRAY [1..RESWORDS] OF OPERATOR; 
  SSY: ARRAY [BOOLEAN,'+'..';'] OF SYMBOL;
  SOP: ARRAY ['+'..';'] OF OPERATOR;
  KW: ARRAY[KEYWORD] OF ALFA; 
  PASCL,PNAME: ALFA;
  TODAY,NOW: ALFA;
  
  
(*$L'GLOBAL VARIABLE INITIALIZATIONS.' *) 
  
  
VALUE 
                    (* INITIALIZE TABLES *) 
                    (*********************) 
  
  KW=('GET       ','PUT       ','RESET     ','REWRITE   ','READ      ', 
      'READLN    ','WRITE     ','WRITELN   ','PAGE      ','PACK      ', 
      'UNPACK    ','NEW       ','DISPOSE   ', 
      'EOF       ','EOLN      ','ODD       ','ROUND     ','TRUNC     ', 
      'ABS       ','SQR       ','ORD       ','CHR       ','PRED      ', 
      'SUCC      ','SIN       ','COS       ','ARCTAN    ','EXP       ', 
      'SQRT      ','LN        ',
      'GETSEG    ','PUTSEG    ',
      'MESSAGE   ','TIME      ','DATE      ','HALT      ',
      'EOS       ','UNDEFINED ','EXPO      ','CARD      ','CLOCK     ', 
      'FALSE     ','TRUE      ','MAXINT    ', 
      'COL       ','PER       ',
      'INTEGER   ','REAL      ','CHAR      ','BOOLEAN   ','TEXT      ', 
      'ALFA      ', 
      'INPUT     ','OUTPUT    ',
      'FORWARD   ','EXTERN    ','FORTRAN   ', 
      'INCLUDE   ');
  
  RW=('IF        ','DO        ','OF        ','TO        ','IN        ', 
      'OR        ','END       ','FOR       ','VAR       ','DIV       ', 
      'MOD       ','SET       ','AND       ','NOT       ','NIL       ', 
      'THEN      ','ELSE      ','WITH      ','GOTO      ','CASE      ', 
      'TYPE      ','FILE      ','BEGIN     ','UNTIL     ','WHILE     ', 
      'ARRAY     ','CONST     ','LABEL     ','VALUE     ','REPEAT    ', 
      'RECORD    ','DOWNTO    ','PACKED    ','PROGRAM   ','FUNCTION  ', 
      'PROCEDURE ','OTHERWISE ','SEGMENTED ');
  
  LRW=(0,0,6,15,22,29,33,34,35,38,38);
  
  FLRW=([], 
        ['D','I','O','T'],
        ['A','D','E','F','M','N','S','V'],
        ['C','E','F','G','T','W'],
        ['A','B','C','L','U','V','W'],
        ['D','P','R'],
        ['P'],
        ['F'],
        ['O','P','S'],
        []);
  
  RSY=(IFSY,DOSY,OFSY,TOSY,RELOP,ADDOP,ENDSY,FORSY,VARSY,MULOP,MULOP, 
       SETSY,MULOP,NOTSY,NILSY,THENSY,ELSESY,WITHSY,GOTOSY,CASESY,
       TYPESY,FILESY,BEGINSY,UNTILSY,WHILESY,ARRAYSY,CONSTSY,LABELSY, 
       VALUESY,REPEATSY,RECORDSY,DOWNTOSY,PACKEDSY,PROGRAMSY, 
       FUNCTIONSY,PROCEDURESY,OTHERWISESY,SEGMENTEDSY); 
  
  ROP=(4 OF NOOP,INOP,OROP,3 OF NOOP,IDIV,IMOD,NOOP,ANDOP,25 OF NOOP);
  
  SSY=((ADDOP,ADDOP,MULOP,MULOP,LPARENT,RPARENT,OTHERSY,RELOP,OTHERSY,
        COMMA,PERIOD,OTHERSY,LBRACK,RBRACK,COLON,4 OF OTHERSY,ARROW,
        OTHERSY,RELOP,RELOP,3 OF OTHERSY,SEMICOLON),
       (ADDOP,ADDOP,MULOP,MULOP,LPARENT,RPARENT,OTHERSY,RELOP,OTHERSY,
        COMMA,PERIOD,OTHERSY,LBRACK,RBRACK,COLON,6 OF OTHERSY,RELOP,
        RELOP,ARROW,OTHERSY,ARROW,SEMICOLON));
  
  SOP=(PLUS,MINUS,MUL,RDIV,3 OF NOOP,EQOP,13 OF NOOP,LTOP,GTOP, 
       4 OF NOOP);
  
  ERLIST=(ERRMAX OF FALSE); 
  LANG = ('ENGLISH   ','FRENCH    ','GERMAN    ','          '); 
  
  BOOLOPCD=(((BXXPX,BXXPCX),(BXXPX,BXXTX)), 
            ((BXXTX,BXXTCX),(BXXTX,BXXPX)));
  
  SETINST=((SAAPK,SXAPK),(SABPK,SXBPK),(SAXPK,SXXPK),(SAXPB,SXXPB), 
           (SAAPB,SXAPB),(SAAMB,SXAMB),(SABPB,SXBPB),(SABMB,SXBMB));
  
  PMDOPCODE=(SBAPK,LXJK);  (* 60B / 20B *)
  
  EXTNAMES=('P.MAIN;   ','P.GLOBL   ','P.TERA    ');
  
  EX=('P.GETB    ','P.PUTB    ','P.GETC    ','P.PUTC    ','P.GETCH   ', 
      'P.PUTCH   ','P.GETLN   ','P.PUTLN   ', 
      'P.RDI     ','P.RDR     ','P.WRF     ','P.WRI     ','P.WRE     ', 
      'P.WRC     ','P.WRCD    ','P.WRB     ','P.WRS     ','P.PAGE    ', 
      'P.RESET   ','P.REWRT   ','P.RWRTS   ','P.GETS    ','P.PUTS    ', 
      'P.NEW     ','P.NEWD    ','P.DISP    ','P.DISPD   ',
      'P.CLOCK   ','P.TIME    ','P.DATE    ','P.MSG     ','P.HALT    ', 
      'P.SINCO   ','P.EXP     ','P.SQRT    ','P.LN      ','P.ATAN    ');
  
  NOI=(61000B,46000B);  (* SB0 B0+K / NO *) 
  
  
                    (* INITIALIZE STRINGS *)
                    (**********************)
  
  PASCL = ALFA('P','A','S','C','L','.',4 OF COL); 
  PNAME = ALFA('P','R','C',7 OF COL); 
  PROGNAME =  'P.MAIN    '; 
  PROGBLOCK = 'P.MAIN    '; 
  COMPILERNAME = 'PASCAL 1.1';
  LANGUAGE = ENGLISH; 
  TENBLANKS = '          '; 
  
  
                    (* INITIALIZE SCALARS *)
                    (**********************)
  
  FWPTR = NIL;
  FSTLABP = NIL;
  FSTCSP = NIL; 
  INPUTPTR = NIL; 
  OUTPUTPTR = NIL;
  LABCNT = 0; 
  ERRORS = FALSE; 
  B6DPL = PFLC; 
  DP = TRUE;
  TOPEXPR = TRUE; 
  INTYPEDEFINITION = FALSE; 
  ERRINX = 0; 
  IC = 0; 
  CODEADDR = 0; 
  PCNT = 0; 
  LC = MPLC;
  LINENUM = 0;
  NEXTNUM = 0;
  VALUES = NIL; 
  PAGE = 0; 
  LINESLEFT = 0;
  SETTITLE = TRUE;
  FIRSTHEADING = TRUE;
  TITLE = '                                        '; 
  SUBTITLE = '                                        ';
  THISSCOPE = 1;
  HIGHSCOPE = 1;
  
  
                    (* DEFAULT COMPILER OPTIONS *)
                    (****************************)
  
  ASCII           = TRUE;        OLDASCII       = TRUE;        (* A+ *) 
  BUFFSZ          = 400B;        OLDBUFFSZ      = 400B;        (* B2 *) 
  EXTON           = FALSE;       OLDEXTON       = FALSE;       (* E- *) 
  ALTERNATEINPUT  = FALSE;       ALTERINGINPUT  = FALSE;       (* I  *) 
  LISTON          = TRUE;        OLDLISTON      = TRUE;        (* L+ *) 
  LCHANGED        = FALSE;
  OPTALLOWED      = TRUE;        OLDOPTALWD     = TRUE;        (* O+ *) 
  PMDOPT          = PMDON;       OLDPMDOPT      = PMDON;       (* P+ *) 
  REDUCEMODE      = TRUE;        OLDREDUCE      = TRUE;        (* R+ *) 
  STDFLAG         = TRUE;        OLDSTDFLAG     = TRUE;        (* S+ *) 
  DEBUG           = TRUE;        OLDDEBUG       = TRUE;        (* T+ *) 
  MAXSRCLEN       = MAXLINELEN;  OLDMAXSL       = MAXLINELEN;  (* U- *) 
  USERWS          = 0;           OLDUSERWS      = 0;           (* W0 *) 
  COMPWS          = FUDGEWS;
  XPARMAX         = 4;           OLDXPARMAX     = 4;           (* X4 *) 
  
  
                    (* INITIALIZE SETS *) 
                    (*******************) 
  
  DIGITS = ['0'..'9'];
  CONSTBEGSYS = [ADDOP,INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT]; 
  SIMPTYPEBEGSYS = [LPARENT,ADDOP,INTCONST,REALCONST,CHARCONST, 
                    STRINGCONST,IDENT]; 
  TYPEBEGSYS = [ARROW,PACKEDSY,SEGMENTEDSY,ARRAYSY,RECORDSY,SETSY,
                FILESY,LPARENT,ADDOP,INTCONST,REALCONST,CHARCONST,
                STRINGCONST,IDENT]; 
  TYPEDELS = [ARRAYSY,RECORDSY,SETSY,FILESY]; 
  BLOCKBEGSYS = [LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,PROCEDURESY,
                 FUNCTIONSY,BEGINSY]; 
  VALSPECBEGSYS = [ADDOP,INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT,
                   NILSY,LPARENT,LBRACK]; 
  SELECTSYS = [ARROW,PERIOD,LBRACK];
  FACBEGSYS = [INTCONST,REALCONST,CHARCONST,STRINGCONST,IDENT,LPARENT,
               LBRACK,NOTSY,NILSY]; 
  STATBEGSYS = [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,
                CASESY];
  
  
                    (* MISCELLANEOUS *) 
                    (*****************) 
  
  CATTR = ATTR(NIL,CST,VALU(INT,0));
  DISPLAY = (22 OF (NIL,BLCK,FALSE,NIL)); 
  EMPTYID = ('          ',NIL); 
  
  
(*$L'EXTERNAL ROUTINES.' *) 
  
  
 PROCEDURE BMSG( NAME : ALFA ); EXTERN; 
 PROCEDURE CLOSEB( VAR F : LGOFILE ); EXTERN; 
 PROCEDURE CLOSET( VAR F : TEXT ); EXTERN;
 PROCEDURE CSLOC(VAR CSP: PCSIMAGE); EXTERN;
 PROCEDURE CSOPT(VAR OPTS : OPTIONBLOCK); EXTERN; 
 PROCEDURE (*$E'P.DADD'*) DADD( VAR R : DOUBLE; A,B : DOUBLE ); EXTERN; 
 PROCEDURE (*$E'P.DDIV'*) DDIV( VAR R : DOUBLE; A,B : DOUBLE ); EXTERN; 
 PROCEDURE (*$E'P.DMUL'*) DMUL( VAR R : DOUBLE; A,B : DOUBLE ); EXTERN; 
 PROCEDURE FILENAME( VAR NAME : ALFA ); EXTERN; 
 PROCEDURE FIND( VAR F : TEXT; FN,RN : ALFA ); EXTERN;
 PROCEDURE LOADGO( VAR F : LGOFILE ); EXTERN; 
 FUNCTION  MASK( C : BITRANGE ) : INTEGER; EXTERN;
 FUNCTION  MERGE(A,B: VALU): INTEGER; EXTERN; 
 PROCEDURE NEXTCH; EXTERN;
 PROCEDURE NEXTCHSETUP( VAR LINE : LINEBUFFER;
   VAR CH: CHAR; VAR CHCNT,SOURCELENGTH: INTEGER); EXTERN;
 PROCEDURE PASCERR( VAR F : TEXT; EL : ERLISTT ); EXTERN; 
 FUNCTION  PORTION( W : INTEGER; SB,EB : BITRANGE ) : INTEGER; EXTERN;
 PROCEDURE RELEASE(MARK: MARKER); EXTERN; 
 FUNCTION  ROTATE( W : INTEGER; C : BITRANGE ) : INTEGER; EXTERN; 
 PROCEDURE (*$E'P.TEN'*) TEN( VAR R :  DOUBLE; X : INTEGER ); EXTERN; 
  
(*$X0 NO PARAMETERS PASSED IN X-REGS. *)
 PROCEDURE (*$E'P.WRO'*) WRITEOCT(VAR F: TEXT; I,W: INTEGER); EXTERN; 
(*$X= RESUME OLD X-OPTION. *) 
  
  
(*$L'INPUT/OUTPUT PROCESSORS.' *) 
  
  
 PROCEDURE HEADING; 
 BEGIN (* HEADING *)
  PAGE := PAGE + 1; 
  IF FIRSTHEADING THEN
   BEGIN FIRSTHEADING := FALSE; 
     IF OPTS.EIGHTLPI THEN WRITELN('T') ELSE WRITELN('S') 
   END; 
  IF OPTS.EIGHTLPI THEN BEGIN WRITELN('1'); WRITE(' ') END
  ELSE WRITE('1');
  WRITE(LISTINGNAME:20, INPUTFILENAME:7, ' ':26, OSNAME,
        PRODUCTNAME, PRODUCTVERSION, PRODUCTLEVEL, ' ':18,
        TODAY, NOW);
  IF OPTS.PAGESIZE < MAXINT THEN WRITE(' PAGE  ', PAGE:1);
  WRITELN;
  WRITELN(TITLE:41, SUBTITLE:44); 
  WRITELN;
  LINESLEFT := OPTS.PAGESIZE - 3; 
  IF OPTS.EIGHTLPI THEN 
   BEGIN WRITELN; LINESLEFT := LINESLEFT - 2 END
 END (* HEADING *); 
  
 PROCEDURE FLAGERROR; 
 VAR K : INTEGER; 
 BEGIN (* FLAGERROR *)
  IF LINESLEFT < 1 THEN HEADING;
  LINESLEFT := LINESLEFT - 1; 
  IF LISTON OR LCHANGED THEN WRITE('       ');
  IF LINENUMBERS
   THEN BEGIN WRITE(' '); FOR K := 1 TO LINESZ DO WRITE('*') END
   ELSE WRITE(' ***** ')
 END (* FLAGERROR *); 
  
 PROCEDURE WRITEERRORS; 
  VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER; 
 BEGIN (* WRITEERRORS *)
  FLAGERROR;
  LASTPOS := LINESZ + 1; FREEPOS := LASTPOS + 1;
  FOR K := 1 TO ERRINX DO 
   BEGIN
    WITH ERRLIST[K] DO
     BEGIN CURRPOS := POS; CURRNMR := NMR END;
    IF CURRPOS = LASTPOS THEN WRITE(',')
    ELSE
     BEGIN
      WHILE FREEPOS < CURRPOS DO
       BEGIN WRITE(' '); FREEPOS := FREEPOS + 1 END;
       WRITE(''''); 
       LASTPOS := CURRPOS 
     END; 
    IF CURRNMR < 10 THEN F := 1 
    ELSE IF CURRNMR < 100 THEN F := 2 
     ELSE F := 3; 
    WRITE(CURRNMR:F); 
    FREEPOS := FREEPOS + F + 1
   END; 
  WRITELN; ERRINX := 0
 END (*WRITEERRORS*) ;
  
 PROCEDURE (*$E'BEGINLI'*) BEGINLINE; 
  
  PROCEDURE READLINE( VAR F : TEXT ); 
  BEGIN (* READLINE *)
   IF DP THEN LINELC := LC ELSE LINELC := IC; 
   LINELENGTH := 0; 
   WHILE NOT EOLN(F) AND (LINELENGTH < MAXLINELEN) DO 
    BEGIN LINELENGTH := LINELENGTH + 1; 
     LINE[LINELENGTH] := F^;
     GET(F) 
    END 
  END (* READLINE *); 
  
 BEGIN (* BEGINLINE *)
  LCHANGED := FALSE;
  IF ALTERNATEINPUT THEN READLINE(ALTFILE)
  ELSE IF EOS(INPUT) THEN 
    BEGIN FLAGERROR;
     WRITELN(' INCOMPLETE PROGRAM.'); 
     ERRORS := TRUE;
     GOTO 13
    END 
   ELSE READLINE(INPUT);
  IF LINELENGTH > MAXSRCLEN THEN SOURCELENGTH := MAXSRCLEN
  ELSE SOURCELENGTH := LINELENGTH;
  CHCNT := 0; 
  LINESZ := 0;
  IF LINENUMBERS
   THEN BEGIN NEXTNUM := 0; 
    WHILE LINE[CHCNT+1] IN DIGITS DO
     BEGIN CHCNT := CHCNT + 1;
     IF LINESZ < 5 THEN LINESZ := LINESZ + 1; 
     NEXTNUM := NEXTNUM * 10 MOD 100000 + ORD(LINE[CHCNT]) - ORD('0') 
     END
    END 
   ELSE IF NOT ALTERNATEINPUT THEN NEXTNUM := NEXTNUM + 1 
 END (* BEGINLINE *); 
  
 PROCEDURE (*$E'ENDLINE'*) ENDLINE; 
  VAR I: INTEGER; 
  
  PROCEDURE FLAGSWITCH( B : BOOLEAN );
  BEGIN (* FLAGSWITCH *)
   IF LISTON OR LCHANGED THEN 
    BEGIN 
     IF LINESLEFT < 3 THEN HEADING; 
     LINESLEFT := LINESLEFT - 3;
     WRITELN; 
     WRITE(' ------ '); 
     IF B THEN WRITE('BEGIN') ELSE WRITE('END');
     WRITELN(' INCLUDED TEXT.');
     WRITELN
    END 
  END (* FLAGSWITCH *); 
  
 BEGIN (* ENDLINE *)
  IF LISTON OR LCHANGED OR (ERRINX > 0) THEN
   BEGIN I := 1 + ORD(NOT LISTON AND LCHANGED); 
    IF LINESLEFT < I + ORD(ERRINX > 0) THEN HEADING;
    LINESLEFT := LINESLEFT - I; 
    IF LISTON OR LCHANGED THEN
     BEGIN WRITE(' '); WRITEOCT(OUTPUT,LINELC,6) END; 
    IF NOT LINENUMBERS THEN WRITE(' ',NEXTNUM:5); 
    WRITE(' '); 
    FOR I := 1 TO LINELENGTH DO WRITE(LINE[I]); 
    WRITELN;
    IF NOT LISTON AND LCHANGED THEN WRITELN;
    IF ERRINX > 0 THEN WRITEERRORS
   END; 
   IF ALTERINGINPUT THEN
    BEGIN ALTERINGINPUT := FALSE; 
     ALTERNATEINPUT := TRUE;
     ALTLINENUMBERS := LINENUMBERS; 
     LINENUMBERS := ALTFILE^ IN DIGITS; 
     FLAGSWITCH(TRUE) 
    END 
   ELSE 
    IF ALTERNATEINPUT THEN
     BEGIN READLN(ALTFILE); 
      IF EOF(ALTFILE) THEN
       BEGIN ALTERNATEINPUT := FALSE; 
        LINENUMBERS := ALTLINENUMBERS;
        FLAGSWITCH(FALSE);
        READLN(INPUT) 
       END
     END
    ELSE READLN(INPUT)
 END (* ENDLINE *); 
  
 PROCEDURE ERROR(FERRNR: ERRINDEX); 
 BEGIN ERRORS := TRUE; ERLIST[FERRNR] := TRUE;
  IF ERRINX >= 9 THEN 
   BEGIN ERRLIST[10].NMR := 255; ERLIST[255] := TRUE; ERRINX := 10 END
  ELSE
   BEGIN ERRINX := ERRINX + 1;
    ERRLIST[ERRINX].NMR := FERRNR 
   END; 
  ERRLIST[ERRINX].POS := CHCNT
 END (*ERROR*) ;
  
 PROCEDURE EXTENSION(FWARNNR: ERRINDEX);
 BEGIN
  IF STDFLAG THEN ERROR(FWARNNR)
 END (* EXTENSION *); 
  
 PROCEDURE OPTIONS( PROCEDURE NEXTCH ); 
   VAR ENDOPTIONS: BOOLEAN; CH1: CHAR;
     SAVELISTON : BOOLEAN;
     FILNAME,RECNAME : ALFA;
     LINESPRINTED: INTEGER; 
     DLNG: LANGUAGEKIND;
     TEMP: TITLEBUFFER; 
  
    PROCEDURE SWITCH( VAR S,OLDS : BOOLEAN ); 
    BEGIN (* SWITCH *)
     IF CH IN ['+','-','='] THEN
      BEGIN 
       IF CH = '=' THEN S := OLDS 
       ELSE BEGIN OLDS := S; S := CH = '+' END; 
       NEXTCH 
      END 
     ELSE ENDOPTIONS := TRUE
    END (* SWITCH *); 
  
  
    PROCEDURE NUMBER( VAR N,OLDN : INTEGER; MIN,MAX : INTEGER );
     VAR DIGIT,DEC,OCT : INTEGER; 
    BEGIN (* NUMBER *)
     IF CH IN DIGITS THEN 
      BEGIN OLDN := N;
       DEC := 0; OCT := 0;
       REPEAT DIGIT := ORD(CH) - ORD('0');
        NEXTCH; 
        IF DEC <= MAX THEN DEC := DEC * 10 + DIGIT; 
        IF (OCT <= MAX) AND (DIGIT <= 7) THEN OCT := OCT * 8 + DIGIT
        ELSE OCT := MAX + 1 
       UNTIL NOT (CH IN DIGITS);
       IF CH = 'B' THEN BEGIN DEC := OCT; NEXTCH END; 
       IF DEC < MIN THEN N := MIN 
       ELSE IF DEC > MAX THEN N := MAX
       ELSE N := DEC
      END 
     ELSE 
      IF CH = '=' THEN BEGIN N := OLDN; NEXTCH END
      ELSE ENDOPTIONS := TRUE 
    END (* NUMBER *); 
  
  
    PROCEDURE READSTRING(VAR S: PACKED ARRAY [L..H: INTEGER] OF CHAR; 
                         SIZE: INTEGER);
     VAR I: INTEGER;
         Q: CHAR; 
    BEGIN (* READSTRING *)
     IF ASCII THEN Q := '''' ELSE Q := '#'; 
     IF CH = Q THEN 
      BEGIN FOR I := 1 TO H DO S[I] := ' '; 
       I := 0;
       REPEAT NEXTCH; 
        WHILE (CH <> Q) AND (CHCNT <= SOURCELENGTH) DO
         BEGIN IF I < SIZE THEN BEGIN I := I + 1; S[I] := CH END; 
          NEXTCH
         END; 
        IF CH = Q THEN
         BEGIN NEXTCH;
          IF (CH = Q) AND (I < SIZE) THEN 
           BEGIN I := I + 1; S[I] := Q END
         END
       UNTIL CH <> Q
      END 
     ELSE ENDOPTIONS := TRUE
    END (* READSTRING *); 
  
  
    PROCEDURE TWOWORDS(VAR W1,W2: ALFA);
    BEGIN (* TWOWORDS *)
     READSTRING(W1,7);
     IF NOT ENDOPTIONS AND (CH = '/') THEN
      BEGIN NEXTCH; READSTRING(W2,7) END
    END (* TWOWORDS *); 
  
  BEGIN (* OPTIONS *) 
   ENDOPTIONS := FALSE; 
   REPEAT NEXTCH; 
    IF (CH IN [ 
              'A',
              'B',
              'D',
              'E',
              'I',
              'L',
              'O',
              'P',
              'R',
              'S',
              'T',
              'U',
              'W',
              'X' 
                 ]) AND OPTALLOWED THEN 
     BEGIN CH1 := CH; NEXTCH; 
      IF (CH1 IN ['A','E','I','O','U']) AND (LINENUM <> 0) THEN 
       EXTENSION(331);
      CASE CH1 OF 
       'A' : SWITCH(ASCII,OLDASCII);
       'B' : BEGIN NUMBER(BUFFSZ,OLDBUFFSZ,1,377777B);
              IF BUFFSZ < 64 THEN BUFFSZ := BUFFSZ * 128
             END; 
       'D' : BEGIN READSTRING(LANG[USERDL],10); DLNG := ENGLISH;
              WHILE LANG[DLNG] <> LANG[USERDL] DO 
               DLNG := SUCC(DLNG);
              IF DLNG = USERDL THEN ERROR(350)
              ELSE LANGUAGE := DLNG 
             END; 
       'E' : IF CH IN ['+','-','='] THEN SWITCH(EXTON,OLDEXTON) 
             ELSE TWOWORDS(EPT1,EPT2);
       'I' : BEGIN FILNAME := '          '; 
              TWOWORDS(RECNAME,FILNAME);
              IF NOT ENDOPTIONS THEN
               BEGIN
                IF NOT EOF(ALTFILE) THEN ERROR(199) 
                ELSE
                 BEGIN FIND(ALTFILE,FILNAME,RECNAME); 
                  IF EOF(ALTFILE) THEN ERROR(198) 
                  ELSE ALTERINGINPUT := TRUE
                 END
               END
             END; 
       'L' : IF CH IN ['+','-','='] THEN
              BEGIN SAVELISTON := LISTON; 
               SWITCH(LISTON,OLDLISTON);
               LCHANGED := LCHANGED OR (LISTON <> SAVELISTON) 
              END 
             ELSE 
              BEGIN READSTRING(TEMP,40);
               IF NOT ENDOPTIONS THEN (* TITLE PRESENT *) 
                IF SETTITLE THEN
                 BEGIN TITLE := TEMP; SETTITLE := FALSE END 
                ELSE BEGIN SUBTITLE := TEMP;
                 IF LISTON THEN LINESLEFT := 0
                END 
              END;
       'O' : SWITCH(OPTALLOWED,OLDOPTALWD); 
       'P' : IF CH IN ['+','-','0','='] THEN
              BEGIN 
               IF PMDOPT <> PMDNONE THEN
                IF CH = '=' THEN PMDOPT := OLDPMDOPT
                ELSE
                 BEGIN OLDPMDOPT := PMDOPT; 
                  IF CH = '+' THEN PMDOPT := PMDON
                  ELSE
                   IF CH = '-' THEN PMDOPT := PMDOFF
                   ELSE PMDOPT := PMDSUPPRESS 
                 END; 
               NEXTCH 
              END 
             ELSE ENDOPTIONS := TRUE; 
       'R' : SWITCH(REDUCEMODE,OLDREDUCE);
       'S' : SWITCH(STDFLAG,OLDSTDFLAG);
       'T' : SWITCH(DEBUG,OLDDEBUG);
       'U' : BEGIN
              IF CH IN ['+','-'] THEN 
               BEGIN OLDMAXSL := MAXSRCLEN; 
                IF CH = '+' THEN MAXSRCLEN := 72
                ELSE MAXSRCLEN := MAXLINELEN; 
                NEXTCH
               END
              ELSE NUMBER(MAXSRCLEN,OLDMAXSL,20,MAXLINELEN);
              IF NOT ENDOPTIONS THEN
               IF LINELENGTH > MAXSRCLEN THEN 
                SOURCELENGTH := MAXSRCLEN 
               ELSE SOURCELENGTH := LINELENGTH
             END; 
       'W' : NUMBER(USERWS,OLDUSERWS,0,377777B);
       'X' : NUMBER(XPARMAX,OLDXPARMAX,0,5);
       END; 
      ENDOPTIONS := ENDOPTIONS OR (CH <> ',') 
     END
    ELSE ENDOPTIONS := TRUE 
   UNTIL ENDOPTIONS;
  END (*OPTIONS*);
  
 PROCEDURE INSYMBOL;
  (* READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS DESCRIPTION
     IN THE GLOBAL VARIABLES: SY, OP, ID, IVAL, RVAL, CONSTP, LGTH *) 
  LABEL 1,2;
  CONST LIM1 = 322;     (* MAXIMUM EXPONENT *)
        LIM2 = -292;    (* MINIMUM EXPONENT *)
        T29 =  4000000000B;  (* 2**29 *)
        T30 = 10000000000B;  (* 2**30 *)
        SEVENBLANKS = '       ';
  VAR D,DCOUNT,ECOUNT,I,K,SCALE,EXP,T: INTEGER; 
    UPPERD,LOWERD,UPPERB,LOWERB,UPPERR,LOWERR: INTEGER; 
    SIGN,BADB: BOOLEAN; 
    T1,T2,T3: DOUBLE; 
    APO,STRINGEND: BOOLEAN; NXTP,TAILP: CTAILP; Q: CHAR;
    OA: RECORD
         CASE BOOLEAN OF
          FALSE: (A: ALFA); 
          TRUE:  (I: INTEGER) 
        END;
    DOT: BOOLEAN; 
 BEGIN (* INSYMBOL *) 
  SETLINENUM := SETLINENUM OR (LINENUM <> NEXTNUM); 
  LINENUM := NEXTNUM; 
 1: OP := NOOP; 
  CASE CH OF
   'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 
   'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z': 
    BEGIN K := 0; ID.TEN := TENBLANKS; SY := IDENT; 
     REPEAT K := K + 1; 
      ID.TEN[K] := CH;
      CHCNT := CHCNT + 1; 
      IF CHCNT > SOURCELENGTH THEN CH := ' '
      ELSE CH := LINE[CHCNT]
     UNTIL (K = ALFALENG) OR NOT (CH IN ['A'..'Z','0'..'9']); 
     IF CH IN ['A'..'Z','0'..'9'] THEN (*EXTRA IDSEGMENTS REQUIRED*)
      BEGIN I := 0; ID.EXT := IDSTART; IDEND^.EXTRA := IDBREAK; 
       IDEND := IDSTART; IDEND^.SEVEN := SEVENBLANKS; 
       REPEAT 
        IF I = 7 THEN (* NEXT IDSEGMENT *)
         BEGIN IDEND := IDEND^.EXTRA; 
          I := 0; IDEND^.SEVEN := SEVENBLANKS;
         END; 
        I := I + 1; IDEND^.SEVEN[I] := CH;
        CHCNT := CHCNT + 1; 
        IF CHCNT > SOURCELENGTH THEN CH := ' '
        ELSE CH := LINE[CHCNT]
       UNTIL NOT (CH IN ['A'..'Z','0'..'9']); 
       IDBREAK := IDEND^.EXTRA; IDEND^.EXTRA := NIL;
      END 
     ELSE 
      BEGIN ID.EXT := NIL;
       IF ID.TEN[1] IN FLRW[K] THEN 
        FOR I := LRW[K-1] + 1 TO LRW[K] DO
         IF RW[I] = ID.TEN THEN 
          BEGIN SY := RSY[I]; OP := ROP[I]; GOTO 2 END
      END;
 2: END;
   '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':  
    BEGIN SY := INTCONST; 
     DCOUNT := 0; 
     UPPERD := 0; LOWERD := 0;
     UPPERB := 0; LOWERB := 0;
     UPPERR := 0; LOWERR := 0;
     SCALE := 0;
     BADB := FALSE; 
     REPEAT D := ORD(CH) - ORD('0');
      BADB := BADB OR NOT (CH IN ['0'..'7']); 
      LOWERD := LOWERD * 10 + D;
      T := LOWERD DIV T30;
      LOWERD := LOWERD - T * T30; 
      IF UPPERD < T30 THEN UPPERD := UPPERD * 10 + T; 
      LOWERB := LOWERB * 8 + D; 
      T := LOWERB DIV T30;
      LOWERB := LOWERB - T * T30; 
      IF UPPERB < T30 THEN UPPERB := UPPERB * 8 + T;
      IF DCOUNT < 28 THEN 
       BEGIN
        IF DCOUNT < 14 THEN UPPERR := UPPERR * 10 + D 
        ELSE LOWERR := LOWERR * 10 + D; 
        IF (D <> 0) OR (DCOUNT <> 0) THEN DCOUNT := DCOUNT + 1
       END
      ELSE SCALE := SCALE + 1;
      NEXTCH
     UNTIL NOT (CH IN DIGITS);
     IVAL := 0; 
     IF CH = 'B' THEN (* OCTAL CONSTANT *)
      BEGIN NEXTCH; 
       EXTENSION(321);
       IF BADB THEN ERROR(204)
       ELSE 
        IF UPPERB >= T30 THEN ERROR(203)
        ELSE IVAL := UPPERB * T30 + LOWERB
      END 
     ELSE (* DECIMAL INTEGER OR REAL *) 
      BEGIN 
       DOT := CH = '.'; 
       IF DOT AND (CHCNT < SOURCELENGTH) THEN 
        DOT := LINE[CHCNT+1] IN DIGITS; 
       IF DOT OR (CH = 'E') THEN (* REAL NUMBER *)
        BEGIN SY := REALCONST;
         IF CH = '.' THEN (* GATHER FRACTION *) 
          BEGIN NEXTCH; 
           IF NOT (CH IN DIGITS) THEN ERROR(201)
           ELSE 
            REPEAT D := ORD(CH) - ORD('0'); 
             IF DCOUNT < 28 THEN
              BEGIN SCALE := SCALE - 1; 
               IF DCOUNT < 14 THEN UPPERR := UPPERR * 10 + D
               ELSE LOWERR := LOWERR * 10 + D;
               IF (D <> 0) OR (DCOUNT <> 0) THEN DCOUNT := DCOUNT + 1 
              END;
             NEXTCH 
            UNTIL NOT (CH IN DIGITS)
          END;
         IF CH = 'E' THEN (* GATHER EXPONENT *) 
          BEGIN NEXTCH; 
           IF CH IN ['+','-'] THEN
            BEGIN SIGN := CH = '-'; NEXTCH END
           ELSE SIGN := FALSE;
           EXP := 0; ECOUNT := 0; 
           IF NOT (CH IN DIGITS) THEN ERROR(201)
           ELSE 
            REPEAT D := ORD(CH) - ORD('0'); 
             IF ECOUNT < 14 THEN
              BEGIN EXP := EXP * 10 + D;
               IF (D <> 0) OR (ECOUNT <> 0) THEN ECOUNT := ECOUNT + 1 
              END;
             NEXTCH 
            UNTIL NOT (CH IN DIGITS); 
           IF SIGN THEN SCALE := SCALE - EXP ELSE SCALE := SCALE + EXP
          END;
         T1.UPPER := UPPERR; T1.LOWER := 0.0; 
         IF DCOUNT > 14 THEN
          BEGIN T2.UPPER := LOWERR; T2.LOWER := 0.0;
           TEN(T3,DCOUNT - 14); 
           DMUL(T1,T3,T1);
           DADD(T1,T1,T2) 
          END;
         EXP := SCALE + DCOUNT; 
         IF (EXP < LIM2) OR (EXP > LIM1) THEN 
          BEGIN T1.UPPER := 0.0; T1.LOWER := 0.0; SCALE := 0; 
           IF EXP > LIM1 THEN ERROR(207)
          END;
         TEN(T2,ABS(SCALE));
         IF SCALE < 0 THEN DDIV(T1,T1,T2) 
         ELSE 
          IF SCALE <> 0 THEN DMUL(T1,T1,T2);
         RVAL := T1.UPPER + T1.LOWER
        END (* REAL NUMBER *) 
       ELSE (* INTEGER NUMBER *)
        IF UPPERD >= T29 THEN ERROR(203)
        ELSE
         BEGIN IVAL := UPPERD * T30 + LOWERD; 
          IF UPPERD > (MAXINT DIV T30) THEN EXTENSION(322)
         END
      END;
     IF CH IN ['A'..'Z'] THEN ERROR(50) 
    END;
   COL, PER:    (* CHR(00B) AND CHR(63B) *) 
    BEGIN NEXTCH; 
     IF CH = '=' THEN 
      BEGIN SY := BECOMES; NEXTCH END 
     ELSE SY := COLON 
    END;
   ' ': 
    BEGIN 
     REPEAT CHCNT := CHCNT + 1; 
      IF CHCNT > SOURCELENGTH THEN
       BEGIN ENDLINE; BEGINLINE; CH := ' ' END
      ELSE CH := LINE[CHCNT]
     UNTIL CH <> ' '; 
     GOTO 1 
    END;
   '#', '''': 
    IF ASCII = (CH = '''') THEN (* QUOTE CHARACTER *) 
     BEGIN Q := CH; 
      APO := FALSE; STRINGEND := FALSE; 
      LGTH := 0; I := 0; CONSTP := NIL; 
      NEXTCH; 
      REPEAT
       IF CHCNT > SOURCELENGTH THEN 
        BEGIN ERROR(202); STRINGEND := TRUE END 
       ELSE 
        IF (CH <> Q) OR APO THEN
         BEGIN
          IF I = ALFALENG THEN
           BEGIN NEW(TAILP);
            WITH TAILP^ DO
             BEGIN NXTCSP := CONSTP; CSVAL := OA.I END; 
            CONSTP := TAILP; I := 0 
           END; 
          I := I + 1; LGTH := LGTH + 1; APO := FALSE; 
          OA.A[I] := CH;
          NEXTCH
         END
        ELSE
          BEGIN APO := TRUE;
          NEXTCH; STRINGEND := CH <> Q
         END
      UNTIL STRINGEND;
      SY := STRINGCONST;
      IF LGTH = 0 THEN ERROR(205) 
     ELSE 
      IF LGTH = 1 THEN
        BEGIN SY := CHARCONST; IVAL := ORD(OA.A[1]) END 
      ELSE
        BEGIN FOR I := I+1 TO ALFALENG DO OA.A[I] := CHR(0);
        NEW(TAILP); 
        WITH TAILP^ DO
         BEGIN NXTCSP := CONSTP; CSVAL := OA.I END; 
        (*REVERSE POINTERS:*) 
        CONSTP := NIL;
        WHILE TAILP <> NIL DO 
         WITH TAILP^ DO 
          BEGIN NXTP := NXTCSP; NXTCSP := CONSTP; 
           CONSTP := TAILP; TAILP := NXTP 
          END;
       END
     END
    ELSE
     BEGIN
      IF ASCII THEN (* '#' IS A BAD CHARACTER *)
       SY := OTHERSY
      ELSE (* '''' IS A ARROW *)
       SY := ARROW; 
      NEXTCH
     END; 
   '.': 
    BEGIN NEXTCH; 
     IF CH = '.' THEN 
      BEGIN SY := DOTDOT; NEXTCH END
     ELSE IF CH = ')' THEN
      BEGIN SY := RBRACK; NEXTCH END
     ELSE SY := PERIOD
    END;
   '(': 
    BEGIN NEXTCH; 
     IF CH = '*' THEN 
      BEGIN NEXTCH; 
       IF CH = '$' THEN OPTIONS(NEXTCH);
       REPEAT 
        (*LOOP UNTIL CH = '*':*)
        WHILE CH <> '*' DO NEXTCH;
        NEXTCH
       UNTIL CH = ')';
       NEXTCH; GOTO 1 
      END;
     IF CH = '.' THEN 
      BEGIN SY := LBRACK; NEXTCH END
     ELSE SY := LPARENT;
    END;
   '<': 
    BEGIN NEXTCH; SY := RELOP;
     IF CH = '=' THEN 
      BEGIN OP := LEOP; NEXTCH END
     ELSE 
      IF CH = '>' THEN
       BEGIN OP := NEOP; NEXTCH END 
      ELSE OP := LTOP 
    END;
   '>': 
    BEGIN NEXTCH; SY := RELOP;
     IF CH = '=' THEN 
      BEGIN OP := GEOP; NEXTCH END
     ELSE OP := GTOP
    END;
   '+', '-', '*', '/', ')', '$', '=', ',', '[', 
   ']', '"', '_', '!', '&', '?', '@', '\', '^', ';':  
    BEGIN SY := SSY[ASCII,CH]; OP := SOP[CH]; NEXTCH END
  END (* CASE *)
 END (* INSYMBOL *);
  
  
(*$L'SYMBOL / STRUCTURE TABLE PROCESSORS.' *) 
  
  
 PROCEDURE WRITEID(NAME: IDNAME); 
  VAR S: IDSEGMENT; 
 BEGIN WRITE(NAME.TEN); 
  S := NAME.EXT;
  WHILE S <> NIL DO 
   BEGIN WRITE(S^.SEVEN); S := S^.EXTRA END;
  WRITELN 
 END (* WRITEID *); 
  
 FUNCTION COMPAREIDS(FID1,FID2: IDNAME): ORDERING;
  
  FUNCTION COMPARESEGS(SEG1,SEG2: IDSEGMENT): ORDERING; 
  BEGIN 
   IF SEG1^.SEVEN < SEG2^.SEVEN THEN COMPARESEGS := LESSTHAN
   ELSE 
    IF SEG1^.SEVEN > SEG2^.SEVEN THEN COMPARESEGS := GREATERTHAN
    ELSE
     IF SEG1^.EXTRA <> NIL THEN 
      IF SEG2^.EXTRA <> NIL THEN
       COMPARESEGS := COMPARESEGS(SEG1^.EXTRA,SEG2^.EXTRA)
      ELSE COMPARESEGS := GREATERTHAN 
     ELSE 
      IF SEG2^.EXTRA = NIL THEN COMPARESEGS := EQUALTO
      ELSE COMPARESEGS := LESSTHAN
  END (* COMPARESEGS *);
  
 BEGIN (* COMPAREIDS *) 
  IF FID1.TEN < FID2.TEN THEN COMPAREIDS := LESSTHAN
  ELSE
   IF FID1.TEN > FID2.TEN THEN COMPAREIDS := GREATERTHAN
   ELSE 
    IF FID1.EXT <> NIL THEN 
     IF FID2.EXT <> NIL THEN
      COMPAREIDS := COMPARESEGS(FID1.EXT,FID2.EXT)
     ELSE COMPAREIDS := GREATERTHAN 
    ELSE
     IF FID2.EXT = NIL THEN COMPAREIDS := EQUALTO 
     ELSE COMPAREIDS := LESSTHAN
 END (* COMPAREIDS *);
  
 PROCEDURE COPYID(VAR FCP: CTP);
  (*COPY (AND ALLOCATE DYNAMIC STORAGE IF NECESSARY) ID INTO THE LCP
    WHICH WILL EVENTUALLY BE PLACED IN THE SYMBOL TABLE BY ENTERID. 
    UNFORTUNATELY THE COPY CANNOT BE MADE BY ENTERID INSTEAD. *)
  VAR S1,S2: IDSEGMENT; 
 BEGIN  FCP^.NAME := ID;
  IF ID.EXT <> NIL THEN (* COPY SEGMENTS *) 
   BEGIN NEW(S2); S1 := ID.EXT; FCP^.NAME.EXT := S2;
    S2^.SEVEN := S1^.SEVEN; S1 := S1^.EXTRA;
    WHILE S1 <> NIL DO
     BEGIN NEW(S2^.EXTRA); S2 := S2^.EXTRA; 
      S2^.SEVEN := S1^.SEVEN; S1 := S1^.EXTRA 
     END; 
    S2^.EXTRA := NIL
   END
 END (* COPYID *);
  
 PROCEDURE ENTERID(FCP: CTP;  FREGION: WHERE);
  (*ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE, 
   WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
   AN UNBALANCED BINARY TREE*)
  VAR NAM: IDNAME;  LCP, LCP1: CTP;  LLEFT, CONFLICT: BOOLEAN;
      LLEV, LLEV1: DISPRANGE; 
  
  PROCEDURE CHECKFWPTR(FCP: CTP); 
  BEGIN 
   WHILE FCP <> NIL DO
    BEGIN IF COMPAREIDS(FCP^.NAME,NAM) = EQUALTO THEN CONFLICT := TRUE; 
     FCP := FCP^.NEXT 
    END 
  END (* CHECKFWPTR *); 
  
  PROCEDURE SEARCHNAM(FCP: CTP;  VAR FCP1: CTP);
  BEGIN 
   FCP1 := NIL; 
   WHILE FCP <> NIL DO
    CASE COMPAREIDS(FCP^.NAME,NAM) OF 
     LESSTHAN   : FCP := FCP^.RLINK;
     EQUALTO    : BEGIN FCP1 := FCP; FCP := NIL END;
     GREATERTHAN: FCP := FCP^.LLINK 
    END 
  END (* SEARCHNAM *);
  
 BEGIN  (* ENTERID *) 
  CONFLICT := FALSE;  NAM := FCP^.NAME; 
  CHECKFWPTR(FWPTR);  LLEV := TOP;
  WHILE FREGION <> DISPLAY[LLEV].REGION DO
   WITH DISPLAY[LLEV] DO
    BEGIN  IF REGION = DREC THEN CHECKFWPTR(FFWPTR);
     SEARCHNAM(FNAME,LCP);
     IF LCP <> NIL THEN CONFLICT := TRUE; 
     LLEV := LLEV - 1 
    END;
  LLEV1 := LLEV;
  WHILE LLEV > 0 DO 
   BEGIN  LLEV := LLEV - 1; 
    SEARCHNAM(DISPLAY[LLEV].FNAME,LCP); 
    IF LCP <> NIL THEN
     BEGIN
      IF LCP^.LASTUSESCOPE >= THISSCOPE THEN CONFLICT := TRUE;
      LLEV := 0 
     END
   END; 
  LCP := DISPLAY[LLEV1].FNAME;
  IF LCP = NIL THEN 
   DISPLAY[LLEV1].FNAME := FCP
  ELSE
   BEGIN
    REPEAT LCP1 := LCP; 
     CASE COMPAREIDS(LCP^.NAME,NAM) OF
      LESSTHAN: 
       BEGIN LCP := LCP^.RLINK; LLEFT := FALSE END; 
      EQUALTO:  (* NAME CONFLICT--FOLLOW RIGHT LINK *)
       BEGIN ERROR(101); LCP := LCP^.RLINK; LLEFT := FALSE END; 
      GREATERTHAN:  
       BEGIN LCP := LCP^.LLINK; LLEFT := TRUE END;
     END
    UNTIL LCP = NIL;
    IF LLEFT THEN LCP1^.LLINK := FCP ELSE LCP1^.RLINK := FCP
   END; 
  FCP^.LLINK := NIL; FCP^.RLINK := NIL; 
  FCP^.LASTUSESCOPE := 0; 
  IF CONFLICT THEN ERROR(190);
 END (*ENTERID*) ;
  
 PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
  (*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S'
   --> PROCEDURE PROCEDUREDECLARATION 
   --> PROCEDURE SELECTOR*) 
  LABEL 1;
 BEGIN
  WHILE FCP <> NIL DO 
   CASE COMPAREIDS(FCP^.NAME,ID) OF 
    LESSTHAN   : FCP := FCP^.RLINK; 
    EQUALTO    : GOTO 1;
    GREATERTHAN: FCP := FCP^.LLINK
   END; 
1:  FCP1 := FCP 
 END (*SEARCHSECTION*) ;
  
 PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
  LABEL 1;
  VAR LCP: CTP; LDISX: DISPRANGE; 
 BEGIN
  FOR LDISX := TOP DOWNTO -1 DO 
   BEGIN LCP := DISPLAY[LDISX].FNAME; 
    WHILE LCP <> NIL DO 
     CASE COMPAREIDS(LCP^.NAME,ID) OF 
      LESSTHAN   : LCP := LCP^.RLINK; 
      EQUALTO    : IF LCP^.KLASS IN FIDCLS THEN 
                    BEGIN IF LDISX = -1 THEN EXTENSION(320);
                     LCP^.LASTUSESCOPE := THISSCOPE; GOTO 1 
                    END 
                   ELSE 
                    BEGIN IF NOT (UNKNOWNID IN FIDCLS) THEN ERROR(103); 
                     LCP := LCP^.RLINK
                    END;
      GREATERTHAN: LCP := LCP^.LLINK
     END
   END; 
  LDISX := 0; 
  (*SEARCH NOT SUCCESSFUL; SUPPRESS ERROR MESSAGE IN CASE 
   OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION 
   OR VARIANTS WITHOUT TAGFIELDS
   --> PROCEDURE FIELDLIST
   --> PROCEDURE SIMPLETYPE*) 
  IF NOT (UNKNOWNID IN FIDCLS) THEN 
   BEGIN ERROR(104);
    (*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
     FOR AN UNDECLARED ID OF APPROPRIATE CLASS
     --> PROCEDURE ENTERUNDECL*)
    IF TYPES IN FIDCLS THEN LCP := UTYPPTR
    ELSE
     IF VARS IN FIDCLS THEN LCP := UVARPTR
     ELSE 
      IF FIELD IN FIDCLS THEN LCP := UFLDPTR
      ELSE
       IF KONST IN FIDCLS THEN LCP := UCSTPTR 
       ELSE 
        IF PROC IN FIDCLS THEN LCP := UPRCPTR 
        ELSE LCP := UFCTPTR;
   END; 
1:  FCP := LCP; DISX := LDISX 
 END (*SEARCHID*) ; 
  
  
 PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER); 
  (*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
  (* ASSUME FSP <> REALPTR *) 
  BEGIN 
   IF FSP <> NIL THEN 
    WITH FSP^ DO
     IF FORM = SUBRANGE THEN
      BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END
     ELSE 
      BEGIN FMIN := 0; FMAX := 0; 
       IF FORM = SCALAR THEN
        BEGIN 
         IF SCALKIND = PREDECLARED THEN 
          BEGIN 
           IF FSP = CHARPTR THEN FMAX := 63 
           ELSE 
            IF FSP = INTPTR THEN
             BEGIN FMIN := -MAXINT; FMAX := MAXINT END
          END 
         ELSE 
          IF FSP^.FCONST <> NIL THEN
           FMAX := FSP^.FCONST^.VALUES.IVAL 
        END 
      END 
  END (*GETBOUNDS*);
  
 PROCEDURE SKIP(FSYS: SETOFSYS);
  (*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*) 
 BEGIN WHILE NOT (SY IN FSYS) DO INSYMBOL 
 END (*SKIP*) ; 
  
  
 PROCEDURE EXPECTSYMBOL( X: SYMBOL; Y: INTEGER);
 BEGIN IF SY = X THEN INSYMBOL ELSE ERROR(Y)
 END (*EXPECTSYMBOL*) ; 
  
 PROCEDURE CHECKCONTEXT(X: SETOFSYS; Y: INTEGER; Z: SETOFSYS);
 BEGIN IF NOT (SY IN X) THEN
  BEGIN ERROR(Y); SKIP(X+Z) END 
 END (*CHECKCONTEXT*) ; 
  
  
(*$L'PROCEDURE / FUNCTION BLOCK PROCESSOR.' *)
  
  
 PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP); 
  VAR LSY: SYMBOL; FLABP: LBP; LFSTCSP: CSP;
      LFORWCNT: INTEGER;
      PMD: PMDKIND; 
      BLOCKSCOPE: SCOPERANGE; 
      INORDER,EXITLOOP: BOOLEAN;
  
       PROCEDURE CHECKFORW(FCP: CTP); 
         (*PRINT ERROR MESSAGE FOR FORWARD DECLARED PROCEDURE*) 
       BEGIN
        IF FCP <> NIL THEN
         WITH FCP^ DO 
          BEGIN 
           IF KLASS IN [PROC,FUNC] THEN 
            IF PFKIND = ACTUAL THEN 
             IF PFDECL = FORWDECL THEN
              BEGIN ERROR(117); 
               FLAGERROR; 
               WRITE(' UNDECLARED PROCEDURE: '); WRITEID(NAME); 
              END;
           CHECKFORW(LLINK); CHECKFORW(RLINK) 
          END 
       END (*CHECKFORW*); 
  
  
  FUNCTION NROFBITS(FVAL: INTEGER) : INTEGER; 
   (*COMPUTE NR OF BITS NECESSARY TO REPRESENT 0..FVAL*)
   VAR B: INTEGER;
  BEGIN B := 0; 
   REPEAT FVAL := FVAL DIV 2; B := B + 1
   UNTIL FVAL = 0;
   NROFBITS := B
  END (*NROFBITS*); 
  
  FUNCTION FULLWORDS(FSIZE: WBSIZE) : INTEGER;
  BEGIN 
   WITH FSIZE DO FULLWORDS := WORDS + ORD(BITS <> 0)
  END (*FULLWORDS*) ; 
  
  FUNCTION CONFORMARRAY(FSP: STP): BOOLEAN; 
   (* DETERMINE IF STRUCTURE POINTED TO BY FSP IS CONFORMANT ARRAY. *)
  BEGIN CONFORMARRAY := FALSE;
   IF FSP <> NIL THEN 
    WITH FSP^ DO
     IF FORM = ARRAYS THEN
      IF CONFORMANT THEN CONFORMARRAY := TRUE 
  END (* CONFORMARRAY *); 
  
  FUNCTION COMPTYPES(FSP1,FSP2: STP): BOOLEAN; FORWARD; 
  
  FUNCTION STRING(FSP: STP): BOOLEAN; 
   (* DETERMINE IF FSP DESCRIBES A STRING TYPE *) 
   VAR LMIN,LMAX: INTEGER;
  BEGIN (* STRING *)
   STRING := FALSE; 
   IF FSP <> NIL THEN 
    WITH FSP^ DO
     IF FORM = ARRAYS THEN
      IF PCKDARR AND (AELTYPE = CHARPTR) THEN 
       IF CONFORMANT THEN 
        BEGIN 
         IF INXTYPE <> NIL THEN 
          IF COMPTYPES(INXTYPE^.BOUNDTYPE,INTPTR) THEN STRING := TRUE 
        END 
       ELSE 
        IF COMPTYPES(INXTYPE,INTPTR) AND (INXTYPE <> NIL) THEN
         BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
          STRING := LMIN = 1
         END
  END (* STRING *); 
  
  FUNCTION COMPTYPES; 
   VAR LMIN1,LMAX1,LMIN2,LMAX2: INTEGER;
  BEGIN (*COMPTYPES*) 
   IF FSP1 <> NIL THEN
    IF FSP1^.FORM = SUBRANGE THEN 
     FSP1 := FSP1^.RANGETYPE; 
   IF FSP2 <> NIL THEN
    IF FSP2^.FORM = SUBRANGE THEN 
     FSP2 := FSP2^.RANGETYPE; 
   IF FSP1 = FSP2 THEN COMPTYPES := TRUE
   ELSE 
    IF (FSP1 <> NIL)AND (FSP2 <> NIL) THEN
     IF FSP1^.FORM = FSP2^.FORM THEN
      CASE FSP1^.FORM OF
       POINTER: 
        COMPTYPES := (FSP1 = NILPTR) OR (FSP2 = NILPTR);
       POWER: 
        COMPTYPES := (FSP1^.PCKDSET * FSP2^.PCKDSET <> [])
                 AND COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
       ARRAYS:  
        BEGIN COMPTYPES := FALSE; 
         IF STRING(FSP1) THEN 
          IF STRING(FSP2) THEN
           BEGIN GETBOUNDS(FSP1^.INXTYPE,LMIN1,LMAX1);
            GETBOUNDS(FSP2^.INXTYPE,LMIN2,LMAX2); 
            COMPTYPES := NOT (CONFORMARRAY(FSP1) OR CONFORMARRAY(FSP2)) 
                         AND (LMAX1 = LMAX2)
           END
        END;
       SCALAR,
       BOUNDDESC, 
       RECORDS, 
       FILES: 
        COMPTYPES := FALSE
      END (*CASE*)
     ELSE COMPTYPES := FALSE
    ELSE COMPTYPES := TRUE
  END (*COMPTYPES*) ; 
  
  PROCEDURE STRINGTYPE(VAR FSP: STP); 
   (*ENTER TYPE OF STRINGCONST (PACKED ARRAY [1..LGTH] OF CHAR) INTO
    STRUCTURE TABLE*) 
   VAR LSP,LSP1: STP; 
  BEGIN NEW(LSP,SUBRANGE);
   WITH LSP^ DO 
    BEGIN FORM := SUBRANGE; RANGETYPE := INTPTR;
     MIN.IVAL := 1; MAX.IVAL := LGTH ; FTYPE := FALSE;
     WITH SIZE DO 
      BEGIN WORDS := 0; BITS := NROFBITS(LGTH) END
    END;
   NEW(LSP1,ARRAYS,TRUE,TRUE);
   WITH LSP1^ DO
    BEGIN FORM := ARRAYS; CONFORMANT := FALSE;
     AELTYPE := CHARPTR; INXTYPE := LSP;
     PCKDARR := TRUE; PARTWORDELS := TRUE;
     ELSPERWORD := ALFALENG; FTYPE := FALSE;
     WITH SIZE DO 
      BEGIN WORDS := LGTH DIV ALFALENG; 
       BITS := (LGTH MOD ALFALENG) * CHARSIZE 
      END 
    END;
   FSP := LSP1
  END (*STRINGTYPE*) ;
  
  
(*$L'DECLARATIONS PROCESSORS.' *) 
  
  
  PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
   VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG); LCSP: CSP; 
  BEGIN LSP := NIL; FVALU.IVAL := 0;
   CHECKCONTEXT(CONSTBEGSYS,50,FSYS); 
   IF SY IN CONSTBEGSYS THEN
    BEGIN 
     IF SY = CHARCONST THEN 
      BEGIN LSP := CHARPTR; FVALU.IVAL := IVAL; INSYMBOL END
     ELSE 
      IF SY = STRINGCONST THEN
       BEGIN STRINGTYPE(LSP); 
        FVALU.VALP := CONSTP; 
        INSYMBOL
       END
     ELSE 
      BEGIN 
       SIGN := NONE;
       IF OP IN [PLUS,MINUS] THEN 
        BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; 
         INSYMBOL 
        END;
       IF SY = IDENT THEN 
        BEGIN SEARCHID([KONST],LCP);
         WITH LCP^ DO 
          BEGIN LSP := IDTYPE; FVALU := VALUES END; 
         IF SIGN <> NONE THEN 
          IF LSP = INTPTR THEN
           BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END 
          ELSE
           IF LSP = REALPTR THEN
            BEGIN 
             IF SIGN = NEG THEN FVALU.RVAL := -FVALU.RVAL 
            END 
          ELSE ERROR(105);
         INSYMBOL;
        END 
       ELSE 
        IF SY = INTCONST THEN 
         BEGIN IF SIGN = NEG THEN IVAL := -IVAL;
          LSP := INTPTR; FVALU.IVAL := IVAL; INSYMBOL 
         END
        ELSE
         IF SY = REALCONST THEN 
          BEGIN IF SIGN = NEG THEN RVAL := -RVAL; 
           LSP := REALPTR; FVALU.RVAL := RVAL; INSYMBOL 
          END 
         ELSE 
          BEGIN ERROR(106); SKIP(FSYS) END
      END;
     CHECKCONTEXT(FSYS,6,[])
     END; 
   FSP := LSP 
  END (*CONSTANT*) ;
  
  
  PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP);
   VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP; 
     LSIZE,DISPL,FILEDISPL: WBSIZE; LMIN,LMAX,LRL: INTEGER; 
     T,T1,W,B: INTEGER; PACKFLAG,SEGFLAG,LFILTYP,EXITLOOP: BOOLEAN; 
     NROFELS: INTEGER; LSCOPE: SCOPERANGE; LLEV: DISPRANGE; 
  
   PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP);
    VAR LSP,LSP1: STP; LCP,LCP1: CTP; 
      LVAL: INTEGER; LVALU: VALU; 
  
    PROCEDURE SUBRANGES(FSP: STP; FVALU: VALU); 
     (*PROCESS SUBRANGE TYPE*)
     VAR LOW,HIGH: INTEGER; 
    BEGIN NEW(LSP,SUBRANGE);
     WITH LSP^ DO 
      BEGIN RANGETYPE := FSP; FORM := SUBRANGE; 
       MIN := FVALU; FTYPE := FALSE 
      END;
     EXPECTSYMBOL(DOTDOT,21); 
     CONSTANT(FSYS,LSP1,LVALU); 
     WITH LSP^ DO 
      BEGIN MAX := LVALU; 
       WITH SIZE DO 
        BEGIN WORDS := 1; BITS := 0 END;
       IF NOT COMPTYPES(FSP,LSP1) THEN ERROR(107) 
       ELSE 
        WITH SIZE DO
         IF FSP = REALPTR THEN
          BEGIN ERROR(183); RANGETYPE := NIL
          END 
         ELSE 
          IF STRING(FSP) THEN 
           BEGIN ERROR(148); RANGETYPE := NIL 
           END
          ELSE
           BEGIN LOW := MIN.IVAL; HIGH := MAX.IVAL; 
            IF LOW > HIGH THEN ERROR(102);
            WORDS := 0; 
            IF ABS(LOW) < ABS(HIGH) THEN
             BITS := NROFBITS(ABS(HIGH))
            ELSE BITS := NROFBITS(ABS(LOW));
            IF LOW < 0 THEN BITS := BITS + 1
           END
      END 
    END (*SUBRANGES*);
  
   BEGIN (*SIMPLETYPE*) 
    CHECKCONTEXT(SIMPTYPEBEGSYS,1,FSYS);
    IF SY IN SIMPTYPEBEGSYS THEN
     BEGIN
      IF SY = LPARENT THEN
       BEGIN NEW(LSP,SCALAR,USERDECLARED);
        WITH LSP^ DO
         BEGIN FORM := SCALAR; SCALKIND := USERDECLARED; FTYPE := FALSE;
          FCONST := NIL 
         END; 
        LCP1 := NIL; LVAL := -1;
        REPEAT INSYMBOL;
         IF SY = IDENT THEN 
          BEGIN NEW(LCP,KONST); LVAL := LVAL + 1; 
           WITH LCP^ DO 
            BEGIN COPYID(LCP); IDTYPE := LSP; NEXT := LCP1; 
             VALUES.IVAL := LVAL; KLASS := KONST
            END;
           ENTERID(LCP,BLCK); 
           LCP1 := LCP; INSYMBOL
          END 
         ELSE ERROR(2); 
         CHECKCONTEXT(FSYS+[COMMA,RPARENT],6,[])
        UNTIL SY <> COMMA;
        WITH LSP^, SIZE DO
         BEGIN FCONST := LCP1;
          WORDS := 0; BITS := NROFBITS(LVAL)
         END; 
        EXPECTSYMBOL(RPARENT,4) 
       END
      ELSE
       BEGIN
        IF SY = IDENT THEN
         BEGIN SEARCHID([TYPES,KONST],LCP); 
          INSYMBOL; 
          WITH LCP^ DO
           IF KLASS = KONST THEN SUBRANGES(IDTYPE,VALUES) 
           ELSE 
            LSP := IDTYPE 
         END (*SY = IDENT*) 
        ELSE
         BEGIN CONSTANT(FSYS+[DOTDOT],LSP1,LVALU);
          SUBRANGES(LSP1,LVALU) 
         END; 
       END; 
      FSP := LSP; 
      CHECKCONTEXT(FSYS,6,[]) 
     END
      ELSE FSP := NIL 
   END (*SIMPLETYPE*) ; 
  
   FUNCTION INCRADDR(FA, FI: ADDRRANGE): ADDRRANGE; 
   BEGIN (* INCRADDR *) 
     IF FA + FI <= MAXADDR THEN INCRADDR := FA + FI 
     ELSE INCRADDR := MAXADDR 
   END (* INCRADDR *);
  
   PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP;
             VAR FFSTFLD: CTP; VAR FTYP: BOOLEAN);
    VAR LASTFLD,LCP,LCP1,THIS,LLSTFLD: CTP; 
      LSP,LSP1,LSP2,LSP3,LSP4: STP; 
      MINSIZE,MAXSIZE: WBSIZE; LVALU: VALU; 
      LFILTYP,EXITLOOP,DISCRIMINATED,LTEST: BOOLEAN;
      TAGVALCOUNT: 0..MAXINT;  TAGSP: STP;
      TAGMIN, TAGMAX: INTEGER;
  
    PROCEDURE FIELDADDRESS(FCP: CTP;  FSIZE: WBSIZE;
                           VAR FDISPL: WBSIZE;  FLASTFLD: CTP); 
     (*COMPUTE ADDRESS OF FCP^ ACCORDING TO ITS SIZE *) 
     VAR W,B: INTEGER;
  
     PROCEDURE ADJUST;
      (*ADJUST LASTFLD*)
     BEGIN
      IF FLASTFLD <> NIL THEN 
       WITH FLASTFLD^ DO
        IF IDTYPE <> NIL THEN 
         IF IDTYPE^.FORM <= POWER THEN
          IF BITADDR = 0 THEN PCKDFLD := FALSE
          ELSE
           BITADDR := WORDSIZE - IDTYPE^.SIZE.BITS; 
      W := INCRADDR(W,1); B := 0
     END (*ADJUST*);
  
    BEGIN (*FIELDADDRESS*)
     WITH FDISPL, FCP^ DO 
     BEGIN
      W := WORDS; B := BITS;
      IF PACKFLAG AND (FSIZE.WORDS = 0) THEN
       BEGIN IF B + FSIZE.BITS > WORDSIZE THEN ADJUST;
        FLDADDR := W; PCKDFLD := TRUE;
        BITADDR := B; 
        IF B + FSIZE.BITS = WORDSIZE THEN 
         BEGIN W := W + 1; B := 0 END 
        ELSE B := B + FSIZE.BITS
       END
      ELSE
       BEGIN IF B <> 0 THEN ADJUST; 
        FLDADDR := W; PCKDFLD := FALSE; 
        W := W + FULLWORDS(FSIZE) 
       END; 
      IF W > MAXADDR THEN BEGIN W := MAXADDR; B := 0 END; 
      WORDS := W; BITS := B 
     END
    END (*FIELDADDRESS*) ;
  
   BEGIN (* FIELDLIST *) LSP := NIL;
    FFSTFLD := NIL; 
    LASTFLD := NIL; FTYP := FALSE;
    CHECKCONTEXT(FSYS+[IDENT,CASESY],19,[]);
    WHILE SY = IDENT DO 
     BEGIN THIS := NIL; 
      (*LOOP UNTIL SY <> COMMA:*) 
      REPEAT
       IF SY = IDENT THEN 
        BEGIN NEW(LCP,FIELD); 
         WITH LCP^ DO 
          BEGIN COPYID(LCP); IDTYPE := NIL; 
           KLASS := FIELD 
          END;
         IF FFSTFLD = NIL THEN FFSTFLD := LCP 
         ELSE LLSTFLD^.NEXT := LCP; 
         LLSTFLD := LCP;
         IF THIS = NIL THEN THIS := LCP;
         ENTERID(LCP,DREC); 
         INSYMBOL 
        END 
       ELSE ERROR(2); 
       CHECKCONTEXT([COMMA,COLON],6,FSYS+[SEMICOLON,CASESY]); 
       EXITLOOP := SY <> COMMA; 
       IF NOT EXITLOOP THEN INSYMBOL
      UNTIL EXITLOOP; 
      LLSTFLD^.NEXT := NIL; 
      EXPECTSYMBOL(COLON,5);
      TYP(FSYS+[CASESY,SEMICOLON],LSP); 
      WHILE THIS <> NIL DO
       WITH THIS^ DO
        BEGIN IDTYPE := LSP;
         IF LSP <> NIL THEN 
          IF LSP^.FTYPE THEN
           BEGIN  FTYP := TRUE; 
             FIELDADDRESS(THIS,LSP^.SIZE,FILEDISPL,NIL) 
           END
          ELSE
           BEGIN  FIELDADDRESS(THIS,LSP^.SIZE,DISPL,LASTFLD); 
            LASTFLD := THIS 
           END
         ELSE 
           BEGIN FLDADDR := DISPL.WORDS; PCKDFLD := FALSE END;
         THIS := NEXT 
        END;
      IF SY = SEMICOLON THEN
       BEGIN INSYMBOL;
        CHECKCONTEXT(FSYS+[IDENT,CASESY],19,[]);
       END
     END (*WHILE*); 
    IF SY = CASESY THEN 
     BEGIN NEW(LSP,VARIANTPART);
      WITH LSP^ DO
       BEGIN FORM := VARIANTPART; TAGFIELDP := NIL; FTYPE := FALSE END; 
      FRECVAR := LSP;  TAGSP := NIL;  TAGVALCOUNT := 0; 
      INSYMBOL; 
      IF SY = IDENT THEN
       BEGIN NEW(LCP,TAGFIELD);  LSP^.TAGFIELDP := LCP; 
        COPYID(LCP); (* SAVE ID UNTIL WE KNOW NEXT SYMBOL *)
        WITH LCP^ DO
         BEGIN IDTYPE := NIL; KLASS := TAGFIELD; NEXT := NIL END; 
        INSYMBOL;  DISCRIMINATED := (SY = COLON); 
        IF DISCRIMINATED THEN 
         BEGIN  ENTERID(LCP,DREC); INSYMBOL;
          IF SY = IDENT THEN
           BEGIN SEARCHID([TYPES],LCP1);  INSYMBOL END
          ELSE
           BEGIN  LCP1 := UTYPPTR;
            ERROR(2);  SKIP(FSYS + [OFSY,LPARENT])
           END
         END
        ELSE
         BEGIN ID := LCP^.NAME; LCP^.NAME := EMPTYID; 
          SEARCHID([TYPES],LCP1)
         END; 
        LSP1 := LCP1^.IDTYPE; 
        IF LSP1 <> NIL THEN 
         BEGIN
          IF LSP1^.FORM <= SUBRANGE THEN
           BEGIN
            IF LSP1 = REALPTR THEN ERROR(109) 
            ELSE
             BEGIN TAGSP := LSP1;  LCP^.IDTYPE := LSP1; 
              GETBOUNDS(TAGSP,TAGMIN,TAGMAX); 
              IF DISCRIMINATED THEN 
               FIELDADDRESS(LCP,LSP1^.SIZE,DISPL,LASTFLD) 
             END
           END
          ELSE ERROR(110) 
         END; 
       END
      ELSE (* SY <> IDENT *)
       BEGIN ERROR(2); SKIP(FSYS+[OFSY,LPARENT]) END; 
      LSP^.SIZE := DISPL; 
      EXPECTSYMBOL(OFSY,8); 
      CHECKCONTEXT(CONSTBEGSYS,19,FSYS+[COLON,LPARENT]);
      LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
      REPEAT
       LSP2 := NIL;  LSP3 := NIL;  DISPL := MINSIZE;
       REPEAT CONSTANT(FSYS+[COMMA,COLON,LPARENT],LSP4,LVALU);
        IF (TAGSP <> NIL) AND (LSP4 <> NIL) THEN
         IF NOT COMPTYPES(TAGSP,LSP4) THEN ERROR(111) 
         ELSE 
          BEGIN 
           LSP4 := LSP1;  LTEST := TRUE;
           WHILE (LSP4 <> NIL) AND LTEST DO 
            WITH LSP4^ DO 
             BEGIN
              IF VARVAL.IVAL = LVALU.IVAL THEN
               BEGIN  ERROR(178);  LTEST := FALSE END;
              LSP4 := NXTVAR
             END; 
           IF LTEST THEN
            BEGIN 
             NEW(LSP3,VARIANT); 
             WITH LSP3^ DO
              BEGIN  FORM := VARIANT;  FIRSTVAL := (LSP2 = NIL);
               NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU; 
              END;
             LSP1 := LSP3;  LSP2 := LSP3; 
             IF (LVALU.IVAL < TAGMIN) OR (LVALU.IVAL > TAGMAX) THEN 
              ERROR(111)
             ELSE TAGVALCOUNT := TAGVALCOUNT + 1
            END 
          END;
        EXITLOOP := SY <> COMMA;
        IF NOT EXITLOOP THEN INSYMBOL 
       UNTIL EXITLOOP;
       EXPECTSYMBOL(COLON,5); 
       EXPECTSYMBOL(LPARENT,9); 
       FIELDLIST(FSYS+[RPARENT,SEMICOLON],LSP2,LCP,LFILTYP);
       FTYP := FTYP OR LFILTYP; 
       IF (DISPL.WORDS > MAXSIZE.WORDS)OR 
        (DISPL.WORDS = MAXSIZE.WORDS)AND (DISPL.BITS > MAXSIZE.BITS)
        THEN MAXSIZE := DISPL;
       WHILE LSP3 <> NIL DO 
        WITH LSP3^ DO 
         BEGIN LSP4 := SUBVAR; SUBVAR := LSP2;
          SIZE := DISPL; FSTVARFLD := LCP;  FTYPE := LFILTYP; 
          LSP3 := LSP4
         END; 
       IF SY = RPARENT THEN 
        BEGIN INSYMBOL; 
         CHECKCONTEXT(FSYS+[SEMICOLON],6,[])
        END 
       ELSE ERROR(4); 
       IF SY = SEMICOLON THEN INSYMBOL
      UNTIL SY IN FSYS; 
      DISPL := MAXSIZE; 
      LSP^.FSTVAR := LSP1;
      IF TAGSP <> NIL THEN
       IF TAGMIN - 1 + TAGVALCOUNT <> TAGMAX THEN ERROR(186)
     END
    ELSE
     FRECVAR := NIL 
   END (*FIELDLIST*) ;
  
   PROCEDURE FIXFIELDALLOCATION(FCP: CTP; FSP: STP; FWORDS: ADDRRANGE); 
     (* INCREASE NON-FILE FIELD OFFSETS IN FIELD LIST FCP AND IN
        VARIANT LIST FSP BY FWORDS. *)
   BEGIN (* FIXFIELDALLOCATION *) 
    WHILE FCP <> NIL DO 
     WITH FCP^ DO 
      BEGIN 
       IF IDTYPE <> NIL THEN
        IF NOT IDTYPE^.FTYPE THEN 
         FLDADDR := INCRADDR(FLDADDR,FWORDS); 
       FCP := NEXT
      END;
    IF FSP <> NIL THEN
       BEGIN
        IF FSP^.TAGFIELDP <> NIL THEN 
         WITH FSP^.TAGFIELDP^ DO
          IF NAME.TEN <> TENBLANKS THEN 
           FLDADDR := INCRADDR(FLDADDR,FWORDS); 
        FSP := FSP^.FSTVAR; 
      WHILE FSP <> NIL DO 
       WITH FSP^ DO  (* FORM = VARIANT *) 
        BEGIN  SIZE.WORDS := INCRADDR(SIZE.WORDS,FWORDS); 
         IF FIRSTVAL THEN FIXFIELDALLOCATION(FSTVARFLD,SUBVAR,FWORDS);
         FSP := NXTVAR
        END 
     END
   END (* FIXFIELDALLOCATION *);
  
  BEGIN (*TYP*) LSP := NIL; 
   PACKFLAG := FALSE; SEGFLAG := FALSE; 
   CHECKCONTEXT(TYPEBEGSYS,10,FSYS);
   IF SY IN TYPEBEGSYS THEN 
    BEGIN 
     IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,LSP)
     ELSE 
  (*^*) 
      IF SY = ARROW THEN
       BEGIN NEW(LSP,POINTER);
        WITH LSP^ DO
         BEGIN FORM := POINTER; FTYPE := FALSE; ELTYPE := NIL;
          DBG := DEBUG; 
          WITH SIZE DO
           BEGIN WORDS := 0; BITS := NROFBITS(MAXADDR); 
            IF DEBUG THEN BITS := 2 * (BITS + 1)
           END
         END; 
        INSYMBOL; 
        IF SY = IDENT THEN
         BEGIN
          IF INTYPEDEFINITION THEN
           BEGIN  LLEV := TOP;
            REPEAT SEARCHSECTION(DISPLAY[LLEV].FNAME,LCP);
             EXITLOOP := (LLEV = 0) OR (LCP <> NIL);
             IF NOT EXITLOOP THEN LLEV := LLEV - 1
            UNTIL EXITLOOP; 
            IF LCP <> NIL THEN
             IF (LCP^.LASTUSESCOPE < BLOCKSCOPE) AND (LLEV < LEVEL) 
             THEN LCP := NIL
             ELSE 
              IF LCP^.KLASS <> TYPES THEN 
               BEGIN  ERROR(191);  LCP := NIL  END
              ELSE LCP^.LASTUSESCOPE := THISSCOPE 
           END
          ELSE SEARCHID([TYPES],LCP); 
          IF LCP = NIL THEN   (*FORWARD REFERENCED TYPE ID*)
           BEGIN NEW(LCP,TYPES);
            WITH LCP^ DO
             BEGIN COPYID(LCP); IDTYPE := LSP; KLASS := TYPES;
              NEXT := FWPTR 
             END; 
            FWPTR := LCP
           END
          ELSE LSP^.ELTYPE := LCP^.IDTYPE;
          INSYMBOL; 
         END
        ELSE ERROR(2);
       END
      ELSE (* SY <> ARROW *)
       BEGIN
        IF SY = PACKEDSY THEN 
         BEGIN PACKFLAG := TRUE; INSYMBOL END;
        IF SY = SEGMENTEDSY THEN
         BEGIN SEGFLAG := TRUE; EXTENSION(323); INSYMBOL END; 
        IF SEGFLAG AND NOT PACKFLAG AND (SY = IDENT) THEN 
         BEGIN SEARCHID([TYPES],LCP); 
          WITH LCP^ DO
           IF IDTYPE <> NIL THEN
            WITH IDTYPE^ DO 
             IF FORM = FILES THEN 
              IF SEGFILE THEN 
               BEGIN ERROR(60); LSP := IDTYPE END 
              ELSE
               BEGIN NEW(LSP);  (* DON'T DO NEW(LSP,FILES)           *) 
                                (* BECAUSE LSP^ := IDTYPE^ WILL FAIL *) 
                LSP^ := IDTYPE^;
                WITH LSP^ DO
                 BEGIN BASEFILE := IDTYPE; SEGFILE := TRUE END
               END
             ELSE ERROR(60);
          INSYMBOL
         END
        ELSE
        BEGIN 
        CHECKCONTEXT(TYPEDELS,10,FSYS); 
        IF (SY <> FILESY)AND SEGFLAG THEN ERROR(57);
  (*ARRAY*) 
        IF SY = ARRAYSY THEN
         BEGIN INSYMBOL;
          EXPECTSYMBOL(LBRACK,11);
          LSP1 := NIL;
          (*LOOP UNTIL SY <> COMMA:*) 
          REPEAT NEW(LSP,ARRAYS); 
           WITH LSP^ DO 
            BEGIN AELTYPE := LSP1; INXTYPE := NIL;
             PCKDARR := PACKFLAG; FORM := ARRAYS; 
             FTYPE := FALSE; CONFORMANT := FALSE
            END;
           LSP1 := LSP; 
           SIMPLETYPE(FSYS+[COMMA,RBRACK,OFSY],LSP2); 
           IF LSP2 <> NIL THEN
            IF LSP2^.FORM <= SUBRANGE THEN
             IF LSP2 = REALPTR THEN ERROR(112)
             ELSE LSP^.INXTYPE := LSP2
            ELSE ERROR(113);
           EXITLOOP := SY <> COMMA; 
           IF NOT EXITLOOP THEN INSYMBOL
          UNTIL EXITLOOP; 
          EXPECTSYMBOL(RBRACK,12);
          EXPECTSYMBOL(OFSY,8); 
          TYP(FSYS,LSP);
          IF LSP <> NIL THEN (* REVERSE POINTERS, COMPUTE SIZE *) 
           BEGIN LSIZE := LSP^.SIZE;
            REPEAT
             WITH LSP1^ DO
              BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
               FTYPE := LSP^.FTYPE; 
               IF INXTYPE <> NIL THEN 
                BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); 
                 NROFELS := LMAX - LMIN + 1;
                 IF (NROFELS <= 0) OR (NROFELS > MAXINT) THEN 
                  NROFELS := MAXINT;
                 IF (LSIZE.WORDS > 0)OR NOT PACKFLAG THEN 
                  BEGIN T := FULLWORDS(LSIZE);
                   IF (NROFELS >= MAXADDR) OR (T >= MAXADDR) THEN 
                    LSIZE.WORDS := MAXADDR
                   ELSE LSIZE.WORDS := NROFELS * T; 
                   LSIZE.BITS := 0; PARTWORDELS := FALSE
                  END 
                 ELSE 
                  BEGIN 
                   IF LSIZE.BITS > 0 THEN 
                    T := WORDSIZE DIV LSIZE.BITS
                   ELSE T := 1; 
                   T1 := NROFELS MOD T; 
                   IF (T1 = 0)AND(T*LSIZE.BITS < WORDSIZE) THEN T1 := T;
                   W := (NROFELS - T1) DIV T; 
                   B := T1*LSIZE.BITS;
                   (* NOTE- ORD(TRUE)=1 AND ORD(FALSE)=0 *) 
                   IF W + ORD(B <> 0) > MAXADDR THEN
                    BEGIN W := MAXADDR; B := 0 END; 
                   LSIZE.WORDS := W; LSIZE.BITS := B; 
                   IF T > 1 THEN
                    BEGIN PARTWORDELS := TRUE;
                     ELSPERWORD := T
                    END 
                   ELSE PARTWORDELS := FALSE
                  END 
                END;
               SIZE := LSIZE
              END (*WITH LSP1^*) ;
             LSP := LSP1; LSP1 := LSP2
            UNTIL LSP1 = NIL
           END (*LSP <> NIL*) 
         END
        ELSE
  (*RECORD*)
         IF SY = RECORDSY THEN
          BEGIN INSYMBOL; 
           OLDTOP := TOP;  LSCOPE := THISSCOPE; 
           IF HIGHSCOPE = SCOPEMAX THEN ERROR(252)
           ELSE HIGHSCOPE := HIGHSCOPE + 1; 
           THISSCOPE := HIGHSCOPE;
           IF TOP < DISPLIMIT THEN
            BEGIN TOP := TOP + 1; 
             WITH DISPLAY[TOP] DO 
              BEGIN FNAME := NIL; REGION := DREC; FFWPTR := FWPTR END;
             FWPTR := NIL 
            END 
           ELSE ERROR(250); 
           WITH DISPL DO
            BEGIN WORDS := 0; BITS := 0 END;
           FILEDISPL := DISPL;
           FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,LCP,LFILTYP);
           NEW(LSP,RECORDS);
           WITH LSP^ DO 
            BEGIN  FORM := RECORDS;  PCKDREC := PACKFLAG; 
             FIELDS := DISPLAY[TOP].FNAME; FTYPE := LFILTYP;
             FSTFLD := LCP; RECVAR := LSP1; SIZE := DISPL;
             IF LFILTYP THEN (* ALTER FIELD OFFSETS *)
              BEGIN SIZE.WORDS := INCRADDR(SIZE.WORDS,FILEDISPL.WORDS); 
               FIXFIELDALLOCATION(LCP,LSP1,FILEDISPL.WORDS) 
              END 
            END;
           IF FWPTR = NIL THEN FWPTR := DISPLAY[TOP].FFWPTR 
           ELSE 
            IF TOP <> OLDTOP THEN 
             BEGIN  LCP := FWPTR; 
              WHILE LCP^.NEXT <> NIL DO LCP := LCP^.NEXT; 
              LCP^.NEXT := DISPLAY[TOP].FFWPTR
             END; 
           THISSCOPE := LSCOPE; 
           TOP := OLDTOP; 
           EXPECTSYMBOL(ENDSY,13) 
          END 
         ELSE 
  (*SET*) 
         IF SY = SETSY THEN 
           BEGIN INSYMBOL;
            EXPECTSYMBOL(OFSY,8); 
            SIMPLETYPE(FSYS,LSP1);
            IF LSP1 <> NIL THEN 
             IF LSP1^.FORM > SUBRANGE THEN
              BEGIN ERROR(115); LSP1 := NIL END 
             ELSE 
              IF LSP1 = REALPTR THEN ERROR(114) 
              ELSE
               IF LSP1 = INTPTR THEN
                ERROR(169)
               ELSE 
                BEGIN GETBOUNDS(LSP1,LMIN,LMAX);
                 IF (LMIN < 0)OR (LMAX > 58) THEN ERROR(169); 
                 (*IMPLEMENTATION RESTRICTION TO ONE WORD SETS*)
                 IF LMAX < LMIN THEN
                  WITH LSP1^ DO MAX.IVAL := MIN.IVAL; 
                 NEW(LSP,POWER);
                 WITH LSP^, SIZE DO 
                  BEGIN ELSET := LSP1;
                   IF PACKFLAG THEN PCKDSET := [PCKD] 
                   ELSE PCKDSET := [UNPCKD];
                   FORM := POWER; FTYPE := FALSE; 
                   IF LMAX >= 58 THEN 
                    BEGIN WORDS := 1; BITS := 0 END 
                   ELSE 
                    BEGIN WORDS := 0; BITS := LMAX + 1 END
                  END 
                END 
           END
          ELSE
  (*FILE*) IF SY = FILESY THEN
            BEGIN INSYMBOL; 
             EXPECTSYMBOL(OFSY,8);
             TYP(FSYS,LSP1);
             IF LSP1 <> NIL THEN (* COMPUTE IMPL.-DEP. FILE SIZE *) 
              BEGIN LRL := FULLWORDS(LSP1^.SIZE); 
               IF LRL <= 1 THEN LRL := 1
              END 
             ELSE LRL := 1; 
             NEW(LSP,FILES);
             WITH LSP^ DO 
              BEGIN FILTYPE := LSP1; FORM := FILES; FTYPE := TRUE;
               SEGFILE := SEGFLAG;
               BASEFILE := LSP; 
               TEXTFILE := FALSE; 
               PCKDFIL := PACKFLAG; 
               T := ((BUFFSZ + LRL - 1) DIV LRL + 1) * LRL; 
               IF T > MAXADDR THEN BSIZE := MAXADDR ELSE BSIZE := T;
               WITH SIZE DO 
                BEGIN 
                 WORDS := EFETSZ; 
                 BITS := 0
                END 
              END;
             IF LSP1 <> NIL THEN
              IF LSP1^.FTYPE THEN 
               BEGIN ERROR(108); LSP^.FILTYPE := NIL END; 
            END;
        END 
       END; 
     CHECKCONTEXT(FSYS,6,[])
    END;
   FSP := LSP 
  END (*TYP*) ; 
  
  PROCEDURE LABELDECLARATION; 
   LABEL 1; 
   VAR LLP: LBP; EXITLOOP: BOOLEAN; 
  BEGIN 
   (*LOOP UNTIL SY <> COMMA:*)
   REPEAT 
    IF SY = INTCONST THEN 
     BEGIN
      IF IVAL > MAXLABEL THEN ERROR(163); 
      LLP := FSTLABP; 
      WHILE LLP <> FLABP DO 
       IF LLP^.LABVAL = IVAL THEN 
        BEGIN ERROR(166); GOTO 1 END
       ELSE LLP := LLP^.NEXTLAB;
      NEW(LLP); 
      WITH LLP^ DO
       BEGIN LABVAL := IVAL; EPT := EPT1; EPT1 := TENBLANKS;
        NEXTLAB := FSTLABP; LABLEV := LEVEL; DEFINED := FALSE;
        ACCESSIBLE := TRUE;  LABSTMTLEVEL := 0; 
        FSTOCC := NIL 
       END; 
      FSTLABP := LLP; 
  1:  INSYMBOL; 
     END
    ELSE ERROR(15); 
    CHECKCONTEXT(FSYS+[COMMA,SEMICOLON],6,[]);
    EXITLOOP := SY <> COMMA;
    IF NOT EXITLOOP THEN INSYMBOL 
   UNTIL EXITLOOP;
   EXPECTSYMBOL(SEMICOLON,14) 
  END (*LABELDECLARATION*) ;
  
  PROCEDURE CONSTDECLARATION; 
   VAR LCP: CTP; LSP: STP; LVALU: VALU; 
  BEGIN 
   IF SY <> IDENT THEN
    BEGIN ERROR(2); SKIP(FSYS+[IDENT]) END; 
   WHILE SY = IDENT DO
    BEGIN NEW(LCP,KONST); 
     WITH LCP^ DO 
      BEGIN COPYID(LCP); IDTYPE := NIL; NEXT := NIL;
       KLASS := KONST 
      END;
     INSYMBOL;
     IF OP = EQOP THEN INSYMBOL ELSE ERROR(16); 
     CONSTANT(FSYS+[SEMICOLON],LSP,LVALU);
     ENTERID(LCP,BLCK); 
     LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
     IF SY = SEMICOLON THEN 
      BEGIN INSYMBOL; 
       CHECKCONTEXT(FSYS+[IDENT],6,[])
      END 
     ELSE ERROR(14) 
    END 
  END (*CONSTDECLARATION*) ;
  
  PROCEDURE TYPEDECLARATION;
   VAR LCP,LCP1,LCP2: CTP;  LSP: STP;  LID: IDNAME;  GOTONE: BOOLEAN; 
  BEGIN 
   INTYPEDEFINITION := TRUE;
   IF SY <> IDENT THEN
    BEGIN ERROR(2); SKIP(FSYS+[IDENT]) END; 
   WHILE SY = IDENT DO
    BEGIN NEW(LCP,TYPES); 
     WITH LCP^ DO 
      BEGIN COPYID(LCP); IDTYPE := NIL; KLASS := TYPES END; 
     INSYMBOL;
     IF OP = EQOP THEN INSYMBOL ELSE ERROR(16); 
     TYP(FSYS+[SEMICOLON],LSP); 
     LCP^.IDTYPE := LSP;
     LCP1 := FWPTR;  GOTONE := FALSE; 
     WHILE LCP1 <> NIL DO (*HAS ANY FORWARD REFERENCE BEEN SATISFIED?*) 
      BEGIN 
       IF COMPAREIDS(LCP1^.NAME,LCP^.NAME) = EQUALTO THEN 
        BEGIN 
         LCP1^.IDTYPE^.ELTYPE := LSP;  GOTONE := TRUE;
         IF LCP1 <> FWPTR THEN
          LCP2^.NEXT := LCP1^.NEXT
         ELSE FWPTR := LCP1^.NEXT;
        END 
       ELSE LCP2 := LCP1; 
       LCP1 := LCP1^.NEXT 
      END;
     ENTERID(LCP,BLCK); 
     IF GOTONE THEN LCP^.LASTUSESCOPE := THISSCOPE; 
     IF SY = SEMICOLON THEN 
      BEGIN INSYMBOL; 
       CHECKCONTEXT(FSYS+[IDENT],6,[])
      END 
     ELSE ERROR(14) 
    END;
   LID := ID;  LCP := NIL;
   WHILE FWPTR <> NIL DO
    BEGIN  LCP1 := FWPTR;  FWPTR := FWPTR^.NEXT;
     ID := LCP1^.NAME;  SEARCHID([TYPES,UNKNOWNID],LCP2); 
     IF LCP2 = NIL THEN (* UNDEFINED *) 
      BEGIN  LCP1^.NEXT := LCP;  LCP := LCP1  END 
     ELSE  (* CAN RESOLVE *)
      BEGIN  LCP1^.IDTYPE^.ELTYPE := LCP2^.IDTYPE;
       (* DISPOSE(LCP1,TYPES) *)
      END 
    END;
   IF LCP <> NIL THEN 
    BEGIN  ERROR(117);
     REPEAT  FLAGERROR; 
      WRITELN(' UNDEFINED TYPE: '); WRITEID(LCP^.NAME); 
      (* LCP1 := LCP; *)
      LCP := LCP^.NEXT; 
      (* DISPOSE(LCP1,TYPES) *) 
     UNTIL LCP = NIL
    END;
   ID := LID;  INTYPEDEFINITION := FALSE
  END (*TYPEDECLARATION*) ; 
  
  PROCEDURE VARDECLARATION; 
   VAR LCP,NXT: CTP; LSP: STP; EXITLOOP: BOOLEAN; 
  BEGIN NXT := NIL; 
   REPEAT 
    (*LOOP UNTIL SY <> COMMA:*) 
    REPEAT
     IF SY = IDENT THEN 
      BEGIN NEW(LCP,VARS);
       WITH LCP^ DO 
        BEGIN COPYID(LCP); NEXT := NXT; KLASS := VARS;
         IDTYPE := NIL; VINIT := FALSE; VKIND := DRCT;
         VLEV := LEVEL; CONFORMNT := FALSE; 
         FIRSTINPARMGROUP := FALSE; 
         THREAT := FALSE; CONTROLVAR := FALSE;
        END;
       ENTERID(LCP,BLCK); 
       NXT := LCP;
       INSYMBOL;
      END 
     ELSE ERROR(2); 
     CHECKCONTEXT(FSYS+[COMMA,COLON]+TYPEDELS,6,[SEMICOLON]); 
     EXITLOOP := SY <> COMMA; 
     IF NOT EXITLOOP THEN INSYMBOL
    UNTIL EXITLOOP; 
    EXPECTSYMBOL(COLON,5);
    TYP(FSYS+[SEMICOLON]+TYPEDELS,LSP); 
    WHILE NXT <> NIL DO 
     WITH  NXT^ DO
      BEGIN IDTYPE := LSP; VADDR := LC; 
       IF LSP <> NIL THEN LC := LC + FULLWORDS(LSP^.SIZE);
       IF LC > MAXADDR THEN 
        BEGIN LC := 0; ERROR(261) END;
       NXT := NEXT
      END;
    IF SY = SEMICOLON THEN
     BEGIN INSYMBOL;
      CHECKCONTEXT(FSYS+[IDENT],6,[]) 
     END
    ELSE ERROR(14)
   UNTIL (SY <> IDENT)AND NOT (SY IN TYPEDELS); 
  END (*VARDECLARATION*) ;
  
  PROCEDURE VALUEDECLARATION; 
   VAR LASTADDR: ADDRRANGE; 
       LSP: STP;
       LCP: CTP;
       TEXTTAB: ARRAY[0..15] OF VALU; 
       THIST: 0..15;
       IDW: PACKED RECORD CASE BOOLEAN OF 
             FALSE: (I:  INTEGER);
             TRUE:  (CN: 0..7777B;
                     WC: 0..7777B;
                     LR: 0..777777B;
                     L : 0..777777B)
             END; 
  
  
   PROCEDURE PUTTEXTTAB;
    VAR I: INTEGER; 
   BEGIN (* PUTTEXTTAB *) 
    IF THIST <> 0 THEN
     BEGIN IDW.WC := THIST + 1; 
      VALUES^^ := IDW.I; PUT(VALUES^);
      VALUES^^ := 0;     PUT(VALUES^);
      FOR I := 1 TO THIST DO
       BEGIN VALUES^^ := TEXTTAB[I].IVAL; 
        PUT(VALUES^)
       END; 
      THIST := 0
     END
   END (* PUTTEXTTAB *);
  
  
   PROCEDURE VALUESPECIFICATION(FSYS: SETOFSYS; FSP: STP; 
                FWRD: ADDRRANGE; FBIT: BITRANGE; FPCKD: BOOLEAN); 
    VAR LCP: CTP; 
        LSP,LSP1: STP;
        LVALU: VALU;
        LSYS: SETOFSYS; 
        WRDS: ADDRRANGE;
        BITS: BITRANGE; 
        RIGHTADJ: BOOLEAN;
        MARK: MARKER; 
  
  
    PROCEDURE EMITVALUE(FVALU: VALU); 
     VAR L,R: BITRANGE; 
    BEGIN (* EMITVALUE *) 
     IF FWRD <> LASTADDR THEN 
      BEGIN 
       IF (FWRD <> LASTADDR+1) OR (THIST = 15) THEN 
        BEGIN PUTTEXTTAB; IDW.L := FWRD END;
       THIST := THIST + 1;
       TEXTTAB[THIST].IVAL := 0;
       LASTADDR := FWRD 
      END;
     IF FPCKD AND (WRDS = 0) THEN 
      BEGIN (* MASK AND ROTATE VALUE INTO ITS FIELD *)
       IF RIGHTADJ THEN BEGIN L := BITS-1; R := 0 END 
       ELSE BEGIN L := WORDSIZE-1; R := WORDSIZE-BITS END;
       FVALU.IVAL := PORTION(FVALU.IVAL,L,R); 
       FVALU.IVAL := ROTATE(FVALU.IVAL,WORDSIZE - FBIT - BITS)
      END;
     TEXTTAB[THIST].IVAL := MERGE(TEXTTAB[THIST],FVALU);
    END (* EMITVALUE *);
  
  
    PROCEDURE EMITSTRING(FCSP: CTAILP); 
     VAR LVALU: VALU; 
         LRIGHTADJ: BOOLEAN;
    BEGIN (* EMITSTRING *)
     LRIGHTADJ := RIGHTADJ; 
     RIGHTADJ := FALSE; 
     WHILE FCSP <> NIL DO 
      BEGIN LVALU.IVAL := FCSP^.CSVAL;
       EMITVALUE(LVALU);
       IF NOT FPCKD THEN FWRD := FWRD + 1;
       FCSP := FCSP^.NXTCSP 
      END;
     RIGHTADJ := LRIGHTADJ
    END (* EMITSTRING *); 
  
  
    PROCEDURE CHECKRANGE(FSP1,FSP2: STP; FVALU: VALU);
     VAR LMIN,LMAX: INTEGER;
    BEGIN (* CHECKRANGE *)
     IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN
      IF COMPTYPES(FSP1,FSP2) THEN
       BEGIN
        IF (FSP1^.FORM <= SUBRANGE) AND 
           (FSP1 <> INTPTR) AND (FSP1 <> REALPTR) THEN
         BEGIN GETBOUNDS(FSP1,LMIN,LMAX); 
          IF (FVALU.IVAL < LMIN) OR (FVALU.IVAL > LMAX) THEN ERROR(303) 
         END
       END
      ELSE ERROR(145) 
    END (* CHECKRANGE *); 
  
  
    PROCEDURE SKIPSTRUCTUREDVALUE( INSY : BOOLEAN );
    BEGIN (* SKIPSTRUCTUREDVALUE *) 
     IF INSY THEN INSYMBOL; 
     VALUESPECIFICATION(LSYS+[OFSY],NIL,0,0,FALSE); 
     WHILE SY IN [COMMA,OFSY] DO
      BEGIN INSYMBOL; VALUESPECIFICATION(LSYS+[OFSY],NIL,0,0,FALSE) END 
    END (* SKIPSTRUCTUREDVALUE *);
  
  
    PROCEDURE RECORDVALUE;
     VAR LCP: CTP;
         LSP,LSP1: STP; 
         LVALU: VALU; 
         FOUND: BOOLEAN;
         LWRD: ADDRRANGE; 
         LBIT,BIT: BITRANGE;
         EXITLOOP: BOOLEAN; 
    BEGIN (* RECORDVALUE *) 
     WITH FSP^ DO 
      BEGIN LCP := FSTFLD; LSP := RECVAR END; 
     LWRD := FWRD; LBIT := FBIT;
     INSYMBOL;
     IF SY <> RPARENT THEN
      REPEAT
       IF LCP = NIL THEN
        IF LSP = NIL THEN 
         BEGIN ERROR(42); (* TOO MANY VALUES SPECIFIED *) 
          SKIPSTRUCTUREDVALUE(FALSE)
         END
        ELSE (* LSP <> NIL *) 
         BEGIN WITH LSP^ DO 
          IF TAGFIELDP <> NIL THEN
           WITH TAGFIELDP^ DO 
            BEGIN CONSTANT(LSYS,LSP1,LVALU);
             CHECKRANGE(IDTYPE,LSP1,LVALU); 
             IF (NAME.TEN <> TENBLANKS) AND (IDTYPE <> NIL) THEN
              BEGIN 
               WITH IDTYPE^ DO
                BEGIN WRDS := SIZE.WORDS; BITS := SIZE.BITS END;
               FWRD := LWRD + FLDADDR;
               FPCKD := PCKDFLD;
               IF FPCKD THEN FBIT := LBIT + BITADDR;
               EMITVALUE(LVALU) 
              END;
             LSP1 := LSP^.FSTVAR; 
             FOUND := FALSE;
             WHILE (LSP1 <> NIL) AND NOT FOUND DO 
              IF LSP1^.VARVAL.IVAL = LVALU.IVAL THEN FOUND := TRUE
              ELSE LSP1 := LSP1^.NXTVAR;
             IF FOUND THEN
              WITH LSP1^ DO 
               BEGIN LCP := FSTVARFLD;
                LSP := SUBVAR 
               END
             ELSE BEGIN ERROR(158);  LSP := NIL END 
            END (* TAGFIELDP <> NIL, WITH TAGFIELDP^ *) 
          ELSE SKIPSTRUCTUREDVALUE(FALSE) 
         END (* LSP <> NIL *) 
       ELSE (* LCP <> NIL *)
        WITH LCP^ DO
         BEGIN IF PCKDFLD THEN BIT := LBIT+BITADDR ELSE BIT := 0; 
          VALUESPECIFICATION(LSYS,IDTYPE,LWRD+FLDADDR,BIT,PCKDFLD); 
          LCP := NEXT 
         END; 
       EXITLOOP := SY <> COMMA; 
       IF NOT EXITLOOP THEN INSYMBOL
      UNTIL EXITLOOP; 
     IF (LCP <> NIL) OR (LSP <> NIL) THEN ERROR(41) (*TOO FEW VALUES*)
    END (* RECORDVALUE *);
  
  
    PROCEDURE ARRAYVALUE; 
     TYPE REPLKIND = 1..4;
     VAR EL,TEMP,REPCNT,LMIN,LMAX: INTEGER; 
         LVALU: VALU; 
         LCP: CTP;
         LSP: STP;
         CONSTVALUE: BOOLEAN; 
         LWRD,NWRDS: ADDRRANGE; 
         REPL: PACKED RECORD CASE REPLKIND OF 
                1: (I    : INTEGER);
                2: (CN   : 0..7777B;
                    WC   : 0..7777B;
                    CR   : 0..77777777B;
                    IM   : 0..7777B); 
                3: (INC  : 0..77777777777B; 
                    SR   : 0..777B; 
                    SADDR: 0..777777B); 
                4: (REP  : 0..777777B;
                    BSZ  : 0..77777B; 
                    DR   : 0..777B; 
                    DADDR: 0..777777B)
                END;
    BEGIN (* ARRAYVALUE *)
     WITH FSP^ DO 
      BEGIN REPCNT := 0;
       WITH AELTYPE^ DO 
        BEGIN WRDS := SIZE.WORDS; 
         BITS := SIZE.BITS; 
         NWRDS := FULLWORDS(SIZE) 
        END;
       FPCKD := PCKDARR;
       IF FPCKD THEN FPCKD := PARTWORDELS;
       GETBOUNDS(INXTYPE,LMIN,LMAX);
       EL := LMIN;
       REPEAT 
          IF REPCNT = 0 THEN
           BEGIN INSYMBOL;
            IF SY = IDENT THEN
             BEGIN SEARCHID([KONST,UNKNOWNID],LCP); 
              CONSTVALUE := LCP <> NIL
             END
            ELSE CONSTVALUE := SY IN CONSTBEGSYS; 
            IF CONSTVALUE THEN
             BEGIN CONSTANT(LSYS+[OFSY],LSP,LVALU); 
              IF SY = OFSY THEN 
               BEGIN REPCNT := 1; 
                IF COMPTYPES(LSP,INTPTR) THEN 
                 IF LVALU.IVAL > 0 THEN REPCNT := LVALU.IVAL
                 ELSE ERROR(45) (* REPETITION FACTOR MUST BE > 0 *) 
                ELSE ERROR(145);
                INSYMBOL; 
                IF FPCKD THEN 
                 BEGIN TEMP := TEXTTAB[THIST].IVAL; 
                  TEXTTAB[THIST].IVAL := 0; 
                  VALUESPECIFICATION(LSYS,AELTYPE,LASTADDR,0,TRUE); 
                  LVALU.IVAL := ROTATE(TEXTTAB[THIST].IVAL,BITS); 
                  TEXTTAB[THIST].IVAL := TEMP;
                  EMITVALUE(LVALU); 
                  REPCNT := REPCNT - 1
                 END
                ELSE (* NOT FPCKD *)
                 BEGIN VALUESPECIFICATION(LSYS,AELTYPE,FWRD,0,FALSE); 
                  IF REPCNT > 1 THEN
                   BEGIN PUTTEXTTAB;
                    WITH REPL DO
                     BEGIN CN := 4300B;  (* REPL TABLE *) 
                      WC := 2;  CR := 0;  IM := 1;
                      VALUES^^ := I; PUT(VALUES^);
                      INC := NWRDS;  SR := 1;  SADDR := FWRD; 
                      VALUES^^ := I; PUT(VALUES^);
                      REP := REPCNT - 1;  BSZ := NWRDS;  DR := 1; 
                      DADDR := FWRD + NWRDS;
                      VALUES^^ := I; PUT(VALUES^) 
                     END; 
                    FWRD := FWRD + (REPCNT-1) * NWRDS;
                    EL := EL + REPCNT - 1 
                   END (* REPCNT > 1 *);
                  REPCNT := 0 
                 END (* NOT FPCKD *)
               END
              ELSE (* SY <> OFSY *) 
               BEGIN CHECKRANGE(AELTYPE,LSP,LVALU); 
                IF STRING(LSP) THEN 
                 BEGIN LWRD := FWRD;
                  EMITSTRING(LVALU.VALP); 
                  FWRD := LWRD
                 END
                ELSE EMITVALUE(LVALU) 
               END
             END
            ELSE (* NOT CONSTVALUE *) 
             VALUESPECIFICATION(LSYS,AELTYPE,FWRD,FBIT,FPCKD) 
           END
          ELSE (* REPCNT <> 0 *)
           BEGIN EMITVALUE(LVALU);
            REPCNT := REPCNT - 1
           END; 
          IF FPCKD THEN 
           IF FBIT + BITS + BITS > WORDSIZE THEN
            BEGIN FBIT := 0; FWRD := FWRD + 1 END 
           ELSE FBIT := FBIT + BITS 
          ELSE FWRD := FWRD + NWRDS;
          IF EL > LMAX THEN 
           BEGIN ERROR(42); (* TOO MANY VALUES SPECIFIED *) 
            REPCNT := 0;
            IF SY = COMMA THEN SKIPSTRUCTUREDVALUE(TRUE)
           END; 
          EL := EL + 1
       UNTIL (SY <> COMMA) AND (REPCNT = 0);
       IF EL <= LMAX THEN ERROR(41) (* TOO FEW VALUES SPECIFIED *)
      END (* WITH FSP^ *) 
    END (* ARRAYVALUE *); 
  
  
    PROCEDURE SETVALUE; 
     VAR LOELEMENT,HIELEMENT: INTEGER;
         EXITLOOP: BOOLEAN; 
         LVALU: VALU; 
         LSP: STP;
  
  
     PROCEDURE SETELEMENT(FSYS: SETOFSYS; VAR ELEMENT: INTEGER);
      VAR LSP1: STP;
          LVALU: VALU;
     BEGIN (* SETELEMENT *) 
      CONSTANT(FSYS,LSP1,LVALU);
      ELEMENT := 0; 
      IF LSP1 <> NIL THEN 
       WITH LSP1^ DO
        IF FORM <= SUBRANGE THEN
         IF LSP1 <> REALPTR THEN
          BEGIN ELEMENT := LVALU.IVAL;
           CHECKRANGE(LSP,LSP1,LVALU) 
          END 
         ELSE ERROR(114)
        ELSE ERROR(113) 
     END (* SETELEMENT *);
  
  
    BEGIN (* SETVALUE *)
     LVALU.PVAL := [];
     LSP := NIL;
     IF FSP <> NIL THEN 
      WITH FSP^ DO
       IF FORM <> POWER THEN ERROR(145) 
       ELSE LSP := ELSET; 
     INSYMBOL;
     IF SY <> RBRACK THEN 
      REPEAT SETELEMENT(FSYS+[DOTDOT,COMMA,RBRACK],LOELEMENT);
       IF SY = DOTDOT THEN
        BEGIN INSYMBOL; 
         SETELEMENT(FSYS+[COMMA,RBRACK],HIELEMENT); 
         LVALU.PVAL := LVALU.PVAL + [LOELEMENT..HIELEMENT]
        END 
       ELSE LVALU.PVAL := LVALU.PVAL + [LOELEMENT]; 
       EXITLOOP := SY <> COMMA; 
       IF NOT EXITLOOP THEN INSYMBOL
      UNTIL EXITLOOP; 
      EMITVALUE(LVALU); 
     EXPECTSYMBOL(RBRACK,12)
    END (* SETVALUE *); 
  
  
   BEGIN (* VALUESPECIFICATION *) 
    NEW(MARK);
    IF FSP <> NIL THEN WITH FSP^ DO 
     BEGIN WRDS := SIZE.WORDS; BITS := SIZE.BITS END; 
    LSYS := FSYS+[COMMA,RPARENT]; 
    RIGHTADJ := TRUE; 
    CHECKCONTEXT(VALSPECBEGSYS,6,FSYS); 
    IF SY IN VALSPECBEGSYS THEN 
     BEGIN
      IF SY = IDENT THEN
       BEGIN SEARCHID([KONST,TYPES],LCP); 
        IF LCP^.KLASS = TYPES THEN
         BEGIN
          IF FSP <> NIL THEN
           BEGIN
            IF NOT COMPTYPES(FSP,LCP^.IDTYPE) THEN ERROR(145) 
           END
          ELSE FSP := LCP^.IDTYPE;
          INSYMBOL; 
          IF SY <> LPARENT THEN 
           BEGIN ERROR(9); IF SY = IDENT THEN SEARCHID([KONST],LCP) END 
         END
       END (* SY = IDENT *);
      IF SY = LPARENT THEN
       BEGIN
        IF FSP = NIL THEN SKIPSTRUCTUREDVALUE(TRUE) 
        ELSE
         WITH FSP^ DO 
          IF FORM = RECORDS THEN RECORDVALUE
          ELSE
           IF FORM = ARRAYS THEN ARRAYVALUE 
           ELSE 
            BEGIN ERROR(44); (* TYPE IS NEITHER ARRAY NOR RECORD *) 
             SKIPSTRUCTUREDVALUE(TRUE)
            END;
        EXPECTSYMBOL(RPARENT,4) 
       END
      ELSE (* SY <> LPARENT *)
       IF SY = LBRACK THEN SETVALUE 
       ELSE 
        BEGIN 
         IF SY = NILSY THEN 
          BEGIN LSP := NILPTR;
           LVALU.IVAL := NILP; INSYMBOL 
          END 
         ELSE CONSTANT(FSYS,LSP,LVALU); 
         IF LSP <> NIL THEN 
          BEGIN CHECKRANGE(FSP,LSP,LVALU);
           IF STRING(LSP) THEN EMITSTRING(LVALU.VALP) 
           ELSE EMITVALUE(LVALU)
          END 
        END;
      CHECKCONTEXT(FSYS,6,[]) 
     END (* SY IN VALSPECBEGSYS *) ;
    RELEASE(MARK) 
   END (* VALUESPECIFICATION *);
  
  
  BEGIN (* VALUEDECLARATION *)
   IF LEVEL = 1 THEN
    BEGIN LASTADDR := 0; THIST := 0;
     IDW.I := 0; IDW.CN := 4000B; (* TEXT TABLE *); IDW.LR := 1;
     CHECKCONTEXT([IDENT],2,FSYS);
     IF VALUES = NIL THEN NEW(VALUES);
     WHILE SY = IDENT DO
      BEGIN SEARCHID([VARS],LCP); 
       WITH LCP^ DO 
        BEGIN IF VINIT THEN ERROR(43); (* INITIALIZED TWICE *)
         VINIT := TRUE; 
         LSP := IDTYPE; 
         IF LSP <> NIL THEN 
          IF LSP^.FORM = FILES THEN 
           BEGIN ERROR(108); LSP := NIL END;
         INSYMBOL;
         IF OP = EQOP THEN INSYMBOL ELSE ERROR(16); 
         VALUESPECIFICATION(FSYS+[SEMICOLON],LSP,VADDR,0,FALSE) 
        END;
       IF SY = SEMICOLON THEN 
        BEGIN INSYMBOL; CHECKCONTEXT(FSYS+[IDENT],6,[]) END 
       ELSE ERROR(14) 
      END (* WHILE *);
     PUTTEXTTAB 
    END (* LEVEL = 1 *) 
   ELSE 
    BEGIN ERROR(40); (* VALUE PART ALLOWED ONLY IN MAIN PROGRAM *)
     SKIP(FSYS) 
    END 
  END (* VALUEDECLARATION *); 
  
  PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL);
   VAR OLDLEV: LEVRANGE;  LSY: SYMBOL;  LCP,LCP1: CTP;  LSP: STP; 
     FORW: BOOLEAN; OLDTOP: DISPRANGE;
     LLC: ADDRRANGE;  LMARK: MARKER;
     MULTIWORDVALUEPARAMETER: BOOLEAN;
  
   PROCEDURE PFHEADER(HSYS: SETOFSYS; FSY: SYMBOL; VAR FCP: CTP;
                      VAR FORW: BOOLEAN; FKIND: IDKIND);
    (* GATHER PROCEDURE/FUNCTION HEADER.  FSY SPECIFIES WHETHER IT IS 
       A PROCEDURE OR FUNCTION, FKIND SPECIFIES WHETHER IT IS AN ACTUAL 
       PROC/FUNC OR A FORMAL PARAMETER.  THE PARAMETER LIST IS
       RETURNED IN FCP, AND FORW INDICATES IF IT IS FORWARD DECLARED. *)
    VAR LCP,LCP1,LCP2: CTP; LSP: STP; 
        LKLASS: IDCLASS;
  
    PROCEDURE PARAMETERLIST(PSYS: SETOFSYS; VAR FPAR: CTP); 
     (* GATHER A PARAMETER LIST, RETURNING IT IN FPAR. *) 
    VAR LCP,LCP1,LCP2,LCP3: CTP; LSP,LSP1,LSP2: STP; LKIND: DRCTINDRCT; 
      SZ: INTEGER; LSY: SYMBOL; LFORW: BOOLEAN; 
      OLDTOP: DISPRANGE; LLC: ADDRRANGE; LSCOPE: SCOPERANGE;
      EXITLOOP,CONFORMFLAG: BOOLEAN;
  
     PROCEDURE CNFARRAYSCHEMA(VAR FSP: STP);
      VAR LSP,LSP1,LSP2: STP; LSIZE: ADDRRANGE; 
          PACKFLAG,EXITLOOP: BOOLEAN; T: INTEGER; 
  
      PROCEDURE INDEXTYPESPECIFICATION(VAR FSP: STP); 
       VAR LSP1,LSP2: STP; LCP1,LCP2,LCP3: CTP; 
  
       PROCEDURE BOUNDDECLARATION(VAR FCP: CTP);
        VAR LCP: CTP; 
       BEGIN (* BOUNDDECLARATION *) 
        IF SY = IDENT THEN
         BEGIN NEW(LCP,BOUNDID);
          WITH LCP^ DO
           BEGIN COPYID(LCP); IDTYPE := NIL; NEXT := NIL; 
            KLASS := BOUNDID; 
            BADDR := 0; BLEV := LEVEL + ORD(LEVEL < MAXLEVEL) 
           END; 
          ENTERID(LCP,PFPAR); INSYMBOL
         END
        ELSE
         BEGIN ERROR(222); LCP := NIL;
          SKIP(FSYS+[DOTDOT,IDENT,COLON,RBRACK])
         END; 
        FCP := LCP
       END (* BOUNDDECLARATION *);
  
      BEGIN (* INDEXTYPESPECIFICATION *)
       BOUNDDECLARATION(LCP1);
       EXPECTSYMBOL(DOTDOT,21); 
       BOUNDDECLARATION(LCP2);
       EXPECTSYMBOL(COLON,5); 
       IF SY = IDENT THEN 
        BEGIN SEARCHID([TYPES],LCP3); 
         LSP2 := LCP3^.IDTYPE;
         IF LSP2 <> NIL THEN
          IF (LSP2^.FORM > SUBRANGE) OR (LSP2 = REALPTR) THEN 
           BEGIN LSP2 := NIL; ERROR(223) END; 
         INSYMBOL 
        END 
       ELSE BEGIN ERROR(2); LSP2 := NIL END;
       IF LCP1 <> NIL THEN LCP1^.IDTYPE := LSP2;
       IF LCP2 <> NIL THEN LCP2^.IDTYPE := LSP2;
       NEW(LSP1,BOUNDDESC); 
       WITH LSP1^ DO
        BEGIN FORM := BOUNDDESC; FTYPE := FALSE;
         SIZE.WORDS := 0; SIZE.BITS := 0; BOUNDTYPE := LSP2;
         LOWBOUND := LCP1; HIGHBOUND := LCP2
        END;
       FSP := LSP1
      END (* INDEXTYPESPECIFICATION *); 
  
     BEGIN (* CNFARRAYSCHEMA *) 
      IF SY = PACKEDSY THEN 
       BEGIN PACKFLAG := TRUE; INSYMBOL END 
      ELSE PACKFLAG := FALSE; 
      IF SY = ARRAYSY THEN
       BEGIN LSP1 := NIL; 
        INSYMBOL; EXPECTSYMBOL(LBRACK,11);
        (*LOOP UNTIL SY <> SEMICOLON:*) 
        REPEAT INDEXTYPESPECIFICATION(LSP2);
         NEW(LSP,ARRAYS); 
         WITH LSP^ DO 
          BEGIN FORM := ARRAYS; 
           AELTYPE := LSP1; INXTYPE := LSP2; FTYPE := FALSE;
           PCKDARR := PACKFLAG; CONFORMANT := TRUE
          END;
         LSP1 := LSP; 
         EXITLOOP := SY <> SEMICOLON; 
         IF NOT EXITLOOP THEN 
          BEGIN INSYMBOL; IF PACKFLAG THEN ERROR(220) END 
        UNTIL EXITLOOP; 
        EXPECTSYMBOL(RBRACK,12); EXPECTSYMBOL(OFSY,8);
        IF SY = IDENT THEN
         BEGIN SEARCHID([TYPES],LCP); 
          LSP := LCP^.IDTYPE; INSYMBOL
         END
        ELSE
         BEGIN IF PACKFLAG THEN ERROR(220); 
          CNFARRAYSCHEMA(LSP) 
         END
       END
      ELSE BEGIN ERROR(221); LSP := NIL END;
      (*REVERSE POINTERS, COMPUTE SIZE, SET PARTWORDELS+ELSPERWORD*)
      IF LSP <> NIL THEN
       BEGIN LSIZE := 0;
        IF CONFORMARRAY(LSP) THEN LSIZE := LSP^.SIZE.WORDS; 
        REPEAT
         WITH LSP1^ DO
          BEGIN LSP2 := AELTYPE; AELTYPE := LSP; FTYPE := LSP^.FTYPE; 
           LSIZE := LSIZE + 3; SIZE.WORDS := LSIZE; SIZE.BITS := 0; 
           IF PCKDARR THEN
            IF LSP^.SIZE.WORDS > 0 THEN PARTWORDELS := FALSE
            ELSE
             IF LSP^.SIZE.BITS > 0 THEN 
              BEGIN T := WORDSIZE DIV LSP^.SIZE.BITS; 
               IF T > 1 THEN
                BEGIN PARTWORDELS := TRUE; ELSPERWORD := T END
               ELSE PARTWORDELS := FALSE
              END 
             ELSE PARTWORDELS := FALSE
          END;
         LSP := LSP1; LSP1 := LSP2
        UNTIL LSP1 = NIL
       END; 
      FSP := LSP
     END (* CNFARRAYSCHEMA *);
  
    BEGIN (* PARAMETERLIST *) LCP1 := NIL;
     CHECKCONTEXT(PSYS+[LPARENT],7,FSYS); 
     IF SY = LPARENT THEN 
      BEGIN IF FORW THEN ERROR(119);
       OLDTOP := TOP; 
       IF TOP < DISPLIMIT THEN
        BEGIN TOP := TOP + 1; 
         WITH DISPLAY[TOP] DO 
          BEGIN FNAME := NIL; REGION := PFPAR END 
        END 
       ELSE ERROR(250); 
       LSCOPE := THISSCOPE; 
       IF HIGHSCOPE = SCOPEMAX THEN ERROR(252)
       ELSE HIGHSCOPE := HIGHSCOPE + 1; 
       THISSCOPE := HIGHSCOPE;
       INSYMBOL;
       IF NOT (SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN 
        BEGIN ERROR(7); SKIP(FSYS+[IDENT,RPARENT]) END; 
       WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO
        BEGIN 
         IF SY IN [PROCEDURESY,FUNCTIONSY] THEN 
          BEGIN 
           LSY := SY; INSYMBOL; LLC := LC;
           PFHEADER(HSYS+[RPARENT],LSY,LCP,LFORW,FORMAL); 
           LCP^.PFADDR := LLC; LC := LLC + 1; 
           LCP^.NEXT := LCP1; LCP1 := LCP 
          END 
         ELSE 
          BEGIN LCP2 := LCP1; LSP := NIL; 
           IF SY = VARSY THEN 
            BEGIN LKIND := INDRCT; INSYMBOL END 
           ELSE LKIND := DRCT;
           (*LOOP UNTIL SY <> COMMA:*)
           REPEAT 
            IF SY = IDENT THEN
             BEGIN NEW(LCP,VARS); 
              WITH LCP^ DO
               BEGIN COPYID(LCP); IDTYPE := NIL; KLASS := VARS; 
                VKIND := LKIND; NEXT := LCP1; 
                VLEV := LEVEL + ORD(LEVEL < MAXLEVEL);
                VADDR := LC; THREAT := FALSE; CONTROLVAR := FALSE;
                FIRSTINPARMGROUP := (LCP1 = LCP2) 
               END; 
              ENTERID(LCP,PFPAR); 
              LCP1 := LCP; LC := LC + 1;
              INSYMBOL; 
             END
            ELSE ERROR(2);
            IF NOT (SY IN [COMMA,COLON]) THEN 
             BEGIN ERROR(7); SKIP(FSYS+[COMMA,SEMICOLON,RPARENT]) 
             END; 
            EXITLOOP := SY <> COMMA;
            IF NOT EXITLOOP THEN INSYMBOL 
           UNTIL EXITLOOP;
           IF SY = COLON THEN 
            BEGIN INSYMBOL; 
             IF SY = IDENT THEN 
              BEGIN SEARCHID([TYPES],LCP);
               LSP := LCP^.IDTYPE; INSYMBOL 
              END 
             ELSE CNFARRAYSCHEMA(LSP);
             IF LSP <> NIL THEN 
              IF LKIND = DRCT THEN
               BEGIN
                IF LSP^.FTYPE THEN ERROR(121);
                MULTIWORDVALUEPARAMETER := MULTIWORDVALUEPARAMETER
                                        OR (FULLWORDS(LSP^.SIZE) > 1) 
               END; 
             CHECKCONTEXT([SEMICOLON,RPARENT],7,FSYS) 
            END 
           ELSE ERROR(5); 
           LCP3 := LCP1; CONFORMFLAG := CONFORMARRAY(LSP);
           WHILE LCP3 <> LCP2 DO
            BEGIN LCP3^.IDTYPE := LSP;
             LCP3^.CONFORMNT := CONFORMFLAG; LCP3 := LCP3^.NEXT 
            END 
          END;
         IF SY = SEMICOLON THEN 
          BEGIN INSYMBOL; 
           IF NOT (SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN 
            BEGIN ERROR(7); SKIP(FSYS+[IDENT,RPARENT]) END
          END 
        END (* WHILE *);
       (* CHECK FOR POTENTIAL STACK/HEAP COLLISION *) 
       IF LC >= MINFB THEN ERROR(263);
       IF SY = RPARENT THEN 
        BEGIN INSYMBOL; 
         CHECKCONTEXT(PSYS+FSYS,6,[]) 
        END 
       ELSE ERROR(4); 
       LCP3 := NIL; 
       (*REVERSE POINTERS AND RESERVE LOCAL CELLS FOR COPIES OF MULTI-
        WORD NON-CONFORMANT VALUES AND CONFORMANT-ARRAY DESCRIPTORS*) 
       WHILE LCP1 <> NIL DO 
        WITH LCP1^ DO 
         BEGIN LCP2 := NEXT; NEXT := LCP3;
          IF KLASS = VARS THEN
           IF IDTYPE <> NIL THEN
            IF CONFORMNT THEN 
             BEGIN
              IF FIRSTINPARMGROUP THEN
               BEGIN (* SET DESCADDR, BOUNDID ADDRESSES *)
                LSP := IDTYPE; LLC := LC; 
                REPEAT
                 LSP1 := LSP^.INXTYPE; LSP^.DESCADDR := LLC;
                 IF LSP1 <> NIL THEN
                  WITH LSP1^ DO 
                   BEGIN
                    IF LOWBOUND <> NIL THEN LOWBOUND^.BADDR := LLC+2; 
                    IF HIGHBOUND <> NIL THEN HIGHBOUND^.BADDR := LLC+1
                   END; 
                 LLC := LLC+3; LSP := LSP^.AELTYPE; 
                 EXITLOOP := TRUE;
                 IF LSP <> NIL THEN 
                  IF LSP^.FORM = ARRAYS THEN
                   IF LSP^.CONFORMANT THEN EXITLOOP := FALSE
                UNTIL EXITLOOP; 
                LC := LLC 
               END
             END
            ELSE
             BEGIN SZ := FULLWORDS(IDTYPE^.SIZE); 
              IF (VKIND = DRCT)AND (SZ <> 1) THEN 
               BEGIN VADDR := LC; LC := LC + SZ END 
             END; 
          LCP3 := LCP1; LCP1 := LCP2
         END; 
       TOP := OLDTOP; THISSCOPE := LSCOPE;
       FPAR := LCP3 
      END 
     ELSE FPAR := NIL 
    END (* PARAMETERLIST *);
  
    PROCEDURE PFNAME(FI: INTEGER);
     (* CREATE INTERNAL NAME FOR PROC/FUNC FROM FI *) 
     VAR K,L: INTEGER;
    BEGIN 
     FOR K := 7 DOWNTO 4 DO 
      BEGIN L := FI DIV 8;
       PNAME[K] := CHR(ORD('0') + FI - 8 * L);
       FI := L
      END 
    END (* PFNAME *); 
  
   BEGIN (* PFHEADER *) 
    LC := PFLC; 
    IF FSY = PROCEDURESY THEN LKLASS := PROC ELSE LKLASS := FUNC; 
    IF SY = IDENT THEN (* DECIDE WHETHER FORWARD *) 
     BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); 
      IF LCP <> NIL THEN
       WITH LCP^ DO 
        BEGIN 
         FORW := KLASS = LKLASS;
         IF FORW THEN FORW := (PFDECL = FORWDECL) AND (PFKIND = ACTUAL) 
                          AND (FKIND = ACTUAL); 
         IF NOT FORW THEN ERROR(160)
        END 
      ELSE FORW := FALSE; 
      IF NOT FORW THEN
       BEGIN
        IF FKIND = ACTUAL THEN NEW(LCP,PROC,USERDECLARED,ACTUAL)
        ELSE NEW(LCP,PROC,USERDECLARED,FORMAL); 
        WITH LCP^ DO
         BEGIN COPYID(LCP); IDTYPE := NIL; NEXT := NIL; 
          KLASS := LKLASS; PFDECKIND := USERDECLARED; PFKIND := FKIND;
          PFLEV := LEVEL + ORD((FKIND=FORMAL) AND (LEVEL<MAXLEVEL));
          KLASS := LKLASS; PFXOPT := XPARMAX; 
          IF FKIND = ACTUAL THEN
           BEGIN PFDECL := DECL;
            IF PCNT = 7777B THEN ERROR(264) ELSE PCNT := PCNT + 1;
            IF EPT1 = TENBLANKS THEN
             IF EXTON THEN EPT := ID.TEN
             ELSE BEGIN PFNAME(PCNT); EPT := PNAME END
            ELSE EPT := EPT1
           END
         END; 
        IF FKIND = ACTUAL THEN ENTERID(LCP,BLCK)
        ELSE ENTERID(LCP,PFPAR) 
       END
      ELSE
        WITH LCP^ DO LC := FIRSTVAR + ORD(KLASS = FUNC);
      INSYMBOL
     END
    ELSE BEGIN ERROR(2); LCP := UFCTPTR END;
    IF LKLASS = PROC THEN PARAMETERLIST(HSYS,LCP1)
    ELSE
     BEGIN PARAMETERLIST(HSYS+[COLON],LCP1);
      IF SY = COLON THEN
       BEGIN INSYMBOL;
        IF SY = IDENT THEN
         BEGIN IF FORW THEN ERROR(122); 
          SEARCHID([TYPES],LCP2); 
          LSP := LCP2^.IDTYPE;
          LCP^.IDTYPE := LSP; 
          IF LSP <> NIL THEN
           IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER]) THEN 
            BEGIN ERROR(120); LCP^.IDTYPE := NIL END; 
          INSYMBOL
         END
        ELSE BEGIN ERROR(2); SKIP(FSYS+HSYS) END
       END
      ELSE (* SY <> COLON *)
       IF NOT FORW THEN ERROR(123)
     END; 
    IF NOT FORW THEN LCP^.PARAMLIST := LCP1;
    FCP := LCP
   END (* PFHEADER *);
  
  BEGIN (*PROCEDUREDECLARATION*)
   LLC := LC; DP := TRUE; 
   MULTIWORDVALUEPARAMETER := FALSE;
   PFHEADER([SEMICOLON],FSY,LCP,FORW,ACTUAL); 
   WITH LCP^ DO 
    BEGIN LC := LC + ORD(KLASS = FUNC); 
     FIRSTVAR := LC 
    END;
   EXPECTSYMBOL(SEMICOLON,14);
   IF SY = IDENT THEN 
    BEGIN IF FORW THEN ERROR(161);
     WITH LCP^ DO 
      IF ID.TEN = KW[FORWARDKW] THEN
       BEGIN PFDECL := FORWDECL; LFORWCNT := LFORWCNT + 1 END 
      ELSE
       BEGIN
        IF ID.TEN = KW[EXTERNALKW] THEN 
         BEGIN EXTENSION(325); PFDECL := EXTDECL END
        ELSE
         IF ID.TEN = KW[FORTRANKW] THEN 
          BEGIN EXTENSION(325); PFDECL := FTNDECL;
           IF MULTIWORDVALUEPARAMETER THEN ERROR(240) 
          END 
         ELSE BEGIN ERROR(162); PFDECL := EXTDECL END;
        IF EPT1 = TENBLANKS THEN EPT := NAME.TEN
       END; 
     INSYMBOL;
     EXPECTSYMBOL(SEMICOLON,14);
     CHECKCONTEXT(FSYS,6,[])
    END 
   ELSE 
    BEGIN LCP^.PFDECL := DECL;
     IF FORW THEN LFORWCNT := LFORWCNT - 1; 
     OLDLEV := LEVEL;  OLDTOP := TOP; 
     IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251); 
     IF TOP < DISPLIMIT THEN
      BEGIN  TOP := TOP + 1;
       WITH DISPLAY[TOP] DO 
        BEGIN  FNAME := LCP^.PARAMLIST;  REGION := BLCK;
         PFCP := LCP;  ASSIGNED := FALSE
        END 
      END 
     ELSE ERROR(250); 
     (* BLOCKSCOPE = THISSCOPE *) 
     IF HIGHSCOPE = SCOPEMAX THEN ERROR(252)
     ELSE HIGHSCOPE := HIGHSCOPE + 1; 
     THISSCOPE := HIGHSCOPE;
     NEW(LMARK);
     BLOCK(FSYS,SEMICOLON,LCP); 
     IF (LCP^.KLASS = FUNC) AND NOT DISPLAY[TOP].ASSIGNED THEN
      ERROR(185); 
     IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
     IF TOP <> OLDTOP THEN RELEASE(LMARK);
     LEVEL := OLDLEV;  TOP := OLDTOP; 
     THISSCOPE := BLOCKSCOPE
    END;
   LC := LLC; 
  END (*PROCEDUREDECLARATION*) ;
  
  
(*$L'PROCEDURE / FUNCTION BODY PROCESSOR.' *) 
  
  
  PROCEDURE BODY(FSYS: SETOFSYS); 
   TYPE RCODERANGE = 0..RCODEMAX; 
      CODEP = ^CODESEGMENT; 
      CODESEGMENT = RECORD NXTSEG: CODEP; 
                      RCODE: ARRAY [RCODERANGE] OF INTEGER; 
                      CODE: ARRAY [CODERANGE] OF INTEGER
                    END;
  
      CSTKIND = (NOP,PUREP,POSP,NEGP);
      CSTREC = PACKED RECORD
           CASE CKIND : CSTKIND OF
            NOP: ();
            PUREP: (EXP: BITRANGE); 
            POSP, 
            NEGP:  (EXP1,EXP2: BITRANGE)
           END; 
      REGSET = SET OF REGNR;
  
  
   VAR
     BONUS: ARRAY [SHRTCST..INDVAR] OF INTEGER; 
     CSEGP: CODEP;
     PMDCODE : INTEGER; 
     BLOCKLENGTH,ENTRYPOINT : INTEGER;
     LCP: CTP; LFSTOCC: LOCOFREF; 
     LP: CTAILP;
     I,K: REGNR;
     LPL,LPL1,LPL2,LPL3 : PLACE;
     LCMAX,LDISP,LSZ,LDESC,LINDEX,CC : ADDRRANGE; 
     RCIX: RCODERANGE; RCP: 1..15;
     LASTOP : OPCODE; 
     LASTI : REGNR; 
     LOCP: LOCOFREF; LCSP: CSP; 
     EXFILP: EXTFILEP;
     EXTFILE,DYNFILE,FIRSTFILE: BOOLEAN;
     BUFFERS,NP: INTEGER; 
     STMTLEVEL: ADDRRANGE;
  
   PROCEDURE NOOP;
   BEGIN (* NOOP *) 
    WITH PC DO
     WHILE CP < 4 DO
      BEGIN CBUF := CBUF * 100000B + NOI[ODD(CP)];
       RBUF := 2 * RBUF; CP := CP + 1 
      END;
    LASTOP := NO
   END (* NOOP *);
  
   PROCEDURE PUTREL(R: INTEGER);
    VAR SEGP: CODEP;
   BEGIN CSEGP^.RCODE[RCIX] := RBUF; RBUF := R; RCP := 1; 
    WITH PC DO
     IF CIX = CODEMAX THEN
      BEGIN NEW(SEGP); SEGP^.NXTSEG := CSEGP; CSEGP := SEGP;
       CIX := 0; SIX := SIX + 1; RCIX := 0
      END;
     RCIX := RCIX + 1 
   END (*PUTREL*) ; 
  
   PROCEDURE SHORTNAME(FNAME: ALFA; VAR F1NAME: ALFA);
    VAR I: 1..ALFALENG; 
   BEGIN I := ALFALENG; 
    IF FNAME <> TENBLANKS THEN
     WHILE (FNAME[I] = ' ')OR (I > 7) DO
      BEGIN FNAME[I] := CHR(0); I := I - 1 END; 
    F1NAME := FNAME 
   END (*SHORTNAME*); 
  
   PROCEDURE SEARCHEXTID(FNAME: ALFA);
    (* RETURNS POINTER TO FNAME-ENTRY IN EXT *) 
  
    PROCEDURE ALLOCID;
     BEGIN NEW(EXT);
      WITH EXT^ DO
       BEGIN
        L := NIL; R := NIL; REF := NIL; EXID := FNAME;
        EXTIDX := EXTIDX + 1
       END
     END; 
  
    BEGIN SHORTNAME(FNAME,FNAME); 
    IF EXTROOT = NIL THEN 
     BEGIN ALLOCID; EXTROOT := EXT END
    ELSE
     BEGIN EXT := EXTROOT;
      WHILE EXT^.EXID <> FNAME DO WITH EXT^ DO
       IF EXID < FNAME THEN 
        IF R = NIL THEN BEGIN ALLOCID; R := EXT END ELSE EXT := R 
       ELSE 
        IF L = NIL THEN BEGIN ALLOCID; L:= EXT END ELSE EXT := L
     END
    END;
  
   PROCEDURE GEN30(FOP: OPCODE; FI,FJ: REGNR; FK: ADDRFIELD;
                   FR: RELOCATION); 
      FORWARD;
  
   PROCEDURE CHECKLINENUM;
   (* ASSUMES PMD=PMDON *)
   VAR EXTL : EXTIDP; 
   BEGIN IF SETLINENUM
    THEN BEGIN SETLINENUM := FALSE; 
     EXTL := EXT; 
     EXT := NIL;
     GEN30(SABPK,0,0,LINENUM,ABSR); 
     EXT := EXTL
     END
   END (* CHECKLINENUM *);
  
  
   PROCEDURE GEN15(FOP: OPCODE; FI,FJ: REGNR; FK: BITRANGE);
   BEGIN (* GEN15 *)
    IF PMD = PMDON THEN CHECKLINENUM; 
    LASTOP := FOP; LASTI := FI; 
    WITH PC DO
     IF CP <> 4 THEN
      BEGIN CP := CP + 1; 
       CBUF := CBUF * 100B + ORD(FOP);
       RBUF := RBUF * 2 
      END 
     ELSE 
      BEGIN CSEGP^.CODE[CIX] := CBUF; 
       CBUF := ORD(FOP); CP := 1; 
       IF RCP = 15 THEN PUTREL(0) 
       ELSE BEGIN RBUF := 2 * RBUF; RCP := RCP + 1 END; 
       CIX := CIX + 1; IC := IC + 1 
      END;
    CBUF := ((10B * CBUF + FI) * 10B + FJ) * 10B + FK 
   END (* GEN15 *); 
  
   PROCEDURE GEN30; 
    VAR MAXPR: ADDRRANGE; 
     EXTRP: EXTREFP;
   BEGIN (* GEN30 *)
    IF PMD = PMDON THEN CHECKLINENUM; 
    IF FR IN [VARR,GLOBLR,TERAR] THEN 
     BEGIN SEARCHEXTID(EXTNAMES[FR]); FR := ABSR END; 
    WITH PC DO
     IF CP < 3 THEN 
      BEGIN CBUF := CBUF * 100B + ORD(FOP); 
       RBUF := RBUF * 4 + ORD(FR);
       CP := CP + 2 
      END 
     ELSE 
      BEGIN IF CP = 3 THEN NOOP;
       CSEGP^.CODE[CIX] := CBUF;
       CBUF := ORD(FOP); CP := 2; 
       IF RCP = 15 THEN PUTREL(ORD(FR)) 
       ELSE BEGIN RBUF := RBUF * 4 + ORD(FR); RCP := RCP + 1 END; 
       CIX := CIX + 1; IC := IC + 1 
      END;
    LASTOP := FOP; LASTI := FI; 
    IF FK < 0 THEN FK := FK + 777777B;
    CBUF := ((CBUF * 10B + FI) * 10B + FJ) * 1000000B + FK; 
    IF EXT <> NIL THEN
     BEGIN NEW(EXTRP); EXTRX := EXTRX + 1;
      WITH EXTRP^,EXT^ DO 
       BEGIN LINK := REF; 
        REF := EXTRP; 
        LOC := ((8 - PC.CP) * 1000B + 1) * 1000000B + IC - 1; 
        EXT := NIL
       END
     END
  END (* GEN30 *);
  
   PROCEDURE INS(FIC: INTEGER; FPL: PLACE); 
    VAR SEGP: CODEP; I: INTEGER;
   BEGIN IF FIC < 0 THEN FIC := 777777B + FIC;
    WITH FPL DO 
     BEGIN IF (SIX=PC.SIX)AND(CIX=PC.CIX) THEN CP := 4 - PC.CP + CP;
      CASE CP OF
       1: FIC := FIC*1000000000000000B; 
       2: FIC := FIC*10000000000B;
       3: FIC := FIC*100000B; 
       4: 
      END;
      IF SIX = PC.SIX THEN
       BEGIN IF CIX = PC.CIX THEN CBUF := CBUF + FIC
             ELSE WITH CSEGP^ DO CODE[CIX] := CODE[CIX] + FIC 
       END
      ELSE
       BEGIN SEGP := CSEGP; 
        FOR I := PC.SIX - 1 DOWNTO SIX DO SEGP := SEGP^.NXTSEG; 
        WITH SEGP^ DO CODE[CIX] := CODE[CIX] + FIC
       END
     END
   END (*INS*) ;
  
   PROCEDURE LINKOCC(VAR FPTR: LOCOFREF); 
    VAR LOCP: LOCOFREF; 
   BEGIN NEW(LOCP); 
    WITH LOCP^, PC DO 
     BEGIN NXTREF := FPTR; FPTR := LOCP;
      LOC := PC 
     END
   END (*LINKOCC*) ;
  
   PROCEDURE GEN60(FC:INTEGER); 
   VAR I:SHRTINT; 
   BEGIN NOOP;
   WITH PC DO 
   BEGIN
    CSEGP^.CODE[CIX] := CBUF; CBUF := FC; 
    IF RCP = 15 THEN PUTREL(0)
    ELSE BEGIN RBUF := RBUF*16; RCP := RCP + 1 END; 
    CIX := CIX + 1; IC := IC + 1
   END
   END (*GEN60*); 
  
   PROCEDURE INITFUNCTION;
   (* INITIALIZE THE FUNCTION-RESULT CELL IN THE STACK TO 
      60000000000000377776B.  THIS PROCEDURE MAY BE EXTENDED
      TO INITIALIZE THE WHOLE STACK. *) 
   BEGIN
    GEN30(SXBPK,7,0,377776B,ABSR) (* FOR POINTERS *); 
    GEN15(MXJK,6,0,2) (* FOR INTEGERS AND REALS *); 
    GEN15(BXXPX,6,6,7); 
    GEN30(SABPK,6,5,FPROCP^.FIRSTVAR-1,ABSR)
   END (* INITFUNCTION *) ; 
  
   PROCEDURE PMDINFO(FCP: CTP); 
    VAR LSP: STP; I,K: INTEGER; 
  
    FUNCTION PMDTYP(FIDTYP: STP): INTEGER;
     VAR I: INTEGER;
    BEGIN 
     I := 0;
     IF FIDTYP <> NIL THEN
      BEGIN IF FIDTYP^.FORM <= POINTER THEN 
        IF FIDTYP^.FORM = POINTER THEN
         I := PMDUPTR + ORD(FIDTYP^.DBG) (* PMDUPTR+1=PMDCPTR *)
        ELSE IF COMPTYPES(FIDTYP,INTPTR) THEN I := PMDINT 
        ELSE IF FIDTYP = REALPTR THEN I := PMDREAL
        ELSE IF COMPTYPES(FIDTYP,CHARPTR) THEN I := PMDCHAR 
        ELSE IF COMPTYPES(FIDTYP,BOOLPTR) THEN I := PMDBOOL 
        ELSE I := PMDSCAL 
       ELSE IF COMPTYPES(FIDTYP,ALFAPTR) THEN I := PMDALFA; 
       I := I * 2 
      END;
     PMDTYP := I
    END (* PMDTYP *); 
  
   BEGIN
    IF FCP <> NIL THEN
     WITH FCP^ DO 
      BEGIN PMDINFO(LLINK); 
       IF KLASS IN [VARS,BOUNDID] THEN
        BEGIN I := PMDTYP(IDTYPE);
         IF I <> 0 THEN 
          BEGIN 
           IF KLASS = VARS THEN 
            BEGIN K := VADDR; 
             IF VKIND = INDRCT THEN I := I + 1
            END 
           ELSE K := BADDR; 
           ALFINT.A := NAME.TEN; GEN60(ALFINT.I); 
           GEN60(I * 1000000B + K)
          END 
        END;
       PMDINFO(RLINK) 
      END 
   END (*PMDINFO*) ;
  
   PROCEDURE LGOHEAD(NAME: ALFA); 
    TYPE STYPE= (WORD,ADRS,NAMS); 
       B18 = 0..777777B;
    VAR PGNAME: INTEGER; I: INTEGER; LLP: LBP;
     STRUCTURES: RECORD CASE STYPE OF 
            WORD: (CVAL: INTEGER);
            NAMS: (CNAM: ALFA); 
            ADRS: (IDW: PACKED RECORD CN: 0..63;
                         WC: B18; LR: B18; L: B18 
                  END)
           END; 
   BEGIN
    WITH STRUCTURES DO
    BEGIN CVAL := 0; IDW.CN := 77B; IDW.WC := 16B;        (*PREFIX*)
     LGO^:= CVAL; PUT(LGO); SHORTNAME(NAME,CNAM); IDW.L:= 0;
     PGNAME:= CVAL; LGO^:= PGNAME; PUT(LGO);
     CNAM := TODAY; LGO^ := CVAL*100B; PUT(LGO);
     CNAM := NOW; LGO^ := CVAL*100B; PUT(LGO);
     CNAM := OSNAME;       LGO^ := CVAL; PUT(LGO);  (*OPERATING SYSTEM*)
     CNAM := COMPILERNAME; LGO^ := CVAL; PUT(LGO);  (*COMPILER VERSION*)
     CNAM := TENBLANKS;    LGO^ := CVAL; PUT(LGO);  (*UPDATE LEVEL*)
     CNAM := ' I        '; LGO^ := CVAL; PUT(LGO);  (*HARDWARE SPEC*) 
     IF LEVEL = 1 THEN
      IF NAME = PROGBLOCK THEN CNAM := 'PROGRAM   ' 
      ELSE CNAM := 'MAIN VARS ' 
     ELSE 
      IF FPROCP^.KLASS = PROC THEN CNAM := 'PROCEDURE ' 
      ELSE CNAM := 'FUNCTION  ';
                           LGO^ := CVAL; PUT(LGO);  (*MODULE TYPE*) 
     IF LEVEL = 1 THEN CNAM := PROGNAME 
     ELSE CNAM := FPROCP^.NAME.TEN; 
                           LGO^ := CVAL; PUT(LGO);  (*MODULE NAME*) 
     FOR I := 1 TO 5 DO BEGIN LGO^ := 0; PUT(LGO) END;
     CVAL := 0; IDW.CN := 70B; IDW.WC := 4;               (*LDSET*) 
     LGO^ := CVAL; PUT(LGO);
     CVAL := 0; IDW.WC := 100001B; LGO^ := CVAL; PUT(LGO);
     SHORTNAME('PASCLIB   ',CNAM); LGO^ := CVAL; PUT(LGO);
     LGO^ := 00120001000000000001B; PUT(LGO); 
     LGO^ := 60000000000200400000B; PUT(LGO); 
     CVAL:= 0; IDW.CN:= 34B;                              (*PIDL*)
     IF LEVEL = 1 THEN IDW.WC := 2 ELSE IDW.WC := 1;
     LGO^ := CVAL; PUT(LGO);
     CVAL := PGNAME; IDW.L := BLOCKLENGTH; LGO^ := CVAL; PUT(LGO);
     IF LEVEL = 1 THEN
      BEGIN 
       CNAM := TENBLANKS; IDW.L := 0; LGO^ := CVAL; PUT(LGO)
      END;
     CVAL:= 0; IDW.CN:= 36B;                              (*ENTR*)
     I := 0; (*COUNT NUMBER OF ADDITIONAL ENTRY POINTS*)
     IF NAME <> EXTNAMES[VARR] THEN BEGIN 
     LLP := FSTLABP;
     WHILE LLP <> FLABP DO
      WITH LLP^ DO
       BEGIN IF EPT <> TENBLANKS THEN I := I + 1; 
        LLP := NEXTLAB
       END; 
     END; 
     IDW.WC := 2 * (I + 1); LGO^ := CVAL; PUT(LGO); 
     LGO^ := PGNAME; PUT(LGO);
     LGO^ := 1000000B + ENTRYPOINT; 
     PUT(LGO);
     IF NAME <> EXTNAMES[VARR] THEN BEGIN 
     WHILE FSTLABP <> FLABP DO
      WITH FSTLABP^ DO
       BEGIN
        IF EPT <> TENBLANKS THEN
         BEGIN SHORTNAME(EPT,ALFINT.A); LGO^ := ALFINT.I; PUT(LGO); 
          IF DEFINED THEN 
           BEGIN CVAL := LABADDR; IDW.LR := 1; LGO^ := CVAL;
            PUT(LGO)
           END
         END; 
        IF NOT DEFINED THEN 
         BEGIN ERROR(168);
          FLAGERROR;
          WRITELN(' UNDEFINED LABEL: ',LABVAL:1); 
         END; 
        FSTLABP := NEXTLAB
       END; 
     END; 
    END;
   END (*LGOHEAD*); 
  
   PROCEDURE LGOTEXT; 
    TYPE B18 = 0..777777B;
    VAR J,DISP: 0..15;
      I,RCMAX: RCODERANGE; K: INTEGER; SEGP1,SEGP2: CODEP;
      L,LCIX: INTEGER;
      STRUCTURES: RECORD CASE BOOLEAN OF
             TRUE: (CVAL: INTEGER); 
             FALSE: (IDW: PACKED RECORD CN: 0..63;
                           WC: B18; LR: B18; L: B18 
                    END)
            END;
   BEGIN
    WITH STRUCTURES, PC DO
     BEGIN NOOP;
     WHILE RCP < 15 DO
       BEGIN RBUF := RBUF*16; RCP := RCP + 1 END; 
      WITH CSEGP^ DO
       BEGIN CODE[CIX] := CBUF; RCODE[RCIX] := RBUF END;
      SEGP1 := NIL; 
      REPEAT (* REVERSE LIST OF CODE SEGMENTS *)
       WITH CSEGP^ DO 
        BEGIN SEGP2 := NXTSEG; NXTSEG := SEGP1; 
         SEGP1 := CSEGP; CSEGP := SEGP2 
        END 
      UNTIL CSEGP = NIL;
      IDW.CN := 40B; IDW.LR := 1; IDW.WC := 20B;
      RCMAX := RCODEMAX; DISP := 15;
      WITH PC DO
      FOR K := 1 TO SIX DO
       BEGIN LCIX := 1; 
        IF K = SIX THEN RCMAX := RCIX;
        FOR I := 1 TO RCMAX DO
         BEGIN IDW.L := CADDR;
          IF (K = SIX) AND (I = RCMAX) THEN 
           BEGIN J := CIX MOD 15; 
            IF J <> 0 THEN
             BEGIN DISP := J; IDW.WC := J + 1 END 
           END; 
          LGO^ := CVAL; PUT(LGO); 
          WITH SEGP1^ DO
           BEGIN LGO^ := RCODE[I]; PUT(LGO);
            FOR L := LCIX TO LCIX + DISP - 1 DO 
             BEGIN LGO^ := CODE[L]; PUT(LGO) END; 
            CADDR := CADDR + DISP; LCIX := LCIX + 15
           END
         END; 
        SEGP1 := SEGP1^.NXTSEG
       END (*FOR K*)
     END (*WITH*) 
   END (*LGOTEXT*) ;
  
   PROCEDURE LGOEND;
    TYPE STYP = (WORD,ADRS,HLFS,NAMS);
       B18 = 0..777777B; B30 = 0..7777777777B;
       HALFS= PACKED RECORD LH: B30; RH: B30 END; 
    VAR PAR: BOOLEAN; 
       STRUCTURES: RECORD CASE STYP OF
              WORD: (CVAL: INTEGER);
              HLFS: (HS: HALFS);
              ADRS: (IDW: PACKED RECORD CN: 0..63;
                           WC: B18; LR: B18; L: B18 
                    END); 
              NAMS: (CNAM: ALFA)
             END; 
       BUFF: RECORD CASE BOOLEAN OF 
           TRUE:  (BUF0: INTEGER);
           FALSE: (BHS: HALFS)
          END;
       WORDCNT: INTEGER;
  
    PROCEDURE EXTTOLGO(PTR: EXTIDP);
     BEGIN (* PTR <> NIL *) 
      WITH PTR^,BUFF,STRUCTURES DO
       BEGIN
        IF L <> NIL THEN EXTTOLGO(L); 
        IF R <> NIL THEN EXTTOLGO(R); 
        CNAM := EXID; 
        IF PAR THEN LGO^ := CVAL ELSE 
         BEGIN BHS.RH:= HS.LH; LGO^ := BUF0; BHS.LH := HS.RH END; 
        PUT(LGO); 
        WHILE REF <> NIL DO WITH REF^ DO
         BEGIN
         IF PAR THEN BHS.LH := LOC
         ELSE BEGIN BHS.RH := LOC; LGO^ := BUF0; PUT(LGO) END;
         PAR := NOT PAR; REF := LINK
         END
       END
     END; (* EXTTOLGO *)
  
   BEGIN CODEADDR:= CODEADDR + IC;
    WITH STRUCTURES,BUFF DO 
    BEGIN 
     IF EXTROOT <> NIL THEN 
      BEGIN WORDCNT := EXTIDX + (EXTRX + 1) DIV 2;
      IF WORDCNT >= 10000B THEN ERROR(256)
      ELSE
       BEGIN CVAL := 0; IDW.CN := 44B; IDW.WC := WORDCNT; 
        LGO^ := CVAL; PUT(LGO); 
        PAR := TRUE;
        EXTTOLGO(EXTROOT);
        IF NOT PAR THEN 
         BEGIN BHS.RH := 0; LGO^ := BUF0; PUT(LGO) END
       END
      END;
     IF LEVEL = 1 THEN
     BEGIN
     CVAL:= 0; IDW.CN:= 46B; IDW.WC:= 1;                  (*XFER*)
     LGO^:= CVAL; PUT(LGO); 
     SHORTNAME(PROGBLOCK,CNAM); 
     IDW.L:= 0; LGO^:= CVAL; PUT(LGO);
     END (* XFER *);
     PUTSEG(LGO); 
    END;
   END (*LGOEND*);
  
  
   PROCEDURE LGOVALUE;
   BEGIN (* LGOVALUE *) 
    ENTRYPOINT := 0;
    BLOCKLENGTH := LCMAX; 
    LGOHEAD(EXTNAMES[VARR]);
    (* HEADER INFO: <MAINVARS> / 2,2,LCMAX / PROGNAME / COMPILERNAME *) 
    LGO^ := 40000005000001000000B;              PUT(LGO); 
    LGO^ := 0;                                  PUT(LGO); 
    ALFINT.A := '<MAINVARS>'; LGO^ := ALFINT.I; PUT(LGO); 
    LGO^ := 20000200000B + LCMAX;               PUT(LGO); 
    ALFINT.A := PROGNAME; LGO^ := ALFINT.I;     PUT(LGO); 
    ALFINT.A := COMPILERNAME; LGO^ := ALFINT.I; PUT(LGO); 
    IF VALUES <> NIL THEN 
     BEGIN RESET(VALUES^);
      WHILE NOT EOS(VALUES^) DO 
       BEGIN LGO^ := VALUES^^; PUT(LGO); GET(VALUES^) END;
      REWRITE(VALUES^)
     END; 
    PUTSEG(LGO) 
   END (* LGOVALUE *);
  
   PROCEDURE CLEARREGS; 
    VAR I: INTEGER; 
    BEGIN 
    FOR I := 0 TO 7 DO
     BEGIN
     XRGS[I].XCONT := AVAIL; ARGS[I].ACONT := UNSPECADDR; 
     IF I IN [2,3,7] THEN BRGS[I].BCONT := FREE 
     ELSE BRGS[I].BCONT := SPECPURP 
     END; 
    LEVELS := [0,1,LEVEL] 
    END; (* CLEARREGS *)
  
   PROCEDURE RJTOEXT(FNAME: ALFA);
    BEGIN 
     SEARCHEXTID(FNAME); CLEARREGS; 
     GEN30(RJ,0,0,0,ABSR); NOOP 
    END; (* RJTOEXT *)
  
   PROCEDURE ENTERCST(FCSTP: CTAILP); 
    (*ENTER CONST POINTED AT BY FCSTP INTO CONSTANT TABLE AND CHAIN 
      ACTUAL OCCURRENCE IN CODE (AT <CIX,CP>) WITH EARLIER OCCURRENCES*)
    LABEL 1,2;
    VAR LCSP: CSP; P1,P2: CTAILP; LFSTOCC: LOCOFREF;
   BEGIN LCSP := FSTCSP;
    WHILE LCSP <> NIL DO
     BEGIN P1 := LCSP^.CSTP; P2 := FCSTP; 
      WHILE (P1 <> NIL)AND (P2 <> NIL) DO 
       BEGIN IF P1^.CSVAL <> P2^.CSVAL THEN GOTO 1; 
        P1 := P1^.NXTCSP; P2 := P2^.NXTCSP
       END; 
      IF P1 = P2 THEN GOTO 2; 
   1: LCSP := LCSP^.NXTCSP
     END; 
    (*NEW ENTRY:*)
    NEW(LCSP);
    WITH LCSP^ DO 
     BEGIN NXTCSP := FSTCSP; CSTP := FCSTP; CREF := NIL END;
    FSTCSP := LCSP; 
   2: (* CHAIN OCCURRENCES: *)
    LFSTOCC := LCSP^.CREF; LINKOCC(LFSTOCC);
    LCSP^.CREF := LFSTOCC 
   END (*ENTERCST*) ; 
  
   PROCEDURE OPENFL(FSP : STP; FADDR : ADDRRANGE);
   (* OPEN FILE WITH TYPE FSP AND EFET ADDRESS FADDR *) 
    VAR I : INTEGER;
        LCSP : CTAILP;
   BEGIN (* OPENFL *) 
    WITH FSP^ DO
     BEGIN CLEARREGS; 
      IF TEXTFILE THEN I := 20B ELSE I := 0;
      IF SEGFILE THEN I := I + 100B;
      IF EXTFILE THEN WITH EXFILP^ DO 
       BEGIN I := I + 1;
        IF TERMINAL THEN I := I + 10B;
        SHORTNAME(FILENAME,ALFINT.A); 
        GEN30(SABPK,2,0,0,PROGR);  (* FORMAL FILE NAME *) 
        NEW(LCSP);
        WITH LCSP^ DO BEGIN NXTCSP := NIL; CSVAL := ALFINT.I END; 
        ENTERCST(LCSP)
       END
      ELSE RJTOEXT('P.NFN     '); 
      GEN30(SXBPK,1,0,I,ABSR);  (* DISPOSITION CODE *)
      IF TEXTFILE THEN I := FADDR + CHEFET ELSE I := FADDR + BINEFET; 
      IF DYNFILE THEN GEN30(SBBPK,3,2,I,ABSR) 
      ELSE
       BEGIN GEN30(SBBPK,3,5,I,ABSR);  (* EFET ADDRESS *) 
        COMPWS := COMPWS + BSIZE; 
        IF COMPWS > MAXADDR THEN COMPWS := MAXADDR; 
        BUFFERS := BUFFERS + BSIZE; 
        IF BUFFERS > MAXADDR THEN BUFFERS := MAXADDR
       END; 
      GEN30(SBBPK,7,0,BSIZE,ABSR);  (* BUFFER SIZE *) 
      IF EXTFILE THEN 
       BEGIN GEN15(SXBPB,6,3,1); GEN15(BXXPX,6,6,2);
        GEN30(SABPK,5,0,EXFILP^.SYSLOC,ABSR); NOOP; 
        GEN15(SAAPB,6,5,0); GEN30(TESTX,ORD(ZR),5,IC,PROGR);
        GEN15(BXX,2,5,5)
       END; 
      IF FILTYPE <> NIL THEN
       BEGIN  I := FULLWORDS(FILTYPE^.SIZE);
        IF I = 0 THEN I := 1; 
        GEN30(SXBPK,6,0,I,ABSR)  (* LRL *)
       END; 
      RJTOEXT('P.OPEN    ') 
     END
   END (* OPENFL *);
  
  
   PROCEDURE CLOSEFL(FSP : STP; FADDR : ADDRRANGE); 
   (* CLOSE FILE WITH TYPE FSP AND EFET ADDRESS FADDR *)
    VAR I : INTEGER;
   BEGIN (* CLOSEFL *)
    CLEARREGS;
    IF FSP^.TEXTFILE THEN I := FADDR + CHEFET ELSE I := FADDR + BINEFET;
    IF DYNFILE THEN GEN30(SABPK,1,2,I,ABSR) 
    ELSE GEN30(SABPK,1,5,I,ABSR);  (* EFET ADDRESS *) 
    RJTOEXT('P.CLOSE   ') 
   END (* CLOSEFL *); 
  
  
   PROCEDURE SUBFILES(FSP : STP; FADDR : ADDRRANGE; 
      PROCEDURE PROCESSFILE(FSP : STP; FADDR : ADDRRANGE) );
   (* PROCESS (OPEN OR CLOSE) ALL FILES WHICH ARE PART OF A  *) 
   (* VARIABLE WITH STRUCTURE FSP AND ADDRESS FADDR          *) 
    VAR I,LMIN,LMAX : INTEGER;
  
    PROCEDURE RECFILES(FCP: CTP;  FSP: STP);
      (* APPLY SUBFILES TO FIELD LIST FCP AND VARIANT LIST FSP. *)
    BEGIN (* RECFILES *)
     WHILE FCP <> NIL DO
      WITH FCP^ DO (* KLASS = FIELD *)
       BEGIN  SUBFILES(IDTYPE,FADDR+FLDADDR,PROCESSFILE); 
        FCP := NEXT 
       END; 
     IF FSP <> NIL THEN 
      BEGIN  FSP := FSP^.FSTVAR;
       WHILE FSP <> NIL DO
        WITH FSP^ DO  (* FORM = VARIANT *)
         BEGIN
          IF FIRSTVAL AND FTYPE THEN RECFILES(FSTVARFLD,SUBVAR);
          FSP := NXTVAR 
         END
      END 
    END (* RECFILES *); 
  
   BEGIN (* SUBFILES *) 
    IF FSP <> NIL THEN
     WITH FSP^ DO 
      IF FTYPE THEN 
       CASE FORM OF 
        RECORDS :  RECFILES(FSTFLD,RECVAR); 
        ARRAYS :  
         IF INXTYPE <> NIL THEN 
          BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); 
           FOR I := LMIN TO LMAX DO 
            BEGIN SUBFILES(AELTYPE,FADDR,PROCESSFILE);
             IF AELTYPE <> NIL THEN 
              FADDR := FADDR + AELTYPE^.SIZE.WORDS
            END 
          END;
         FILES :  
          BEGIN IF FIRSTFILE AND NOT DYNFILE THEN 
            GEN15(SBBPB,2,0,0);  (* FILE IS A LOCAL VARIABLE *) 
           FIRSTFILE := FALSE;
           PROCESSFILE(FSP,FADDR) 
          END 
         END (* CASE *) 
   END (* SUBFILES *);
  
  
   PROCEDURE ALLFILES(FCP : CTP;
      PROCEDURE PROCESSFILE(FSP : STP; FADDR : ADDRRANGE) );
   (* PROCESS (OPEN OR CLOSE) ALL FILES IN THE SYMBOL TABLE  *) 
   (* SUB-TREE WITH ROOT NODE FCP                            *) 
    LABEL 1;
   BEGIN (* ALLFILES *) 
    IF FCP <> NIL THEN
     WITH FCP^ DO 
      BEGIN ALLFILES(LLINK,PROCESSFILE); ALLFILES(RLINK,PROCESSFILE); 
       IF (KLASS = VARS)AND (VKIND = DRCT) THEN 
        BEGIN EXTFILE := FALSE; 
         IF (LEVEL = 1)AND (IDTYPE <> NIL) THEN 
          IF IDTYPE^.FORM = FILES THEN
           BEGIN EXFILP := FEXFILP; 
             WHILE EXFILP <> NIL DO 
             WITH EXFILP^ DO
              BEGIN 
               IF FILENAME = NAME.TEN THEN
                BEGIN EXTFILE := TRUE; DECLARED := TRUE;
                 GOTO 1 
                END;
               EXFILP := NXTP 
              END;
    1:      END;
         SUBFILES(IDTYPE,VADDR,PROCESSFILE) 
        END 
      END (*WITH*)
   END (* ALLFILES *);
  
   PROCEDURE ROTATEX(FI: REGNR);
    (*IF X-FI IS SHIFTED, SHIFT IT BACK*) 
   BEGIN
    WITH XRGS[FI] DO
     IF XCONT IN [SIMPVAR,INDVAR] THEN
      IF SHFTCNT <> 0 THEN
       BEGIN GEN15(LXJK,FI,0,WORDSIZE-SHFTCNT); SHFTCNT := 0
       END
   END (*ROTATEX*); 
  
   PROCEDURE DECREFX(FI: REGNR);
    (*DECREASE NUMBER OF REFERENCES TO X-FI BY ONE*)
   BEGIN
    WITH XRGS[FI] DO
     IF XCONT <> AVAIL THEN 
      IF REFNR > 0 THEN 
       BEGIN REFNR := REFNR - 1;
        IF REFNR = 0 THEN 
         IF XCONT = OTHER THEN XCONT := AVAIL 
         ELSE LASTREF := IC 
       END
   END (*DECREFX*) ;
  
   PROCEDURE BXIXJ(FI,FJ: REGNR); 
    (*AVOID GENERATION OF B XI XJ INSTRUCTIONS WHENEVER APPROPRIATE BY
     ALTERING PREVIOUSLY GENERATED INSTRUCTION*)
    VAR I: REGNR; 
   BEGIN
    IF FI <> FJ THEN
    BEGIN XRGS[FI] := XRGS[FJ]; 
     IF (LASTI = FJ) AND
        ((LASTOP IN [BXX..BXXMCX,LXBX..RXXDX,CXX]) OR 
         (LASTOP >= SXAPK)) AND 
        (XRGS[FJ].REFNR <= 1) THEN
      BEGIN 
       IF (LASTOP < SXAPK) OR (LASTOP >= SXXPB) THEN
        CBUF := CBUF - (LASTI - FI)*100B
       ELSE 
        CBUF := CBUF - (LASTI - FI)*10000B*1000B; 
       LASTI := FI; XRGS[FJ].XCONT := AVAIL 
      END 
     ELSE 
      BEGIN GEN15(BXX,FI,FJ,FJ); DECREFX(FJ); XRGS[FI].REFNR := 1;
       WITH XRGS[FJ] DO 
        IF XCONT = INDVAR THEN
         WITH XRGS[XREG] DO  REFNR := REFNR + 1;
      END;
    END 
   END (*BXIXJ*) ;
  
   PROCEDURE SAVEREFXRGS(VAR FXRGS: XRGSTATUS); 
    VAR I,J,K: REGNR; LXRGS: XRGSTATUS; 
   BEGIN LXRGS:=XRGS; CLEARREGS;
    FOR I:=0 TO 7 DO
     WITH LXRGS[I] DO 
      IF XCONT <> AVAIL THEN
       IF XCONT = INDVAR THEN 
        BEGIN WITH LXRGS[XREG] DO 
               BEGIN REFNR:=REFNR - 1;
                IF REFNR = 0 THEN XCONT:=AVAIL
               END; 
              IF REFNR = 0 THEN XCONT:=AVAIL ELSE XCONT:=OTHER
        END 
       ELSE IF REFNR = 0 THEN XCONT:=AVAIL; 
    K:=0; 
    FOR I:=6 TO 7 DO
     WITH LXRGS[I] DO 
      IF XCONT <> AVAIL THEN
       BEGIN
        IF K=0 THEN GEN30(SABPK,I,5,LC,ABSR)
               ELSE GEN15(SAAPB,7,6,1); 
        K:=K+1; J:=I
       END; 
    FOR I:=0 TO 5 DO
     WITH LXRGS[I] DO 
      IF XCONT <> AVAIL THEN
       BEGIN GEN15(BXX,7,I,I);
        IF K=0 THEN GEN30(SABPK,7,5,LC,ABSR)
               ELSE GEN15(SAAPB,7,J,1); 
        K:=K+1; J:=7
       END; 
    LC := LC + K; 
    IF LC > LCMAX THEN LCMAX := LC; 
    FXRGS := LXRGS
   END (*SAVEREFXRGS*) ;
  
   PROCEDURE RELOADREFXRGS(VAR FXRGS: XRGSTATUS); 
    VAR I,J,K,L,M: REGNR; LPL: PLACE; 
   BEGIN K := 0; M := 0;
    FOR I := 0 TO 7 DO
     BEGIN J := (I+6) MOD 8;
      WITH FXRGS[J] DO
       IF XCONT <> AVAIL THEN 
        IF REFNR <> 0 THEN
         BEGIN IF I <= 2 THEN L := 5 ELSE L := J; 
          IF K = 0 THEN 
           BEGIN GEN30(SABPK,L,5,0,ABSR); LPL := PC;
           END
          ELSE GEN15(SAAPB,L,K,1);
          IF I <= 2 THEN GEN15(BXX,J,5,5);
          XRGS[J] := FXRGS[J];
          K := L; M := M + 1
         END
     END; 
    IF M <> 0 THEN
     BEGIN LC := LC - M; INS(LC,LPL) END; 
   END (*RELOADXRGS*) ; 
  
   PROCEDURE NEEDB(VAR FI: REGNR);
    (*RETURN INDEX OF AVAILABLE B-REGISTER*)
    LABEL 1;
    VAR MAXLEV: LEVRANGE; I,NR: REGNR;
   BEGIN MAXLEV := 0; NR := 0;
    FOR I := 2 TO 7 DO
     WITH BRGS[I] DO
      CASE BCONT OF 
       FREE:  
        BEGIN NR := I; GOTO 1 END;
       BASADDR: 
        IF BLEV > MAXLEV THEN 
         BEGIN MAXLEV := BLEV; NR := I END; 
       SPECPURP:  
      END;
    LEVELS := LEVELS-[MAXLEV];
   1: BRGS[NR].BCONT := SPECPURP; FI := NR; 
    IF NR = 0 THEN ERROR(259) 
   END (*NEEDB*) ;
  
   PROCEDURE NEEDX(FREGS: REGSET; VAR FI: REGNR); 
    (* RETURN INDEX FI (FI IN FREGS) OF AVAILABLE X-REGISTER; 
     DON'T TOUCH ANY X-REG. CONTENTS*)
    (* IT IS ASSUMED THAT FREGS IS A SET OF THE FORM [FLOW..FHIGH]. 
       IF THIS IS NOT TRUE, THE FOLLOWING CODE DOES NOT WORK. *)
    LABEL 1;
    VAR I,NR: REGNR; PR,MAXPR: INTEGER; FIRSTTIME: BOOLEAN; 
    FLOW,FHIGH: REGNR;
   BEGIN MAXPR := 0; FIRSTTIME := TRUE; 
    FLOW := 0;
    WHILE NOT (FLOW IN FREGS) DO FLOW := FLOW + 1;
    FHIGH := FLOW + CARD(FREGS) - 1;
    NR := FHIGH;
    REPEAT
    FOR I := FLOW TO FHIGH DO 
     WITH XRGS[I] DO
      IF XCONT = AVAIL THEN 
       BEGIN NR := I; GOTO 1 END
      ELSE
       IF XCONT <> OTHER THEN 
        IF REFNR = 0 THEN 
         BEGIN PR := IC - LASTREF + BONUS[XCONT]; 
          IF PR > MAXPR THEN
           BEGIN MAXPR := PR; NR := I END 
         END; 
    IF MAXPR = 0 THEN 
     IF FIRSTTIME THEN
      BEGIN 
       FOR I := 0 TO 7 DO 
        WITH XRGS[I] DO 
         IF XCONT = INDVAR THEN 
          BEGIN DECREFX(XREG);
           IF REFNR = 0 THEN XCONT := AVAIL 
           ELSE 
            BEGIN IF SHFTCNT <> 0 THEN GEN15(LXJK,I,0,WORDSIZE-SHFTCNT);
             XCONT := OTHER 
            END 
          END;
       FIRSTTIME := FALSE 
      END 
     ELSE 
      BEGIN IF FLOW <> FHIGH THEN ERROR(259); MAXPR := 1 END
    UNTIL MAXPR > 0;
   1:WITH XRGS[NR] DO 
     BEGIN
      IF XCONT = INDVAR THEN DECREFX(XREG)
      ELSE
        FOR I := 1 TO 7 DO
         WITH ARGS[I] DO
          IF ACONT = INDADDR THEN 
           IF AREG = NR THEN ACONT := UNSPECADDR; 
       XCONT := OTHER; REFNR := 1 
      END;
    FI := NR
   END (*NEEDX*) ;
  
   PROCEDURE LOADBASE(FLEV: LEVRANGE; VAR FI: REGNR); 
    LABEL 1;
    VAR I: REGNR; J,K: LEVRANGE;
   BEGIN NEEDX([1..5],I); FI := I;
    IF FLEV IN LEVELS THEN GEN15(SXBPB,I,BRG[FLEV],0) 
    ELSE
     FOR J := FLEV + 1 TO LEVEL DO
      IF J IN LEVELS THEN 
       BEGIN GEN15(SABPB,I,BRG[J],0); 
        FOR K := J - 2 DOWNTO FLEV DO 
         GEN15(SAXPB,I,I,0);
        ARGS[I].ACONT := UNSPECADDR;
        GOTO 1
       END; 
 1:END (* LOADBASE *);
  
   PROCEDURE SETADDRESS(
      VAR FATTR: ATTR;   (* DESCRIBING THE ADDRESS *) 
      FSIMPIND: BOOLEAN; (* TRUE IF FATTR DESCRIBES AN INDIRECT VARIABLE
                            AND X.VWDISPL CONTAINS A SIMPLE VARIABLE AND
                            THIS CALL REPRESENTS A MEMORY REFERENCE *)
      FR: REGTYPE;       (* SELECTING A- OR X-REGISTER *) 
      FREGS: REGSET;     (* SELECTING ACCEPTABLE REGISTER NUMBERS *)
      VAR FI: REGNR);    (* RESULT REGISTER NUMBER *) 
    (* SET ADDRESS OF FATTR INTO AN A-REGISTER OR X-REGISTER. 
       IF FREGS <> [], IT DEFINES THE SET OF ACCEPTABLE REGISTER
       NUMBERS.  IN THIS CASE, A NEEDX(FREGS,FI) IS DONE. 
       IF FREGS = [], WE ASSUME THAT THE REGISTER HAS ALREADY BEEN
       ALLOCATED AND FI CONTAINS THE REGISTER NUMBER. 
       IF THE CALL TO SETADDRESS REPRESENTS A MEMORY REFERENCE
       (FR = REGA), THE REGISTER MAP IS UPDATED TO REFLECT THE CHANGE 
       IN A-REGISTER VALUE.  FOR REFERENCES TO AN 
       INDIRECT OR INDEXED VALUE (WORDACC IN [INDRCT,INXD]), THE
       NUMBER OF REFERENCES TO THE X-REGISTER WHICH CONTAINS THE
       BASE ADDRESS (VWDISPL) MAY BE DECREMENTED UNLESS IT IS 
       A STORING OPERATION (FI IN [6..7]).  THE VALUE OF
       FSIMPIND IS ONLY RELEVENT FOR A STRING OPERATION.  IN ALL
       CASES THE UPDATING OF FATTR AND THE X-REGISTER MAP IS LEFT 
       UP TO THE PROCEDURE WHICH CALLED SETADDRESS. 
    *)
    LABEL 1;
    VAR I,J,L,LAREG: REGNR; 
        LADDR: INTEGER; 
        NOTSTORING: BOOLEAN;
  
    PROCEDURE FINDAREG(FCONT: ARGSTR);
     VAR I: REGNR; D: SHRTINT;
    BEGIN (* FINDAREG *)
     LAREG := 0;
     LADDR := MAXADDR;
     WITH FATTR DO
      FOR I := 1 TO 7 DO
       WITH ARGS[I] DO
        IF ACONT = FCONT THEN 
         BEGIN
          D := MAXADDR; 
          IF FCONT = SIMPADDR THEN
           BEGIN
            IF ALEV = VLEVEL THEN D := CWDISPL - ADISPL 
           END
          ELSE
           IF AREG = VWDISPL THEN D := CWDISPL - ADISPL;
          IF ABS(D) < ABS(LADDR) THEN 
           BEGIN LADDR := D; LAREG := I END 
         END
    END (* FINDAREG *); 
  
    PROCEDURE NEED; 
    BEGIN (* NEED *)
     IF FREGS <> [] THEN NEEDX(FREGS,I) 
     ELSE I := FI 
    END (* NEED *); 
  
   BEGIN (* SETADDRESS *) 
    NOTSTORING := TRUE; 
    IF FR = REGA THEN 
     IF FREGS = [] THEN NOTSTORING := FI IN [0..5]
     ELSE NOTSTORING := FREGS <= [0..5];
    LAREG := 0; 
    WITH FATTR DO 
     IF TYPTR <> NIL THEN 
      CASE KIND OF
       CST: 
        (* MUST BE A STRING CONSTANT *) 
        BEGIN NEED; GEN30(SETINST[BPK,FR],I,0,0,PROGR); 
         IF FR = REGA THEN ARGS[I].ACONT := UNSPECADDR; 
         IF STRING(TYPTR) THEN ENTERCST(CVAL.VALP)
        END;
       VARBL: 
        CASE WORDACC OF 
         DRCT:  
          BEGIN 
           FINDAREG(SIMPADDR);
           IF ABS(LADDR) <= 1 THEN
            BEGIN NEED; 
             IF LADDR >= 0 THEN GEN15(SETINST[APB,FR],I,LAREG,LADDR)
             ELSE GEN15(SETINST[AMB,FR],I,LAREG,1)
            END 
           ELSE 
            IF VLEVEL IN LEVELS THEN
             BEGIN NEED;
              GEN30(SETINST[BPK,FR],I,BRG[VLEVEL],CWDISPL,REL[VLEVEL])
             END
            ELSE
             IF LAREG <> 0 THEN 
              BEGIN NEED; 
               GEN30(SETINST[APK,FR],I,LAREG,LADDR,ABSR)
              END 
             ELSE 
              BEGIN 
               LOADBASE(VLEVEL,J); DECREFX(J); NEED;
               GEN30(SETINST[XPK,FR],I,J,CWDISPL,ABSR)
              END;
           IF FR = REGA THEN
            WITH ARGS[I] DO 
             BEGIN ACONT := SIMPADDR; ALEV := VLEVEL; 
              ADISPL := CWDISPL 
             END; 
          END (* DRCT *) ;
         INDRCT:  
          BEGIN 
           IF NOTSTORING THEN 
            FSIMPIND := XRGS[VWDISPL].XCONT = SIMPVAR;
           IF FSIMPIND THEN 
            BEGIN 
             IF FR = REGX THEN DECREFX(VWDISPL);
             FINDAREG(INDADDR); 
             IF ABS(LADDR) <= 1 THEN
              BEGIN NEED; 
               IF LADDR >= 0 THEN 
                GEN15(SETINST[APB,FR],I,LAREG,LADDR)
               ELSE GEN15(SETINST[AMB,FR],I,LAREG,1); 
               GOTO 1 
              END 
            END 
           ELSE 
            IF NOTSTORING THEN DECREFX(VWDISPL);
           NEED;
           IF CWDISPL IN [0,1] THEN 
            GEN15(SETINST[XPB,FR],I,VWDISPL,CWDISPL)
           ELSE GEN30(SETINST[XPK,FR],I,VWDISPL,CWDISPL,ABSR);
         1:IF FR = REGA THEN
            IF FSIMPIND THEN
             WITH ARGS[I] DO
              BEGIN ACONT := INDADDR; 
               AREG := VWDISPL; ADISPL := CWDISPL 
              END 
            ELSE ARGS[I].ACONT := UNSPECADDR; 
          END (* INDRCT *) ;
         INXD:  
          BEGIN 
           IF NOTSTORING THEN DECREFX(VWDISPL); 
           IF VLEVEL IN LEVELS THEN 
            BEGIN 
             IF VLEVEL = 1 THEN 
              BEGIN NEED; 
               GEN30(SETINST[XPK,FR],I,VWDISPL,CWDISPL,VARR)
              END 
             ELSE 
              BEGIN NEEDX([0..7],J); DECREFX(J); NEED;
               IF PC.CP = 3 THEN
                BEGIN GEN15(SXXPB,J,VWDISPL,BRG[VLEVEL]); 
                 GEN30(SETINST[XPK,FR],I,J,CWDISPL,ABSR)
                END 
               ELSE 
                BEGIN GEN30(SXXPK,J,VWDISPL,CWDISPL,ABSR);
                 GEN15(SETINST[XPB,FR],I,J,BRG[VLEVEL]) 
                END 
              END 
            END 
           ELSE 
            BEGIN NEEDB(L); 
             FINDAREG(SIMPADDR);
             IF LAREG <> 0 THEN 
              BEGIN NEED; 
               GEN30(SBAPK,L,LAREG,LADDR,ABSR); 
               GEN15(SETINST[XPB,FR],I,VWDISPL,L) 
              END 
             ELSE 
              BEGIN GEN30(SBXPK,L,VWDISPL,CWDISPL,ABSR);
              LOADBASE(VLEVEL,J); DECREFX(J); NEED; 
              GEN15(SETINST[XPB,FR],I,J,L)
             END; 
             BRGS[L].BCONT := FREE
            END;
           IF FR = REGA THEN ARGS[I].ACONT := UNSPECADDR
          END (* INXD *)
        END (* CASE WORDACC OF *) ; 
       COND,EXPR: 
        NEED
      END (* CASE KIND OF *)
     ELSE NEED; 
    FI := I 
   END (* SETADDRESS *);
  
   PROCEDURE LOADADDRESS(VAR FATTR: ATTR; VAR FI: REGNR); 
    (*LOAD WORD-ADDRESS OF FATTR INTO X-FI*)
   BEGIN
    WITH FATTR DO 
     IF KIND = VARBL THEN 
      IF (WORDACC = INDRCT) AND (CWDISPL = 0) THEN FI := VWDISPL
      ELSE
       BEGIN SETADDRESS(FATTR,FALSE,REGX,[0..7],FI);
        WORDACC := INDRCT; VWDISPL := FI; CWDISPL := 0
       END
     ELSE SETADDRESS(FATTR,FALSE,REGX,[0..7],FI)
   END (*LOADADDRESS*) ;
  
   PROCEDURE LOAD(VAR FATTR: ATTR; VAR FI: REGNR); FORWARD; 
  
   PROCEDURE LOADCST(FCST: INTEGER; VAR FI: REGNR); 
   (* LOAD FCST INTO X.FI *)
   BEGIN (* LOADCST *)
    WITH CATTR DO BEGIN KIND := CST; CVAL.IVAL := FCST END; 
    LOAD(CATTR,FI)
   END (* LOADCST *); 
  
   PROCEDURE LOADMSK(FBTS: BITRANGE; VAR FI: REGNR);
   (* LOAD MASK OF FBTS BITS INTO X.FI *) 
   BEGIN LOADCST(MASK(FBTS),FI) END;
  
   PROCEDURE LOAD;
    (*LOAD FATTR INTO X-FI*)
    LABEL 1,4,6;
    VAR I,J,K: REGNR; SHRT,SIMPIND: BOOLEAN;
      BITSZ,SHIFT,MASK: BITRANGE; 
      SVAL: SHRTINT; CSHFT: INTEGER; LCSP: CTAILP;
      LCST: INTEGER; LMODE: (USRADJ,SRADJ,USLADJ);
      MSK,STR: BOOLEAN; MCST: INTEGER;
   BEGIN
    IF PMD = PMDON THEN CHECKLINENUM; 
    WITH FATTR DO 
     BEGIN
     IF TYPTR <> NIL THEN 
      CASE KIND OF
       CST: 
        BEGIN SHRT := FALSE; SVAL := 0; LCSP := NIL;
         MSK := FALSE;
         STR := STRING(TYPTR);
         IF STR THEN LCSP := CVAL.VALP
         ELSE 
          BEGIN LCST := CVAL.IVAL; (* INTERNAL VALUE OF CONSTANT *) 
           IF ABS(LCST) < TWOTO17 THEN
            BEGIN SVAL := LCST; SHRT := TRUE END
           ELSE 
            BEGIN NEW(LCSP);
             WITH LCSP^ DO
              BEGIN NXTCSP := NIL; CSVAL := LCST END
            END 
          END;
         IF SHRT THEN 
          BEGIN 
           FOR I := 0 TO 7 DO 
            WITH XRGS[I] DO 
             IF XCONT = SHRTCST THEN
              IF CSTVAL = SVAL THEN 
               BEGIN REFNR := REFNR + 1; GOTO 1 END 
          END 
         ELSE 
          FOR I := 0 TO 7 DO
           WITH XRGS[I] DO
            IF XCONT = LONGCST THEN 
             IF CPTR = LCSP THEN
              BEGIN REFNR := REFNR + 1; GOTO 1 END; 
         IF NOT (STR OR (LCST IN [0,1,2])) THEN 
          BEGIN SHIFT := 0; MASK := 0; MCST := LCST;
           WHILE NOT ODD(MCST) DO 
            BEGIN MCST := MCST DIV 2; SHIFT := SHIFT + 1 END; 
           REPEAT MCST := MCST DIV 2; SHIFT := SHIFT + 1; 
            MASK := MASK + 1
           UNTIL NOT ODD(MCST); 
           IF (MCST = 0) THEN (* MASK CONSTANT *) 
            BEGIN 
             IF LCST < 0 THEN 
              BEGIN SHIFT := SHIFT - MASK; MASK := WORDSIZE - MASK END; 
             (* DECIDE WHETHER TO USE MASK AND SHIFT *) 
             MSK := NOT SHRT OR (SHIFT = 0) OR (PC.CP = 3)
            END 
          END;
         IF MSK THEN
          BEGIN NEEDX([0..7],I);
           GEN15(MXJK,I,0,MASK);
           IF SHIFT <> 0 THEN GEN15(LXJK,I,0,SHIFT) 
          END 
         ELSE 
         IF SHRT THEN 
          BEGIN NEEDX([0..7],I);
           IF SVAL = 0 THEN GEN15(BXXMX,I,I,I)
           ELSE 
            IF SVAL = 1 THEN GEN15(SXBPB,I,1,0) 
            ELSE
             IF SVAL = 2 THEN GEN15(SXBPB,I,1,1)
             ELSE GEN30(SXBPK,I,0,SVAL,ABSR)
          END 
         ELSE 
          BEGIN NEEDX([1..5],I);
           ARGS[I].ACONT := UNSPECADDR; 
           GEN30(SABPK,I,0,0,PROGR);
           ENTERCST(LCSP) 
          END;
         WITH XRGS[I] DO
          BEGIN REFNR := 1; 
           IF SHRT THEN 
            BEGIN XCONT := SHRTCST; CSTVAL := SVAL END
           ELSE BEGIN XCONT := LONGCST; CPTR := LCSP END
          END;
   1:   END;
       VARBL: 
        BEGIN 
         CASE WORDACC OF
          DRCT: 
           BEGIN
      (* CODE DELETED FOR IF(NOT)AND(<)COMPARE EXPRESSION  *) 
      (* FOR CORRECTION OF PSR PA10037                     *) 
      (* FOR I := 0 TO 7 DO                                *) 
      (*  WITH XRGS[I] DO                                  *) 
      (*   IF XCONT = SIMPVAR THEN                         *) 
      (*    IF (XLEV = VLEVEL) AND (XADDR = CWDISPL) THEN  *) 
      (*     BEGIN REFNR := REFNR + 1; GOTO 4 END;         *) 
            SETADDRESS(FATTR,FALSE,REGA,[1..5],I);
            WITH XRGS[I] DO 
             BEGIN XCONT := SIMPVAR; REFNR := 1; VPADDR := FALSE; 
              SHFTCNT := 0; XLEV := VLEVEL; XADDR := CWDISPL
             END; 
   4:       END;
          INDRCT: 
           BEGIN SIMPIND := XRGS[VWDISPL].XCONT = SIMPVAR;
            IF SIMPIND THEN 
             FOR I := 0 TO 7 DO 
              WITH XRGS[I] DO 
               IF XCONT = INDVAR THEN 
                IF (XREG = VWDISPL) AND (XDISPL = CWDISPL) THEN 
                 BEGIN REFNR := REFNR + 1; DECREFX(VWDISPL);
                  GOTO 6
                 END; 
            SETADDRESS(FATTR,FALSE,REGA,[1..5],I);
            IF SIMPIND THEN 
             WITH XRGS[I] DO
              BEGIN XCONT := INDVAR; REFNR := 1; SHFTCNT := 0;
               XREG := VWDISPL; XDISPL := CWDISPL 
              END;
   6:      END; 
          INXD: 
           SETADDRESS(FATTR,FALSE,REGA,[1..5],I)
         END (*CASE*) ; 
         IF PCKD THEN 
          BEGIN 
           WITH TYPTR^ DO 
            BEGIN 
             IF FORM = SUBRANGE THEN
              IF MIN.IVAL < 0 THEN LMODE := SRADJ 
              ELSE LMODE := USRADJ
             ELSE 
              IF FORM IN [ARRAYS,RECORDS] THEN LMODE := USLADJ
              ELSE LMODE := USRADJ; 
             BITSZ := SIZE.BITS 
            END;
           WITH XRGS[I] DO
            IF XCONT IN [SIMPVAR,INDVAR] THEN SHIFT := SHFTCNT
            ELSE SHIFT := 0;
           IF LMODE = USLADJ THEN MASK := BITSZ 
           ELSE MASK := WORDSIZE - BITSZ; 
           CSHFT := CBDISPL - SHIFT;
           IF LMODE = USRADJ THEN CSHFT := CSHFT + BITSZ; 
           IF BITREG = XREG THEN
            BEGIN 
             IF SHIFT <> 0 THEN (*TO GUARANTEE 0 <= B-K <= 60*) 
              BEGIN GEN15(LXJK,I,0,WORDSIZE-SHIFT); 
               XRGS[I].SHFTCNT := 0; CSHFT := CSHFT + SHIFT 
              END;
             NEEDB(K);
             IF CSHFT IN [0,1] THEN GEN15(SBXPB,K,VBDISPL,CSHFT)
             ELSE GEN30(SBXPK,K,VBDISPL,CSHFT,ABSR);
             DECREFX(VBDISPL); DECREFX(I);
             NEEDX([0..7],J); GEN15(LXBX,J,K,I);
             BRGS[K].BCONT := FREE; 
             IF LMODE = SRADJ THEN GEN15(AXJK,J,0,MASK) 
             ELSE 
              BEGIN LOADMSK(MASK,K);
               IF LMODE = USRADJ THEN GEN15(BXXTCX,J,J,K) 
               ELSE GEN15(BXXTX,J,J,K); 
               DECREFX(K) 
              END;
             I := J 
            END 
           ELSE 
            BEGIN IF CSHFT < 0 THEN CSHFT := CSHFT + WORDSIZE 
             ELSE 
              IF CSHFT = WORDSIZE THEN CSHFT := 0;
             WITH XRGS[I] DO
              IF XCONT IN [SIMPVAR,INDVAR] THEN 
               IF LMODE = SRADJ THEN
                BEGIN NEEDX([0..7],J); DECREFX(I);
                 GEN15(BXX,J,I,I); I := J 
                 END
               ELSE 
                SHFTCNT := (SHFTCNT + CSHFT) MOD WORDSIZE;
             IF CSHFT <> 0 THEN GEN15(LXJK,I,0,CSHFT);
             IF LMODE = SRADJ THEN GEN15(AXJK,I,0,MASK) 
             ELSE 
              BEGIN LOADMSK(MASK,K); DECREFX(K); NEEDX([0..7],J); 
               IF LMODE = USRADJ THEN GEN15(BXXTCX,J,I,K) 
               ELSE GEN15(BXXTX,J,I,K); 
               DECREFX(I); I := J 
              END 
            END 
          END (*PCKD*)
         ELSE ROTATEX(I); 
        END;
       COND:  
        BEGIN NEEDX([0..7],I);
         IF CONDCD IN [ZR,NZ] THEN
          BEGIN LOADCST(0,K); GEN15(IXXMX,I,K,CDR); DECREFX(K); 
           IF CONDCD = ZR THEN GEN15(BXXMX,I,I,CDR) 
           ELSE GEN15(BXXMCX,I,I,CDR);
           LOADMSK(59,K); GEN15(BXXTCX,I,I,K) 
          END 
         ELSE 
          BEGIN LOADMSK(1,K); 
           IF CONDCD = PL THEN GEN15(BXXTX,I,K,CDR) 
           ELSE GEN15(BXXTCX,I,K,CDR);
           GEN15(LXJK,I,0,1)
          END;
         DECREFX(K);
         DECREFX(CDR) 
        END;
       EXPR:  
        I := EXPREG 
      END (*CASE*)
     ELSE NEEDX([0..7],I);
     KIND := EXPR; EXPREG := I
     END (*WITH FATTR*) ; 
    FI := I 
   END (*LOAD*) ; 
  
   PROCEDURE OPERATION(FOP: OPCODE; VAR FK: REGNR; FI,FJ: REGNR); 
   BEGIN DECREFX(FI); DECREFX(FJ); NEEDX([0..7],FK); GEN15(FOP,FK,FI,FJ)
   END (* OPERATION *); 
  
   PROCEDURE LOADDESC(VAR FATTR: ATTR; VAR FI: REGNR; FDISPL: SHRTINT); 
    (* LOAD THE DESCRIPTOR WORD FDISPL FOR NON-PARAMETRIC USE. *) 
    VAR LATTR: ATTR;
   BEGIN
    WITH FATTR DO 
     BEGIN LATTR.TYPTR := INTPTR; LATTR.KIND := VARBL;
      LATTR.PCKD := FALSE; LATTR.WORDACC := DRCT; 
      LATTR.VLEVEL := VLEVEL; LATTR.CWDISPL := 0; 
      IF TYPTR <> NIL THEN
       LATTR.CWDISPL := TYPTR^.DESCADDR + FDISPL
     END; 
    LOAD(LATTR,FI)
   END (*LOADDESC*) ; 
  
   PROCEDURE STORE(VAR FATTR: ATTR; FI: REGNR); 
    (*STORE X-FI AT FATTR*) 
    (*ASSUMES FATTR.KIND = VARBL*)
    VAR I,J,K,LNR: REGNR; LATTR: ATTR; LXRG: XRGSTAT; 
    L: REGNR; OP1,OP2: OPCODE; TRUNCATE: BOOLEAN; 
      BITSZ,SHIFT,MASK: BITRANGE; CSHFT: INTEGER; LCST: SHRTINT;
      LCP: POSRANGE; LADDR: INTEGER; LFTADJ,LBX,LXFICST: BOOLEAN; 
      LCLEARED : BOOLEAN; 
  
   BEGIN
    IF PMD = PMDON THEN CHECKLINENUM; 
    WITH FATTR DO 
     IF TYPTR <> NIL THEN 
      BEGIN 
       IF PCKD THEN 
        BEGIN LATTR := FATTR; 
         IF WORDACC <> DRCT THEN
          WITH XRGS[VWDISPL] DO REFNR := REFNR + 1; 
         LATTR.PCKD := FALSE; LOAD(LATTR,I);
         WITH TYPTR^ DO 
          BEGIN LFTADJ := FORM IN [ARRAYS,RECORDS]; 
           BITSZ := SIZE.BITS 
          END;
         WITH XRGS[I] DO
          IF XCONT IN [SIMPVAR,INDVAR] THEN SHIFT := SHFTCNT
          ELSE SHIFT := 0;
         IF LFTADJ THEN 
          BEGIN MASK := BITSZ; CSHFT := CBDISPL - SHIFT;
           OP1 := BXXTCX; OP2 := BXXTX
          END 
         ELSE 
          BEGIN MASK := WORDSIZE - BITSZ; 
           CSHFT := CBDISPL - SHIFT + BITSZ;
           OP1 := BXXTX; OP2 := BXXTCX
          END;
         IF BITREG = XREG THEN
          BEGIN 
           IF BITSZ < SHIFT THEN (*TO GUARANTEE 0 <= B-K <= 60*)
            BEGIN GEN15(LXJK,I,0,WORDSIZE - SHIFT); 
             XRGS[I].SHFTCNT := 0; CSHFT := CSHFT + SHIFT 
            END;
           NEEDB(K);
           IF CSHFT IN [0,1] THEN GEN15(SBXPB,K,VBDISPL,CSHFT)
           ELSE GEN30(SBXPK,K,VBDISPL,CSHFT,ABSR);
           DECREFX(VBDISPL); DECREFX(I); NEEDX([0..7],J); 
           GEN15(LXBX,J,K,I); 
          END 
         ELSE 
          BEGIN 
           IF CSHFT < 0 THEN CSHFT := CSHFT + WORDSIZE
           ELSE IF CSHFT = WORDSIZE THEN CSHFT := 0;
           IF CSHFT <> 0 THEN GEN15(LXJK,I,0,CSHFT); J := I;
           WITH XRGS[I] DO
            IF XCONT IN [SIMPVAR,INDVAR] THEN 
             BEGIN SHFTCNT := (SHFTCNT + CSHFT) MOD WORDSIZE; 
              CSHFT := 0
             END
          END;
         WITH TYPTR^ DO 
          IF FORM IN [SCALAR,SUBRANGE,POINTER] THEN 
           IF FORM = SUBRANGE THEN TRUNCATE := MIN.IVAL < 0 
           ELSE TRUNCATE := FALSE 
          ELSE TRUNCATE := TRUE;
         IF TRUNCATE THEN 
          WITH XRGS[FI] DO
           IF XCONT = SHRTCST THEN TRUNCATE := CSTVAL < 0 
           ELSE 
            IF XCONT = LONGCST THEN TRUNCATE := CPTR^.CSVAL < 0;
         LOADMSK(MASK,L); DECREFX(L); 
         GEN15(OP1,J,J,L);
         IF TRUNCATE THEN 
          BEGIN NEEDX([0..7],I); GEN15(OP2,I,FI,L); DECREFX(FI) END 
         ELSE I := FI;
         GEN15(BXXPX,J,J,I);
         IF BITREG = XREG THEN
          BEGIN GEN30(SBBPK,K,K,-WORDSIZE,ABSR); GEN15(AXBX,J,K,J); 
           BRGS[K].BCONT := FREE
          END 
         ELSE IF CSHFT <> 0 THEN GEN15(LXJK,J,0,WORDSIZE-CSHFT);
         DECREFX(I); FI := J
        END (*PCKD*) ;
      LCP := PC.CP; LNR := FI;
      IF NOT (FI IN [6,7]) THEN 
       BEGIN NEEDX([6,7],I); BXIXJ(I,FI); 
        FI := I 
       END; 
      LBX := LCP <> PC.CP;
      WITH XRGS[FI] DO
       BEGIN LXFICST := XCONT = SHRTCST;
        IF LXFICST THEN LCST := CSTVAL
        ELSE ROTATEX(FI); 
       END; 
      CASE WORDACC OF 
       DRCT:  
        BEGIN LCLEARED := FALSE;
         FOR I := 0 TO 7 DO 
          IF I <> FI THEN 
           WITH XRGS[I] DO
            IF XCONT = SIMPVAR THEN 
             IF (XLEV = VLEVEL)AND (XADDR = CWDISPL) THEN 
              BEGIN XCONT := AVAIL; LCLEARED := TRUE END; 
         IF LCLEARED THEN 
          BEGIN 
           FOR I := 0 TO 7 DO 
            WITH XRGS[I] DO 
             IF XCONT = INDVAR THEN 
              IF XRGS[XREG].XCONT = AVAIL THEN XCONT := AVAIL;
           FOR I := 1 TO 7 DO 
            WITH ARGS[I] DO 
             IF ACONT = INDADDR THEN
              IF XRGS[AREG].XCONT = AVAIL THEN
               ACONT := UNSPECADDR
          END;
         WITH LXRG DO 
          BEGIN XCONT := SIMPVAR; REFNR := 1; VPADDR := FALSE;
           XLEV := VLEVEL; XADDR := CWDISPL; SHFTCNT := 0 
          END 
        END;
       INDRCT:  
        BEGIN 
         FOR I := 0 TO 7 DO 
          IF I <> FI THEN 
           WITH XRGS[I] DO
            IF XCONT = INDVAR THEN
             IF (XREG = VWDISPL)AND (XDISPL = CWDISPL) THEN 
              BEGIN DECREFX(VWDISPL); XCONT := AVAIL END; 
         IF XRGS[VWDISPL].XCONT = SIMPVAR THEN
          WITH LXRG DO
           BEGIN XCONT := INDVAR; REFNR := 1; 
            XREG := VWDISPL; XDISPL := CWDISPL; SHFTCNT := 0
           END
         ELSE 
          WITH LXRG DO
           BEGIN XCONT := OTHER; REFNR := 1 END 
        END;
       INXD:  
        WITH LXRG DO
         BEGIN XCONT := OTHER; REFNR := 1 END 
      END (*CASE*); 
      IF WORDACC <> DRCT THEN DECREFX(VWDISPL); 
      IF LXRG.XCONT = OTHER THEN
       BEGIN
        IF NOT LXFICST AND LBX THEN 
         WITH XRGS[FI] DO 
          BEGIN IF XCONT = INDVAR THEN DECREFX(XREG); 
           XCONT := OTHER 
          END 
       END
      ELSE
       BEGIN IF LBX THEN K := LNR ELSE K := FI; 
        IF (LXRG.XCONT <> INDVAR) OR (LXRG.XREG <> K) THEN
         BEGIN
          WITH XRGS[K] DO 
           IF XCONT = INDVAR THEN DECREFX(XREG) 
           ELSE IF XCONT = SIMPVAR THEN 
                 FOR I := 0 TO 7 DO 
                  WITH XRGS[I] DO 
                   IF XCONT = INDVAR THEN 
                    IF XREG = K THEN
                     IF REFNR = 0 THEN XCONT := AVAIL 
                     ELSE XCONT := OTHER; 
           IF K = LNR THEN
            BEGIN LXRG.REFNR := XRGS[K].REFNR;
             IF LXRG.REFNR = 0 THEN LXRG.LASTREF := IC
            END;
           XRGS[K] := LXRG; 
           IF LXRG.XCONT = INDVAR THEN
            WITH XRGS[LXRG.XREG] DO REFNR := REFNR + 1; 
         END
       END; 
      SETADDRESS(FATTR,LXRG.XCONT=INDVAR,REGA,[],FI); 
      IF VLEVEL > 0 THEN
      (*UPDATE OF REGISTER CONTENTS:*)
      IF WORDACC = DRCT THEN   (*SIMPLE VAR HAS GOT NEW VALUE. DISPOSE*)
       BEGIN                  (*X-REGS CONTAINING VAR PARAMS*)
        FOR I := 0 TO 7 DO
         IF I <> FI THEN
          WITH XRGS[I] DO 
           IF XCONT = INDVAR THEN 
            IF XRGS[XREG].VPADDR THEN 
             IF XRGS[XREG].XLEV > VLEVEL THEN 
              BEGIN DECREFX(XREG);
               IF REFNR > 0 THEN XCONT := OTHER ELSE XCONT := AVAIL 
              END 
       END
      ELSE  (*ASSUME COINCIDANCE. DISPOSE X-REGS NOT CONT. SIMPLE VARS*)
       BEGIN
        FOR I := 0 TO 7 DO
         IF I <> FI THEN
          WITH XRGS[I] DO 
           IF XCONT = INDVAR THEN 
            BEGIN DECREFX(XREG);
             IF REFNR > 0 THEN XCONT := OTHER ELSE XCONT := AVAIL 
            END;
        IF XRGS[VWDISPL].VPADDR THEN   (*DISPOSE X-REGS CONTAINING*)
         BEGIN                        (*SIMPLE VARS OF LEVEL < XLEV*) 
          FOR I := 0 TO 7 DO
           IF I <> FI THEN
            WITH XRGS[I] DO 
             IF XCONT = SIMPVAR THEN
              IF XLEV < XRGS[VWDISPL].XLEV THEN 
               IF REFNR > 0 THEN XCONT := OTHER ELSE XCONT := AVAIL;
          FOR I := 1 TO 7 DO
           WITH ARGS[I] DO
            IF ACONT = INDADDR THEN 
             IF XRGS[AREG].XCONT = AVAIL THEN 
              ACONT := UNSPECADDR 
         END
       END; 
    END (*TYPTR <> NIL*); 
   DECREFX(FI)
  END (*STORE*) ; 
  
  PROCEDURE CHECKBNDS(FI: REGNR; FMIN,FMAX: INTEGER; FADDR: ADDRRANGE); 
   (*TEST X-FI AGAINST BOUNDS FMIN AND FMAX.IF OUT OF BOUNDS JUMP 
   TO FADDR*) 
   VAR I,J,K: REGNR;
  BEGIN 
   IF FMIN <> 0 THEN
    BEGIN LOADCST(FMIN,I); DECREFX(I); NEEDX([0..7],K); 
     GEN15(IXXMX,K,FI,I)
    END;
   LOADCST(FMAX,I); 
   DECREFX(I); NEEDX([0..7],J); GEN15(IXXMX,J,I,FI);
   IF FMIN <> 0 THEN
    BEGIN GEN15(BXXPX,J,J,K); DECREFX(K) END
   ELSE GEN15(BXXPX,J,J,FI);
   GEN30(TESTX,ORD(NG),J,FADDR,TERAR); DECREFX(J) 
  END (*CHECKBNDS*) ; 
  
  PROCEDURE CHECKSET(FSP: STP; VAR I: REGNR); 
   VAR LMIN, LMAX: INTEGER; J,K: REGNR; 
  BEGIN 
   GETBOUNDS(FSP^.ELSET,LMIN,LMAX); 
   IF (LMIN >= 0) AND (LMAX <= 58) THEN 
    IF GATTR.KIND = CST THEN
     BEGIN
      IF GATTR.CVAL.PVAL - [LMIN..LMAX] <> [] THEN ERROR(303);
      LOAD(GATTR,I) 
     END
    ELSE
     BEGIN LOAD(GATTR,I); 
      IF DEBUG THEN 
       BEGIN LOADCST(ROTATE(MASK(59-LMAX-LMIN),LMIN),J);
        DECREFX(J); NEEDX([0..7],K); GEN15(BXXTX,K,I,J);
        GEN30(TESTX,ORD(NZ),K,ASSERR,TERAR); DECREFX(K) 
       END
     END
  END (* CHECKSET *); 
  
  
(*$L'STATEMENT PROCESSOR.' *) 
  
  
   PROCEDURE STATEMENT(FSYS: SETOFSYS;  STMTSEQUENCE: BOOLEAN); 
    LABEL 1;
    VAR LCP: CTP; LLP: LBP; LOCP: LOCOFREF; 
        LASTSY: SYMBOL;  EXITLOOP: BOOLEAN; 
  
    PROCEDURE THREATEN(FCP: CTP); 
    BEGIN 
     IF (FCP <> NIL) AND (FCP <> UVARPTR) THEN
      IF FCP^.KLASS = VARS THEN 
       BEGIN IF FCP^.CONTROLVAR THEN ERROR(184);
        IF FCP^.VLEV < LEVEL THEN 
         FCP^.THREAT := TRUE
       END
    END (* THREATEN *); 
  
    PROCEDURE PACKOFL(FI: REGNR); 
     VAR K: REGNR;
    BEGIN NEEDX([0..7],K); GEN15(BXX,K,FI,FI);
     GEN15(AXJK,K,0,48); GEN30(TESTX,ORD(NZ),K,OVLERR,TERAR); DECREFX(K)
    END (*PACKOFL*) ; 
  
    PROCEDURE PACKANDNORM(VAR FI: REGNR); 
     VAR K: REGNR;
    BEGIN IF DEBUG THEN PACKOFL(FI); DECREFX(FI); NEEDX([0..7],K);
     GEN15(PXBX,K,0,FI); GEN15(NXBX,K,0,K); 
     FI := K
    END (*PACKANDNORM*) ; 
  
    PROCEDURE EXPREP(FVAL: INTEGER;VAR FREC: CSTREC); 
     (*RETURN EXPONENTIAL REPRESENTATION OF FVAL: 
      CKIND = PUREP   IF   FVAL = 2**EXP, 
      CKIND = POSP    IF   FVAL = 2**EXP1*(2**EXP2 + 1),
      CKIND = NEGP    IF   FVAL = 2**EXP1*(2**EXP2 - 1),
      CKIND = NOP     ELSE.*) 
     VAR E1,E2: BITRANGE; 
    BEGIN 
     IF FVAL > 0 THEN 
      BEGIN E1 := 0;
       WHILE NOT ODD(FVAL) DO 
        BEGIN FVAL := FVAL DIV 2; E1 := E1 + 1 END; 
       IF FVAL = 1 THEN 
        WITH FREC DO
         BEGIN CKIND := PUREP; EXP := E1 END
       ELSE 
        BEGIN FVAL := FVAL DIV 2; E2 := 1;
         IF ODD(FVAL) THEN
          BEGIN 
           REPEAT FVAL := FVAL DIV 2; E2 := E2 + 1
           UNTIL NOT ODD(FVAL); 
           IF FVAL > 0 THEN FREC.CKIND := NOP 
           ELSE 
            WITH FREC DO
             BEGIN CKIND := NEGP; EXP1 := E1; EXP2 := E2 END
          END 
         ELSE 
          BEGIN 
           REPEAT FVAL := FVAL DIV 2; E2 := E2 + 1
           UNTIL ODD(FVAL); 
           IF FVAL > 1 THEN FREC.CKIND := NOP 
           ELSE 
            WITH FREC DO
             BEGIN CKIND := POSP; EXP1 := E1; EXP2 := E2 END
          END 
        END 
      END 
     ELSE FREC.CKIND := NOP 
    END (*EXPREP*) ;
  
    PROCEDURE OPTMULT(FI: REGNR; FREC: CSTREC; FEQ: BOOLEAN;
    VAR FK: REGNR); 
     (*GENERATE CODE FOR X-FK := X-FI*FREC.  FEQ <=> FI=FK IS ALLOWED*) 
     VAR E: BITRANGE; I,K: REGNR; B: BOOLEAN; 
    BEGIN B := FALSE; 
     WITH FREC DO 
      BEGIN IF CKIND = PUREP THEN E := EXP ELSE E := EXP1;
       IF E <> 0 THEN 
        IF E = 1 THEN 
         BEGIN NEEDX([0..7],K); GEN15(LXBX,K,1,FI); 
          IF FEQ OR (CKIND = PUREP) THEN DECREFX(FI)
          ELSE
           BEGIN B := TRUE; I := FI END;
          FI := K 
         END
        ELSE
         IF FEQ AND (XRGS[FI].REFNR = 1) THEN (*DESTROY X-FI*)
          BEGIN GEN15(LXJK,FI,0,E); 
           WITH XRGS[FI] DO 
            BEGIN IF XCONT = INDVAR THEN DECREFX(XREG); 
             XCONT := OTHER 
            END 
          END 
         ELSE (*COPY X-FI*) 
          BEGIN NEEDX([0..7],K); GEN15(BXX,K,FI,FI);
           GEN15(LXJK,K,0,E); 
           IF FEQ OR (CKIND = PUREP) THEN DECREFX(FI) 
           ELSE 
            BEGIN B := TRUE; I := FI END; 
           FI := K
          END;
       IF CKIND <> PUREP THEN 
        BEGIN NEEDX([0..7],K);
         IF B THEN DECREFX(I);
         GEN15(BXX,K,FI,FI); GEN15(LXJK,K,0,EXP2);
         IF CKIND = POSP THEN GEN15(IXXPX,K,K,FI) 
         ELSE GEN15(IXXMX,K,K,FI);
         DECREFX(FI); FK := K 
        END 
       ELSE FK := FI
      END 
    END (*OPTMULT*) ; 
  
    PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD;
  
   PROCEDURE ASSIGNTO(VAR LATTR: ATTR); 
     VAR I,J,K,L,M: REGNR; FLOAT: BOOLEAN;
         LWORDS: ADDRRANGE; LMIN,LMAX: INTEGER; 
         SIMPIND,LONG: BOOLEAN; 
   BEGIN
       IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN 
        BEGIN 
         FLOAT := COMPTYPES(GATTR.TYPTR,INTPTR) AND 
          (LATTR.TYPTR = REALPTR);
         IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) OR FLOAT THEN
          CASE LATTR.TYPTR^.FORM OF 
           SCALAR,
           SUBRANGE:  
            BEGIN 
             IF (LATTR.TYPTR = INTPTR) OR (LATTR.TYPTR = REALPTR) THEN
              LOAD(GATTR,I) 
             ELSE 
              BEGIN GETBOUNDS(LATTR.TYPTR,LMIN,LMAX); 
               IF GATTR.KIND = CST THEN 
                BEGIN 
                 IF (GATTR.CVAL.IVAL<LMIN)OR (GATTR.CVAL.IVAL 
                  >LMAX) THEN ERROR(303); 
                 LOAD(GATTR,I)
                END 
               ELSE 
                BEGIN LOAD(GATTR,I);
                 IF DEBUG THEN CHECKBNDS(I,LMIN,LMAX,ASSERR)
                END 
              END;
             IF FLOAT THEN PACKANDNORM(I);
             STORE(LATTR,I) 
            END;
           POINTER: 
            BEGIN LOAD(GATTR,I);
             STORE(LATTR,I) 
            END;
           POWER: 
            BEGIN 
             CHECKSET(LATTR.TYPTR,I); 
             STORE(LATTR,I) 
            END;
           ARRAYS,
           RECORDS: 
            IF LATTR.TYPTR^.FTYPE THEN ERROR(146) ELSE
            BEGIN LWORDS := FULLWORDS(LATTR.TYPTR^.SIZE); 
             IF LWORDS = 1 THEN 
              BEGIN LOAD(GATTR,I); STORE(LATTR,I) END 
             ELSE 
              IF LWORDS > 31 THEN 
               BEGIN BRGS[2].BCONT := SPECPURP; 
                LOADADDRESS(LATTR,I); GEN15(SBXPB,2,I,0); 
                NEEDX([1],K); SETADDRESS(GATTR,FALSE,REGA,[],K);
                GEN30(SBBPK,7,0,LWORDS,ABSR); RJTOEXT('P.MVE     ') 
               END
              ELSE  (* LWORDS <= 31 *)
               IF LWORDS <> 0 THEN
               BEGIN SETADDRESS(GATTR,FALSE,REGA,[1..5],I); 
                NEEDX([6,7],K); 
                GEN15(BXX,K,I,I); 
                LONG := LWORDS >= 4;
                LWORDS := LWORDS - 1; (* COUNT FIRST WORD *)
                IF LONG THEN
                 BEGIN NEEDX([0..7],J); GEN15(MXJK,J,0,LWORDS) END; 
                SIMPIND := FALSE; 
                IF LATTR.WORDACC = INDRCT THEN
                 SIMPIND := XRGS[LATTR.VWDISPL].XCONT = SIMPVAR;
                SETADDRESS(LATTR,SIMPIND,REGA,[],K);
                IF LONG THEN
                 BEGIN NOOP;
                  GEN15(SAAPB,I,I,1); GEN15(BXX,K,I,I); 
                  GEN15(LXJK,J,0,1); GEN15(SAAPB,K,K,1);
                  GEN30(TESTX,ORD(NG),J,IC-1,PROGR);
                  DECREFX(J)
                 END
                ELSE (* NOT LONG *) 
                 FOR J := 1 TO LWORDS DO
                  BEGIN GEN15(SAAPB,I,I,1); GEN15(BXX,K,I,I); 
                   GEN15(SAAPB,K,K,1) 
                  END;
                (* RATHER THAN ATTEMPTING TO DETERMINE WHICH REGISTER 
                   DESCRIPTORS HAVE BEEN INVALIDATED BY THE STORE 
                   OPERATION, WE SIMPLY CLEAR THE REGISTER MAP.  *) 
                CLEARREGS 
               END  (* LWORDS <= 31 *)
            END;
           FILES: ERROR(146)
          END 
         ELSE ERROR(129)
        END 
   END (*ASSIGNTO*);
  
    PROCEDURE CHECKPTRREF(FI: REGNR); 
     (* CHECK THAT THE EXTENDED ($T+) POINTER VALUE IN X.FI  *) 
     (* IS VALID AND NON-NIL.  *) 
     VAR J, K: REGNR; 
    BEGIN (* CHECKPTRREF *) 
     NEEDX([1..5],J); NEEDX([0..7],K);
     GEN30(SABPK,J,0,FL,GLOBLR);
     GEN30(SXXPK,K,FI,-1,ABSR); 
     GEN15(IXXMX,J,K,J);
     GEN15(BXXPCX,J,K,J); 
     GEN30(TESTX,ORD(NG),J,PTRERR,TERAR); 
     GEN15(SAXPB,J,K,0);
     GEN15(IXXMX,J,FI,J); 
     GEN30(TESTX,ORD(NZ),J,PTRERR,TERAR); 
     DECREFX(J); DECREFX(K);
     ARGS[J].ACONT := UNSPECADDR
    END (* CHECKPTRREF *);
  
    PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); 
     VAR LATTR: ATTR; 
      I,J: REGNR; LSP: STP; 
  
     PROCEDURE IDADDRESS; 
      VAR I: REGNR; 
     BEGIN
      WITH FCP^, LATTR DO 
       BEGIN TYPTR := IDTYPE;  KIND := VARBL;  TAGF := FALSE; 
        IF TYPTR <> NIL THEN
         CASE KLASS OF
          VARS: 
           BEGIN
            VLEVEL := VLEV; CWDISPL := VADDR; PCKD := FALSE;
            DCLPCKD := FALSE; 
            IF CONFORMNT THEN WORDACC := INDRCT 
            ELSE WORDACC := VKIND;
            IF WORDACC = INDRCT THEN
             BEGIN WORDACC := DRCT; LOAD(LATTR,I);
              KIND := VARBL; XRGS[I].VPADDR := TRUE;
              WORDACC := INDRCT; CWDISPL := 0;
              VWDISPL := I; PCKD := FALSE 
             END
           END; 
          TAGFIELD, 
          FIELD:  
           WITH DISPLAY[DISX] DO
            BEGIN WORDACC := DRCT; VLEVEL := LEV; 
             IF WACC = DRCT THEN CWDISPL := CWDSPL + FLDADDR
             ELSE 
              BEGIN CWDISPL := CWDSPL; PCKD := FALSE; 
               LOAD(LATTR,I); 
               KIND := VARBL; WORDACC := INDRCT;
               CWDISPL := FLDADDR; VWDISPL := I 
              END;
             DCLPCKD := DCLPKD; 
             IF PKD THEN (*IMPLIES (FLDADDR=0)AND PCKDFLD*) 
              BEGIN PCKD := TRUE; 
               IF BACC = DRCT THEN
                BEGIN CBDISPL := BDSPL + BITADDR; 
                 BITREG := NONE 
                END 
               ELSE 
                BEGIN 
                 WITH GATTR DO
                  BEGIN TYPTR := IDTYPE; KIND := VARBL; 
                   WORDACC := DRCT; VLEVEL := LEVEL;
                   CWDISPL := BDSPL; PCKD := FALSE
                  END;
                 LOAD(GATTR,I); 
                 CBDISPL := BITADDR; BITREG := XREG;
                 VBDISPL := I 
                END 
              END (*PKD*) 
             ELSE 
              IF PCKDFLD THEN 
               BEGIN PCKD := TRUE; CBDISPL := BITADDR;
                BITREG := NONE
               END
              ELSE PCKD := FALSE; 
             TAGF := (KLASS = TAGFIELD) 
            END (*WITH*) ;
           FUNC: (* WE GET HERE ONLY FROM ASSIGNMENT STATEMENT *) 
            BEGIN TYPTR := NIL; 
             IF PFDECKIND = PREDECLARED THEN ERROR(150) 
             ELSE 
              IF PFKIND = FORMAL THEN ERROR(151)
              ELSE
               IF PFDECL IN [EXTDECL, FTNDECL] THEN ERROR(150)
               ELSE 
                BEGIN VLEVEL := PFLEV + 1;
                 IF VLEVEL > LEVEL THEN ERROR(177)
                 ELSE 
                  IF FCP <> DISPLAY[VLEVEL].PFCP THEN ERROR(177)
                  ELSE
                   BEGIN TYPTR := IDTYPE; WORDACC := DRCT;
                    CWDISPL := FIRSTVAR - 1; PCKD := FALSE; 
                    DISPLAY[VLEVEL].ASSIGNED := TRUE
                   END
                END 
            END (* FUNC *)
         END (*CASE*) 
       END (*WITH*) 
     END (*IDADDRESS*) ;
  
     PROCEDURE INDEXCODE; 
      VAR LBREG: REGKIND; LBITS: BITRANGE; LWORDS: ADDRRANGE; 
        LOW,HIGH: INTEGER; I,J,K,L,M: REGNR;
        LACC: ACCESSKIND; SZE: INTEGER; LREC: CSTREC; 
        CW: INTEGER;
        DSHIFT,RSHIFT,MSHIFT: INTEGER;
        EPW,LARGEST,PRECISION: INTEGER; 
  
      PROCEDURE TESTBOUNDS(FI: REGNR; VAR FATTR: ATTR; VAR FJ: REGNR);
       (* TEST X.FI AGAINST BOUNDS DENOTED BY THE DESCRIPTOR OF FATTR.
          X.FJ := X.FI - LOW. *)
       VAR I,J: REGNR;
      BEGIN LOADDESC(FATTR,I,1);
       DECREFX(I); NEEDX([0..7],J); GEN15(IXXMX,J,I,FI);
       LOADDESC(FATTR,I,2); 
       OPERATION(IXXMX,FJ,FI,I);
       DECREFX(J); NEEDX([0..7],I); GEN15(BXXPX,I,J,FJ);
       DECREFX(I); GEN30(TESTX,ORD(NG),I,INXERR,TERAR)
      END (*TESTBOUNDS*) ;
  
     BEGIN (*INDEXCODE*) LACC := DRCT; LBREG := NONE; 
      IF GATTR.KIND <> CST THEN LOAD(GATTR,I);
      WITH LATTR, TYPTR^ DO 
       BEGIN
        IF CONFORMANT THEN
         BEGIN
          IF GATTR.KIND = CST THEN LOAD(GATTR,I); 
          (*TEST INDEX, SET J TO INDEX - LOW*)
          IF DEBUG THEN TESTBOUNDS(I,LATTR,J) 
          ELSE
           BEGIN LOADDESC(LATTR,J,2); OPERATION(IXXMX,J,I,J)
           END
         END
        ELSE
         BEGIN
          GETBOUNDS(INXTYPE,LOW,HIGH);
          IF GATTR.KIND = CST THEN
           BEGIN IF (GATTR.CVAL.IVAL>HIGH)OR (GATTR.CVAL.IVAL<LOW)
            THEN ERROR(302) 
           END
          ELSE
           IF DEBUG THEN CHECKBNDS(I,LOW,HIGH,INXERR);
         END; 
        IF PCKDARR AND PARTWORDELS THEN (*PARTWORD ACCESS*) 
         BEGIN
          (* IF CONFORMANT THEN: FULLWORD(SIZE) > 1 *)
          IF NOT PCKD THEN
           BEGIN PCKD := TRUE; CBDISPL := 0; BITREG := NONE END;
          LBITS := AELTYPE^.SIZE.BITS;
          IF FULLWORDS(SIZE) = 1 THEN 
           IF GATTR.KIND = CST THEN 
            CBDISPL := CBDISPL + (GATTR.CVAL.IVAL - LOW)*LBITS
           ELSE 
            BEGIN CBDISPL := CBDISPL - LOW*LBITS; 
             EXPREP(LBITS,LREC);
             IF LREC.CKIND <> NOP THEN OPTMULT(I,LREC,TRUE,J) 
             ELSE 
              BEGIN LOADCST(LBITS,K); 
               OPERATION(DXXTX,J,I,K) 
              END;
             LBREG := XREG
            END 
          ELSE
           IF GATTR.KIND = CST THEN 
            BEGIN CWDISPL := CWDISPL + (GATTR.CVAL.IVAL - LOW)
                    DIV ELSPERWORD; 
             CBDISPL := CBDISPL + (GATTR.CVAL.IVAL - LOW) 
                   MOD ELSPERWORD * LBITS 
            END 
           ELSE 
            BEGIN 
             EPW := ELSPERWORD; 
             IF CONFORMANT THEN LARGEST := EPW * 400000B
                            (* ASSUME MAX SIZE FOR CONFORMANT ARRAYS *) 
             ELSE 
              BEGIN LARGEST := HIGH - LOW;
               IF LARGEST > MAXADDR * WORDSIZE THEN 
                LARGEST := MAXADDR * WORDSIZE;
               IF LOW = 0 THEN J := I 
               ELSE BEGIN LOADCST(LOW,J); OPERATION(IXXMX,J,I,J) END
              END;
             (* 
                COMPUTE WORD INDEX INTO PACKED ARRAY GIVEN
                 EPW IN [2..8,10,12,15,20,30,60]. 
  
                 WE DO THIS BY REPRESENTING EPW AS
                      EPW = 2**DSHIFT * X * Y 
  
                 WHERE
  
                      DSHIFT = 0  FOR EPW IN [3,5,7,15] 
                      DSHIFT = 1  FOR EPW IN [2,6,10,30]
                      DSHIFT = 2  FOR EPW IN [4,12,20,60] 
                      DSHIFT = 3  FOR EPW = 8 
  
                      X = 1  FOR EPW IN [2,4,7,8,15,30,60]
                      X = 3  FOR EPW IN [5,10,20] 
                      X = 5  FOR EPW IN [3,6,12]
  
                      Y = 1  FOR EPW IN [2,4,8] 
                      Y = 7  FOR EPW = 7
                      Y = 15 FOR EPW IN [3,5,6,10,12,15,20,30,60] 
  
  
                 MSHIFT REPRESENTS THE SHIFT BETWEEN BITS IN X: 
  
                      1 = 1 + 2**0       MSHIFT = 0 
                      3 = 1 + 2**1       MSHIFT = 1 
                      5 = 1 + 2**2       MSHIFT = 2 
  
                 RSHIFT REPRESENTS THE SHIFT BETWEEN BITS IN THE BINARY 
                 REPRESENTATION OF  1/1,  1/7,  AND  1/15:  
  
                      1/1 = 1.0                      RSHIFT = 0 
                      1/7 = 0.001001001 ...          RSHIFT = 3 
                      1/15 = 0.000100010001 ...      RSHIFT = 4 
             *) 
             DSHIFT := ORD(EPW-2 IN [0,2,4,6,8,10,18,28,58]) +
                       ORD(EPW-2 IN [2,6,10,18,58]) + 
                       ORD(EPW = 8);
             IF EPW IN [2,4,8] THEN RSHIFT := 0 
             ELSE 
              IF EPW = 7 THEN RSHIFT := 3 
              ELSE RSHIFT := 4; 
             MSHIFT := ORD(EPW IN [3,5,6,10,12,20]) + 
                       ORD(EPW IN [3,6,12]);
             NEEDX([0..7],K); 
             IF DSHIFT = 0 THEN I := J (* RSHIFT CANNOT BE 0 *) 
             ELSE 
              BEGIN I := K; M := 1; 
               IF DSHIFT <> 1 THEN
                BEGIN NEEDB(M); GEN15(SBBPB,M,1,1); 
                 IF DSHIFT = 3 THEN GEN15(SBBPB,M,M,1); 
                 BRGS[M].BCONT := FREE
                END;
               GEN15(AXBX,K,M,J)
              END;
             IF RSHIFT = 0 THEN 
              BEGIN NEEDX([0..7],L); GEN15(LXBX,L,M,K) END
             ELSE 
              BEGIN 
               FOR L := 1 TO DSHIFT DO LARGEST := LARGEST DIV 2;
               PRECISION := 1;
               FOR L := 1 TO RSHIFT DO PRECISION := PRECISION * 2;
               IF LARGEST < 377776B THEN GEN15(SXXPB,K,I,1) 
               ELSE 
                BEGIN LOADCST(1,L); DECREFX(L); 
                 GEN15(IXXPX,K,L,I) 
                END;
               NEEDX([0..7],L); DECREFX(L); 
               IF MSHIFT <> 0 THEN
                BEGIN 
                 IF MSHIFT = 1 THEN GEN15(LXBX,L,1,K) 
                 ELSE 
                  BEGIN GEN15(BXX,L,K,K); GEN15(LXJK,L,0,MSHIFT) END; 
                 GEN15(IXXPX,K,L,K) 
                END;
               REPEAT 
                 GEN15(BXX,L,K,K);
                 GEN15(LXJK,K,0,RSHIFT);
                 GEN15(IXXPX,K,L,K);
                 RSHIFT := RSHIFT * 2;
                 PRECISION := SQR(PRECISION)
               UNTIL LARGEST < PRECISION; 
               GEN15(AXJK,K,0,RSHIFT);
               EXPREP(EPW,LREC);
               IF LREC.CKIND <> NOP THEN
                BEGIN OPTMULT(K,LREC,FALSE,L);
                 (*RESET REFERENCE:*) 
                 WITH XRGS[K] DO
                  BEGIN XCONT := OTHER; REFNR := 1 END; 
                END 
               ELSE 
                BEGIN LOADCST(EPW,I); DECREFX(I); 
                 NEEDX([0..7],L); GEN15(DXXTX,L,K,I); 
               END
              END;
             DECREFX(J); I := J; NEEDX([0..7],J); GEN15(IXXMX,J,I,L); 
             EXPREP(LBITS,LREC);
             IF LREC.CKIND <> NOP THEN OPTMULT(J,LREC,TRUE,J) 
             ELSE 
              BEGIN GEN30(SXBPK,L,0,LBITS,ABSR); GEN15(DXXTX,J,J,L) END;
             DECREFX(L);
             LACC := INXD; LBREG := XREG
            END 
         END (*PCKDARR AND PARTWORDELS*)
        ELSE
          IF CONFORMANT THEN
           BEGIN
            IF CONFORMARRAY(AELTYPE) THEN 
             BEGIN (*SIZE (FOR AELTYPE) IS VARIABLE*) 
              LOADDESC(LATTR,I,3); OPERATION(DXXTX,K,I,J) 
             END
            ELSE (*SIZE OF AELTYPE IS CONSTANT*)
             BEGIN SZE := FULLWORDS(AELTYPE^.SIZE); 
              EXPREP(SZE,LREC); 
              IF LREC.CKIND <> NOP THEN OPTMULT(J,LREC,TRUE,K)
              ELSE
               BEGIN
                WITH GATTR DO 
                 BEGIN TYPTR := INTPTR; KIND := CST;
                  CVAL.IVAL := SZE
                 END; 
                LOAD(GATTR,I); OPERATION(DXXTX,K,I,J) 
               END; 
             END; 
            LACC := INXD
           END
          ELSE
          BEGIN 
           LWORDS := FULLWORDS(AELTYPE^.SIZE);
           IF GATTR.KIND = CST THEN 
            BEGIN CW := CWDISPL + (GATTR.CVAL.IVAL - LOW) * LWORDS; 
             IF ABS(CW) > MAXADDR THEN
              BEGIN CWDISPL := 0; 
               LOADCST(CW,K); LACC := INXD
              END 
             ELSE CWDISPL := CW 
            END 
           ELSE 
            BEGIN CW := CWDISPL - LOW * LWORDS; 
             IF ABS(CW) > MAXADDR THEN
              BEGIN 
               IF DEBUG (* LOW ALREADY IN X-REG *) OR 
                  (ABS(LOW) > MAXADDR) THEN 
                BEGIN LOADCST(LOW,K); OPERATION(IXXMX,K,I,K) END
               ELSE 
                BEGIN DECREFX(I); NEEDX([0..7],K);
                 GEN30(SXXPK,K,I,-LOW,ABSR) 
                END;
               I := K 
              END 
             ELSE CWDISPL := CW;
             EXPREP(LWORDS,LREC); 
             IF LREC.CKIND <> NOP THEN OPTMULT(I,LREC,TRUE,K) 
             ELSE 
              BEGIN LOADCST(LWORDS,J);
               OPERATION(DXXTX,K,I,J) 
              END;
             LACC := INXD 
            END;
          END;
        IF LACC <> DRCT THEN
         IF WORDACC = DRCT THEN 
          BEGIN VWDISPL := K; WORDACC := INXD;
          END 
         ELSE 
          BEGIN OPERATION(IXXPX,L,VWDISPL,K); VWDISPL := L END; 
        IF LBREG <> NONE THEN 
         IF BITREG = NONE THEN
          BEGIN BITREG := XREG; VBDISPL := J END
         ELSE 
          BEGIN OPERATION(IXXPX,L,VBDISPL,J); VBDISPL := L END
       END (*WITH LATTR*) 
     END (*INDEXCODE*) ;
  
    BEGIN (*SELECTOR*)
     IDADDRESS; 
     CHECKCONTEXT(FSYS+SELECTSYS,59,[]);
     WHILE SY IN SELECTSYS DO 
      BEGIN 
(*[*)   IF SY = LBRACK THEN 
        BEGIN 
         REPEAT 
          WITH LATTR DO 
           IF TYPTR <> NIL THEN 
            IF TYPTR^.FORM <> ARRAYS THEN 
             BEGIN ERROR(138); TYPTR := NIL END;
          INSYMBOL; EXPRESSION(FSYS+[COMMA,RBRACK]);
          IF GATTR.TYPTR <> NIL THEN
           IF GATTR.TYPTR^.FORM > SUBRANGE THEN ERROR(113); 
          IF LATTR.TYPTR <> NIL THEN
           WITH LATTR.TYPTR^ DO 
            BEGIN LSP := INXTYPE; 
             IF LSP <> NIL THEN 
              IF LSP^.FORM = BOUNDDESC THEN 
               LSP := LSP^.BOUNDTYPE; 
             IF COMPTYPES(LSP,GATTR.TYPTR) THEN 
              BEGIN 
               IF (INXTYPE <> NIL)AND (AELTYPE <> NIL) THEN INDEXCODE 
              END 
             ELSE ERROR(139); 
             LATTR.DCLPCKD := PCKDARR;
             LATTR.TYPTR := AELTYPE 
            END 
         UNTIL SY <> COMMA; 
         EXPECTSYMBOL(RBRACK,12)
        END (*IF SY = LBRACK*)
       ELSE 
(*.*)     IF SY = PERIOD THEN 
         BEGIN
          WITH LATTR DO 
           BEGIN
            IF TYPTR <> NIL THEN
             IF TYPTR^.FORM <> RECORDS THEN 
              BEGIN ERROR(140); TYPTR := NIL END; 
            INSYMBOL; 
            IF SY = IDENT THEN
             BEGIN
              IF TYPTR <> NIL THEN
               BEGIN SEARCHSECTION(TYPTR^.FIELDS,LCP);
                IF LCP = NIL THEN 
                 BEGIN ERROR(152); TYPTR := NIL END 
                ELSE
                 WITH LCP^ DO 
                  BEGIN DCLPCKD := TYPTR^.PCKDREC;
                   TYPTR := IDTYPE;  TAGF := (KLASS = TAGFIELD);
                   IF PCKD THEN (*IMPLIES (FLDADDR=0)AND PCKDFLD*)
                    CBDISPL := CBDISPL + BITADDR
                   ELSE 
                    BEGIN CWDISPL := CWDISPL + FLDADDR; 
                     IF PCKDFLD THEN
                      BEGIN PCKD := TRUE; BITREG := NONE; 
                       CBDISPL := BITADDR 
                      END 
                    END 
                  END 
               END; 
              INSYMBOL
             END (*SY = IDENT*) 
            ELSE ERROR(2) 
           END (*WITH GATTR*) 
         END (*IF SY = PERIOD*) 
        ELSE
(*^*)    BEGIN
          IF LATTR.TYPTR <> NIL THEN
           BEGIN
            WITH LATTR DO 
             BEGIN
              IF TYPTR^.FORM = FILES THEN 
               IF TYPTR^.TEXTFILE THEN
                CWDISPL := CWDISPL + CHEFET - 1 
               ELSE CWDISPL := CWDISPL + BINEFET - 1; 
              LOAD(LATTR,I);
              WITH TYPTR^ DO
               IF FORM = POINTER THEN 
                BEGIN TYPTR:=ELTYPE;
                 IF DBG THEN
                  BEGIN 
                   IF DEBUG THEN (* TEST POINTER *) 
                    CHECKPTRREF(I); 
                   (* SET KEY PART TO ZERO *) 
                   J := I; DECREFX(J); NEEDX([0..7],I); 
                   GEN15(SXXPB,I,J,0);
                  END 
                END 
               ELSE 
                IF FORM = FILES THEN TYPTR := FILTYPE 
                ELSE ERROR(141);
              KIND := VARBL; WORDACC := INDRCT; 
              CWDISPL := 0; VWDISPL := I; 
              DCLPCKD := FALSE; 
              PCKD := FALSE 
             END
           END; 
          INSYMBOL
         END; 
       CHECKCONTEXT(FSYS+SELECTSYS,6,[])
      END (*WHILE*) ; 
     GATTR := LATTR;
    END (*SELECTOR*) ;
  
    PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP); 
     VAR LKEY: KEYWORD; I,J,K: REGNR; 
  
     PROCEDURE VARIABLE(FSYS: SETOFSYS);
      VAR LCP: CTP; 
     BEGIN
      IF SY = IDENT THEN
       BEGIN SEARCHID([VARS,FIELD,TAGFIELD],LCP); 
        THREATEN(LCP); INSYMBOL 
       END
      ELSE BEGIN ERROR(2); LCP := UVARPTR END;
      SELECTOR(FSYS,LCP)
     END (*VARIABLE*) ; 
  
     PROCEDURE GETCPUTC(FEXT: EXTERNALNAME);
     BEGIN (* GETCPUTC *) 
      GEN15(SAXPB,3,1,1); 
      IF FEXT = GETCHEX THEN
       BEGIN GEN15(SXXPB,6,1,1);
        IF DEBUG THEN 
         BEGIN GEN15(LXJK,1,0,1); GEN15(BXXPX,0,3,1) END
       END
      ELSE (* PUT *)
       BEGIN GEN15(SXBPB,4,1,0); GEN15(IXXPX,6,1,4);
        IF DEBUG THEN 
         BEGIN GEN15(LXBX,0,1,1); GEN15(BXXPCX,0,3,0) END 
       END; 
      GEN15(SAAPB,6,1,0); 
      GEN30(SXBPK,7,0,IC+1,PROGR);
      SEARCHEXTID(EX[FEXT]);
      IF DEBUG THEN GEN30(TESTX,ORD(NG),0,0,ABSR) 
      ELSE GEN30(TESTX,ORD(NG),3,0,ABSR); 
      CLEARREGS;
      NOOP
     END (* GETCPUTC *);
  
     PROCEDURE FILEPROCS(FEXT: EXTERNALNAME); 
      VAR CHARFILE,SEGMFILE: BOOLEAN; I: REGNR; 
        LDPLMT: ADDRRANGE;
     BEGIN EXPECTSYMBOL(LPARENT,9); 
      CLEARREGS; XRGS[1].XCONT := OTHER; (*RESERVE A1/X1*)
      VARIABLE(FSYS+[COMMA,RPARENT]); 
      CLEARREGS; (*TO PREVENT BX1... AND GUARANTEE SA1...*) 
      CHARFILE := FALSE; SEGMFILE := FALSE;  LDPLMT := BINEFET; 
      IF GATTR.TYPTR <> NIL THEN
       BEGIN
        IF GATTR.WORDACC <> DRCT THEN 
         XRGS[GATTR.VWDISPL].XCONT := OTHER;
        WITH GATTR.TYPTR^ DO
         IF FORM = FILES THEN 
          BEGIN CHARFILE := TEXTFILE; SEGMFILE := SEGFILE;
           IF CHARFILE THEN LDPLMT := CHEFET
          END 
         ELSE ERROR(116)
       END
      ELSE GATTR.CWDISPL := 0;
      IF LKEY IN [GETKW,PUTKW] THEN 
       IF CHARFILE THEN LDPLMT := CHEFET - 1
      ELSE
       IF LKEY IN [GETSEGKW,PUTSEGKW] THEN
        IF NOT SEGMFILE THEN ERROR(116);
      GATTR.CWDISPL := GATTR.CWDISPL + LDPLMT;
      LOAD(GATTR,I);
      IF SY = COMMA THEN
       BEGIN
        IF LKEY = REWRITEKW THEN
         BEGIN IF NOT SEGMFILE THEN ERROR(126); 
          EXTENSION(326); FEXT := RWRTSEX 
         END
        ELSE
         IF LKEY <> GETSEGKW THEN ERROR(126); 
        INSYMBOL; 
        EXPRESSION(FSYS+[RPARENT]); 
        IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(142); 
        LOAD(GATTR,I); BXIXJ(2,I) 
       END
      ELSE
       IF LKEY = GETSEGKW THEN GEN15(SXBPB,2,1,0);
      IF CHARFILE AND (LKEY IN [GETKW,PUTKW]) THEN
       IF LKEY = GETKW THEN GETCPUTC(GETCHEX) ELSE GETCPUTC(PUTCHEX)
      ELSE RJTOEXT(EX[FEXT]); 
      EXPECTSYMBOL(RPARENT,4) 
     END (* FILEPROCS *); 
  
     PROCEDURE LOADFILEWORD(FATTR: ATTR; FDRCT: BOOLEAN;
                            FDISPL: SHRTINT); 
      (* LOAD WORD FDISPL RELATIVE TO THE EFET OF THE FILE
         DESCRIBED BY <FATTR,FDRCT> INTO A1/X1, GUARANTEEING
         A MEMORY REFERENCE IS GENERATED.  UPON ENTRY, A1/X1
         SHOULD BE RESERVED.  *)
      VAR I: REGNR; L: ADDRRANGE; LATTR: ATTR;
     BEGIN (* LOADFILEWORD *) 
      WITH FATTR DO 
       BEGIN
        IF TYPTR^.TEXTFILE THEN L := CHEFET + FDISPL
        ELSE L := BINEFET + FDISPL; 
        IF FDRCT THEN CWDISPL := CWDISPL + L
        ELSE
         BEGIN LATTR := FATTR;
          LOAD(LATTR,I);
          WORDACC := INDRCT;
          VWDISPL := I; 
          CWDISPL := L
         END; 
        I := 1; 
        SETADDRESS(FATTR,TRUE,REGA,[],I);  (* GENERATE SA1 ... *) 
        IF WORDACC = INDRCT THEN DECREFX(VWDISPL) 
       END
     END (* LOADFILEWORD *);
  
     PROCEDURE READ;
      VAR PARAM,LATTR,FILATTR: ATTR; I,J: REGNR;
        LDRCT,GETIN,EXITLOOP: BOOLEAN;
        LMIN,LMAX: INTEGER; 
        LXRGS: XRGSTATUS; 
  
     BEGIN (*READ*) 
      (*SET DEFAULT FILE ATTRIBUTES:*)
      WITH FILATTR DO 
       BEGIN TYPTR := TEXTPTR; KIND := VARBL; WORDACC := DRCT;
        VLEVEL := 1; PCKD := FALSE; 
        IF INPUTPTR = NIL THEN CWDISPL := 0 
        ELSE CWDISPL := INPUTPTR^.VADDR 
       END; 
      LDRCT := TRUE;
      (*SET PARAMETER ATTRIBUTES:*) 
      WITH PARAM DO 
       BEGIN TYPTR := TEXTPTR; KIND := VARBL; WORDACC := DRCT;
        VLEVEL := 0; CWDISPL := PFLC; PCKD := FALSE 
       END; 
      NEEDX([1],I);             (*RESERVE A1/X1*) 
      IF SY = LPARENT THEN
       BEGIN GETIN := TRUE; 
        INSYMBOL; VARIABLE(FSYS+[COMMA,RPARENT]); 
        IF GATTR.TYPTR <> NIL THEN
         IF GATTR.TYPTR^.FORM = FILES THEN
          BEGIN IF NOT GATTR.TYPTR^.TEXTFILE AND (LKEY = READLNKW)
            THEN ERROR(116);
           IF GATTR.WORDACC = DRCT THEN 
            BEGIN FILATTR := GATTR; LDRCT := TRUE END 
           ELSE 
            BEGIN LOADADDRESS(GATTR,I); 
             WITH FILATTR DO
              BEGIN TYPTR := GATTR.TYPTR; 
               VLEVEL := LEVEL; CWDISPL := LC 
              END;
             STORE(FILATTR,I);
             LC := LC + 1;
             IF LC > LCMAX THEN LCMAX := LC;
             LDRCT := FALSE 
            END;
          IF SY = RPARENT THEN
           BEGIN IF LKEY = READKW THEN ERROR(116);
            GETIN := FALSE
           END
          ELSE
           IF SY = COMMA THEN 
            BEGIN INSYMBOL; VARIABLE(FSYS+[COMMA,RPARENT]) END
          END (*FORM = FILES*)
         ELSE IF INPUTPTR = NIL THEN ERROR(175);
        IF GETIN THEN 
         (*LOOP UNTIL SY <> COMMA:*)
         REPEAT 
          IF FILATTR.TYPTR^.TEXTFILE AND
             NOT COMPTYPES(GATTR.TYPTR,CHARPTR) THEN
           BEGIN DECREFX(1);
            IF (GATTR.TYPTR = REALPTR) OR 
               COMPTYPES(GATTR.TYPTR,INTPTR) THEN 
             BEGIN  NEEDX([6,7],I);  DECREFX(I); (* STORING REG.*)
              SAVEREFXRGS(LXRGS); (* SAVE ACCESS TO VARIABLE *) 
              LATTR := FILATTR;  (* PASS FILE ADDRESS *)
              IF LDRCT THEN LOADADDRESS(LATTR,J) ELSE LOAD(LATTR,J);
              PARAM.CWDISPL := PFLC;  STORE(PARAM,J); 
              IF GATTR.TYPTR = REALPTR THEN RJTOEXT(EX[RDREX])
              ELSE RJTOEXT(EX[RDIEX]);
              IF I <> 6 THEN GEN15(BXX,I,6,6);
              RELOADREFXRGS(LXRGS);  NEEDX([I],I);
              LATTR := GATTR; 
              GATTR.KIND := EXPR;  GATTR.EXPREG := I; 
              ASSIGNTO(LATTR) 
             END
            ELSE ERROR(116) 
           END
          ELSE
           BEGIN LATTR := GATTR;
            LOADFILEWORD(FILATTR,LDRCT,-1); 
            WITH GATTR DO 
             BEGIN TYPTR := FILATTR.TYPTR^.FILTYPE; KIND := VARBL;
              WORDACC := INDRCT; CWDISPL := 0; VWDISPL := 1;
              PCKD := FALSE 
             END; 
            XRGS[1].REFNR := 2;  (*TO PROTECT A1/X1*) 
            ASSIGNTO(LATTR);
            NEEDX([1],I); (*RESET REFERENCE TO X1*) 
            IF FILATTR.TYPTR^.TEXTFILE THEN GETCPUTC(GETCHEX) 
            ELSE BEGIN LOADFILEWORD(FILATTR,LDRCT,0); 
                  RJTOEXT(EX[GETBEX]);
                 END; 
           END; 
          EXITLOOP := SY <> COMMA;
          IF NOT EXITLOOP THEN
           BEGIN NEEDX([1],I); (*RESERVE A1/X1*)
            INSYMBOL; VARIABLE(FSYS+[COMMA,RPARENT])
           END
         UNTIL EXITLOOP;
       EXPECTSYMBOL(RPARENT,4)
       END (*SY = LPARENT*) 
      ELSE
       IF LKEY = READKW THEN ERROR(116) 
       ELSE 
        IF INPUTPTR = NIL THEN ERROR(175);
      IF LKEY = READLNKW THEN 
       BEGIN LOADFILEWORD(FILATTR,LDRCT,-1);
        RJTOEXT(EX[GETLNEX])
       END; 
      IF NOT LDRCT THEN LC := LC - 1
     END (*READ*) ; 
  
     PROCEDURE WRITE; 
      VAR PARAM,LATTR,LATTR2,FILATTR: ATTR; K: REGNR; 
       LSP: STP; I,J: REGNR; LDEF,LDRCT,PUTOUT,EXITLOOP: BOOLEAN; 
       SHORTSTRING: BOOLEAN;
  
      PROCEDURE SETWIDTHANDJUMP(FW: INTEGER; FNAME: ALFA);
        VAR I: REGNR; 
      BEGIN 
       IF LDEF THEN (* PASS DEFAULT FIELDWIDTH *) 
        BEGIN LOADCST(FW,I);
         PARAM.CWDISPL := PFLC + 2; STORE(PARAM,I)
        END;
       RJTOEXT(FNAME) 
      END (* SETWIDTHANDJUMP *);
  
      PROCEDURE FORMATSPEC(FSYS: SETOFSYS; FDPL: ADDRRANGE);
       VAR I,J,K: REGNR; CSTWIDTH: BOOLEAN; 
      BEGIN 
       INSYMBOL; B6DPL := PFLC + FDPL;
       EXPRESSION(FSYS);
       IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(116) 
       ELSE 
        BEGIN CSTWIDTH := GATTR.KIND = CST; 
         IF CSTWIDTH THEN 
          IF GATTR.CVAL.IVAL <= 0 THEN ERROR(305) 
        END;
       LOAD(GATTR,I); 
       IF DEBUG AND NOT CSTWIDTH THEN 
        BEGIN LOADCST(1,J); 
         DECREFX(J);
         NEEDX([0..7],K); 
         GEN15(IXXMX,K,I,J);
         GEN30(TESTX,ORD(NG),K,ASSERR,TERAR); 
         DECREFX(K) 
        END;
       PARAM.CWDISPL := PFLC + FDPL;
       STORE(PARAM,I) 
      END (* FORMATSPEC *); 
  
     BEGIN (*WRITE*)
      WITH FILATTR DO (* SET DEFAULT FILE ATTRIBUTES *) 
       BEGIN TYPTR := TEXTPTR; KIND := VARBL; WORDACC := DRCT;
        VLEVEL := 1; PCKD := FALSE; 
        IF OUTPUTPTR = NIL THEN CWDISPL := 0
        ELSE CWDISPL := OUTPUTPTR^.VADDR
       END; 
      LDRCT := TRUE;
      WITH PARAM DO (* SET PARAMETER ATTRIBUTES *)
       BEGIN TYPTR := TEXTPTR; KIND := VARBL; WORDACC := DRCT;
        VLEVEL := 0; CWDISPL := PFLC; PCKD := FALSE 
       END; 
      NEEDX([1],I);             (*RESERVE A1/X1*) 
      IF SY = LPARENT THEN
       BEGIN PUTOUT := TRUE;
        INSYMBOL; EXPRESSION(FSYS+[COMMA,COLON,RPARENT,IDENT]); 
        IF GATTR.TYPTR <> NIL THEN
         IF GATTR.TYPTR^.FORM = FILES THEN
          BEGIN IF NOT GATTR.TYPTR^.TEXTFILE AND (LKEY = WRITELNKW) 
            THEN ERROR(116);
           IF SY = RPARENT THEN 
            BEGIN IF LKEY = WRITEKW THEN ERROR(116);
             PUTOUT := FALSE
            END 
           ELSE 
            IF SY <> COMMA THEN 
             BEGIN ERROR(116); SKIP(FSYS+[COMMA,RPARENT]) END;
           IF GATTR.WORDACC = DRCT THEN 
            BEGIN FILATTR := GATTR; LDRCT := TRUE END 
           ELSE 
            BEGIN LOADADDRESS(GATTR,I); 
             WITH FILATTR DO
              BEGIN TYPTR := GATTR.TYPTR; 
               VLEVEL := LEVEL; CWDISPL := LC 
              END;
             STORE(FILATTR,I);
             LC := LC + 1;
             IF LC > LCMAX THEN LCMAX := LC;
             LDRCT := FALSE 
            END;
           IF SY = COMMA THEN 
            BEGIN INSYMBOL; 
             EXPRESSION(FSYS+[COMMA,COLON,RPARENT,IDENT]) 
            END 
          END (* FORM = FILES *)
         ELSE IF OUTPUTPTR = NIL THEN ERROR(176); 
        IF PUTOUT THEN
         (*LOOP UNTIL SY <> COMMA*) 
         REPEAT 
          IF FILATTR.TYPTR^.TEXTFILE AND
             (NOT COMPTYPES(GATTR.TYPTR,CHARPTR) OR (SY = COLON)) THEN
           BEGIN LSP := GATTR.TYPTR; DECREFX(1);
            LATTR := FILATTR; LATTR2 := GATTR;
            IF LDRCT THEN (* PASS FILEADDRESS: *) LOADADDRESS(LATTR,J)
            ELSE LOAD(LATTR,J); 
            PARAM.CWDISPL := PFLC; STORE(PARAM,J);
            IF STRING(LSP) THEN (* PASS VALUE TO BE OUTPUT: *)
             BEGIN SHORTSTRING := FULLWORDS(LSP^.SIZE) = 1; 
              IF CONFORMARRAY(LSP) THEN EXTENSION(333); 
              (* DYNAMIC STRINGS ARE NOT SHORTSTRINGS *)
              IF SHORTSTRING THEN LOAD(GATTR,I) 
              ELSE LOADADDRESS(GATTR,I) 
             END
            ELSE LOAD(GATTR,I); 
            PARAM.CWDISPL := PFLC + 1; STORE(PARAM,I);
            IF SY = COLON THEN (* PASS FIELDWIDTH: *) 
             BEGIN FORMATSPEC(FSYS+[COMMA,COLON,RPARENT],2);
              LDEF := FALSE 
             END
            ELSE LDEF := TRUE;
            IF SY = COLON THEN
             BEGIN
              IF LSP <> REALPTR THEN ERROR(124);
              FORMATSPEC(FSYS+[COMMA,RPARENT],3); 
              SETWIDTHANDJUMP(20,EX[WRFEX]) 
             END
            ELSE
              IF COMPTYPES(LSP,INTPTR) THEN 
               SETWIDTHANDJUMP(10,EX[WRIEX])
              ELSE
               IF LSP = REALPTR THEN
                SETWIDTHANDJUMP(22,EX[WREEX]) 
               ELSE 
                IF COMPTYPES(LSP,CHARPTR) THEN
                 IF DEBUG THEN SETWIDTHANDJUMP(1,EX[WRCDEX])
                 ELSE SETWIDTHANDJUMP(1,EX[WRCEX])
                ELSE
                 IF COMPTYPES(LSP,BOOLPTR) THEN 
                  SETWIDTHANDJUMP(10,EX[WRBEX]) 
                 ELSE 
                  IF LSP <> NIL THEN
                   IF STRING(LSP) THEN
                    WITH LSP^ DO
                     IF CONFORMARRAY(LSP) THEN
                      BEGIN LOADDESC(LATTR2,J,1); 
                       LOADDESC(LATTR2,I,2); OPERATION(IXXMX,K,J,I);
                       NEEDX([6,7],I); GEN15(SXXPB,I,K,1); DECREFX(K);
                       PARAM.CWDISPL := PFLC + 3; STORE(PARAM,I); 
                       IF LDEF THEN 
                        BEGIN NEEDX([I],I); 
                         PARAM.CWDISPL := PFLC + 2; STORE(PARAM,I)
                        END;
                       GEN30(SXBPK,7,0,IC+1,PROGR); 
                       RJTOEXT(EX[WRSEX]) 
                      END 
                     ELSE 
                      BEGIN (* PASS STRING LENGTH: *) 
                       LSZ := ALFALENG * SIZE.WORDS + 
                              SIZE.BITS DIV CHARSIZE; 
                       IF SHORTSTRING THEN LOADCST(-LSZ,I)
                       ELSE LOADCST(LSZ,I); 
                       PARAM.CWDISPL := PFLC + 3; 
                       STORE(PARAM,I);
                       SETWIDTHANDJUMP(LSZ,EX[WRSEX]) 
                      END 
                   ELSE ERROR(116); 
           END
          ELSE
           BEGIN LOADFILEWORD(FILATTR,LDRCT,-1);
            WITH LATTR DO 
             BEGIN TYPTR := FILATTR.TYPTR^.FILTYPE; KIND := VARBL;
              WORDACC := INDRCT; CWDISPL := 0; VWDISPL := 1;
              PCKD := FALSE 
             END; 
            ASSIGNTO(LATTR);
            NEEDX([1],I); (*RESET REFERENCE TO X1*) 
           IF FILATTR.TYPTR^.TEXTFILE THEN GETCPUTC(PUTCHEX)
           ELSE 
            BEGIN LOADFILEWORD(FILATTR,LDRCT,0); RJTOEXT(EX[PUTBEX])
            END;
           END; 
          B6DPL := PFLC;
          EXITLOOP := SY <> COMMA;
          IF NOT EXITLOOP THEN
           BEGIN INSYMBOL; NEEDX([1],I); (*RESERVE A1/X1*)
            EXPRESSION(FSYS+[COMMA,COLON,RPARENT,IDENT])
           END; 
         UNTIL EXITLOOP;
        EXPECTSYMBOL(RPARENT,4) 
       END (*SY = LPARENT*) 
      ELSE
       IF LKEY = WRITEKW THEN ERROR(116)
       ELSE 
        IF OUTPUTPTR = NIL THEN ERROR(176); 
      IF LKEY = WRITELNKW THEN
       BEGIN LOADFILEWORD(FILATTR,LDRCT,-1);
        RJTOEXT(EX[PUTLNEX])
       END; 
      IF NOT LDRCT THEN LC := LC - 1
     END (*WRITE*) ;
  
     PROCEDURE STRINGPARAM; 
      VAR I,J: REGNR; 
     BEGIN EXPECTSYMBOL(LPARENT,9); 
      EXPRESSION(FSYS+[RPARENT]); 
      LOADADDRESS(GATTR,I); BXIXJ(1,I); 
      IF GATTR.TYPTR <> NIL THEN
       IF STRING(GATTR.TYPTR) THEN
        IF CONFORMARRAY(GATTR.TYPTR) THEN 
         BEGIN LOADDESC(GATTR,I,1); 
          LOADDESC(GATTR,J,2); OPERATION(IXXMX,I,I,J);
          GEN15(SXXPB,I,I,1); BXIXJ(2,I); 
         END
        ELSE
        WITH GATTR.TYPTR^.SIZE DO 
         BEGIN LOADCST(WORDS*ALFALENG+BITS DIV CHARSIZE,I); BXIXJ(2,I)
         END
       ELSE ERROR(116); 
      EXPECTSYMBOL(RPARENT,4) 
     END (* STRINGPARAM *); 
  
     PROCEDURE MESSAGE; 
     BEGIN STRINGPARAM; 
      RJTOEXT(EX[MSGEX])
     END (*MESSAGE*) ;
  
     PROCEDURE PAGE;
      VAR I: REGNR; 
     BEGIN (* PAGE *) 
      NEEDX([1],I);  (* RESERVE A1/X1 *)
      IF SY = LPARENT THEN
       BEGIN  INSYMBOL;  VARIABLE(FSYS+[RPARENT]);
        IF GATTR.TYPTR <> NIL THEN
         IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(116)
         ELSE IF NOT GATTR.TYPTR^.TEXTFILE THEN ERROR(116); 
        EXPECTSYMBOL(RPARENT,4) 
       END
      ELSE (* USE OUTPUT *) 
       WITH GATTR DO
        BEGIN  TYPTR := TEXTPTR; KIND := VARBL; WORDACC := DRCT;
         VLEVEL := 1;  PCKD := FALSE; 
         IF OUTPUTPTR = NIL THEN BEGIN ERROR(176); CWDISPL := 0 END 
         ELSE CWDISPL := OUTPUTPTR^.VADDR 
        END;
      LOADFILEWORD(GATTR,TRUE,-1);
      RJTOEXT(EX[PAGEEX]) 
     END (*PAGE*) ; 
  
     PROCEDURE TIMEDATE(FEXT: EXTERNALNAME);
      VAR I: REGNR; 
     BEGIN EXPECTSYMBOL(LPARENT,9); 
      VARIABLE(FSYS+[RPARENT]); 
      IF NOT COMPTYPES(GATTR.TYPTR,ALFAPTR) THEN ERROR(116);
      LOADADDRESS(GATTR,I); BXIXJ(1,I); 
      RJTOEXT(EX[FEXT]);
      EXPECTSYMBOL(RPARENT,4) 
     END (*TIMEDATE*) ; 
  
     PROCEDURE HALT;
     BEGIN IF SY = LPARENT THEN STRINGPARAM 
       ELSE GEN15(SXBPB,1,0,0); 
      RJTOEXT(EX[HALTEX]) 
     END (* HALT *);
  
    PROCEDURE INDEXUNPACKEDARRAY(VAR SOURCE: ATTR;
                                 INDEX: ATTR; LOW: INTEGER);
     VAR WORDS: ADDRRANGE; REC: CSTREC; I,J,K: REGNR; 
       CW: INTEGER; LACC: ACCESSKIND; 
    BEGIN (* INDEXUNPACKEDARRAY *)
     IF (SOURCE.TYPTR <> NIL) AND (INDEX.TYPTR <> NIL) THEN 
      WITH SOURCE,TYPTR^ DO 
       BEGIN
        LACC := DRCT; 
        IF AELTYPE <> NIL THEN WORDS := FULLWORDS(AELTYPE^.SIZE)
        ELSE WORDS := 1;
        IF INDEX.KIND = CST THEN
         BEGIN CW := CWDISPL + (INDEX.CVAL.IVAL - LOW) * WORDS; 
          IF ABS(CW) > MAXADDR THEN 
           BEGIN CWDISPL := 0;
            LOADCST(CW,K); LACC := INXD 
           END
          ELSE CWDISPL := CW
         END
        ELSE
         BEGIN CW := CWDISPL - LOW * WORDS; 
          LOAD(INDEX,I);
          IF ABS(CW) > MAXADDR THEN 
           BEGIN
            IF ABS(LOW) > MAXADDR THEN
             BEGIN LOADCST(LOW,K); OPERATION(IXXMX,K,I,K) END 
            ELSE
             BEGIN DECREFX(I); NEEDX([0..7],K); 
              GEN30(SXXPK,K,I,-LOW,ABSR)
             END; 
            I := K
           END
          ELSE CWDISPL := CW; 
          EXPREP(WORDS,REC);
          IF REC.CKIND <> NOP THEN OPTMULT(I,REC,TRUE,K)
          ELSE
           BEGIN LOADCST(WORDS,J);
            OPERATION(DXXTX,K,I,J)
           END; 
          LACC := INXD
         END; 
        IF LACC <> DRCT THEN
         IF WORDACC = DRCT THEN 
          BEGIN VWDISPL := K; WORDACC := INXD END 
         ELSE 
          BEGIN OPERATION(IXXPX,J,VWDISPL,K); VWDISPL := J END
       END
    END (* INDEXUNPACKEDARRAY *); 
  
    PROCEDURE PACK; 
     VAR BITS: BITRANGE; FW,LADDR: ADDRRANGE; 
       I,J,K,Q,R,S,T: REGNR; LSP,LSP1: STP; SOURCE,INDEX: ATTR; 
       PW,EPW,LOW,HIGH,LMIN,LMAX: INTEGER; LEFTADJ: BOOLEAN;
  
     PROCEDURE PACKWORD(NROFELS: EPWRANGE); 
      VAR LADDR: ADDRRANGE; SHFT: BITRANGE; 
     BEGIN NEEDB(S); GEN30(SBBPK,S,R,NROFELS,ABSR); 
      GEN15(BXXMX,J,J,J); NOOP; LADDR := IC;
      GEN15(SABPB,K,R,0); 
      IF LEFTADJ THEN 
       BEGIN GEN15(BXXTX,K,I,K); GEN15(BXXPX,J,J,K);
        GEN15(LXJK,J,0,BITS)
       END
      ELSE
       BEGIN GEN15(BXXTCX,K,K,I); GEN15(LXJK,J,0,BITS); 
        GEN15(BXXPX,J,J,K)
       END; 
      GEN15(SBBPB,R,R,1); GEN30(NE,R,S,LADDR,PROGR);
      BRGS[S].BCONT := FREE;
      SHFT := WORDSIZE - NROFELS*BITS;
      IF SHFT > 0 THEN GEN15(LXJK,J,0,SHFT) 
     END (*PACKWORD*) ; 
  
    BEGIN (*PACK*)
     EXPECTSYMBOL(LPARENT,9); 
     VARIABLE(FSYS+[COMMA,RPARENT]); SOURCE := GATTR; 
     LSP := NIL; LSP1 := NIL; LOW := 0; HIGH := 0; LEFTADJ := FALSE;
     IF GATTR.TYPTR <> NIL THEN 
      WITH GATTR.TYPTR^ DO
       IF FORM = ARRAYS THEN
        IF  NOT PCKDARR THEN
         IF CONFORMARRAY(GATTR.TYPTR) THEN ERROR(224) 
         ELSE 
          BEGIN LSP := INXTYPE; LSP1 := AELTYPE;
           IF LSP <> NIL THEN GETBOUNDS(LSP,LOW,HIGH);
           IF LSP1 <> NIL THEN LEFTADJ := LSP1^.FORM IN [ARRAYS,RECORDS]
          END 
        ELSE ERROR(116) 
       ELSE ERROR(116); 
     EXPECTSYMBOL(COMMA,20);
     EXPRESSION(FSYS+[COMMA,RPARENT]); INDEX := GATTR;
     IF NOT COMPTYPES(GATTR.TYPTR,LSP) THEN ERROR(116); 
     EXPECTSYMBOL(COMMA,20);
     VARIABLE(FSYS+[RPARENT]);
     IF GATTR.TYPTR <> NIL THEN 
      WITH GATTR.TYPTR^ DO
       IF FORM = ARRAYS THEN
        BEGIN 
         IF PCKDARR AND (AELTYPE = LSP1) THEN 
          IF CONFORMARRAY(GATTR.TYPTR) THEN ERROR(224)
          ELSE
           BEGIN LMIN := 0; LMAX := 0;
            IF INXTYPE <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX);
            IF LMAX - LMIN > HIGH - LOW THEN ERROR(116);
            WITH INDEX DO 
             IF KIND = CST THEN 
              BEGIN 
               IF (CVAL.IVAL < LOW) OR (CVAL.IVAL > HIGH-(LMAX-LMIN)) 
                THEN ERROR(302) 
              END 
             ELSE 
              BEGIN 
               IF DEBUG THEN
                BEGIN LOAD(INDEX,I);
                 CHECKBNDS(I,LOW,HIGH-(LMAX-LMIN),INXERR);
                 DECREFX(I) 
                END 
              END;
            IF PARTWORDELS THEN 
             BEGIN
              (*LOAD SOURCE ADDRESS (SOURCE[INDEX]) INTO B-R:*) 
              NEEDB(R); 
              IF (SOURCE.TYPTR <> NIL) AND (INDEX.TYPTR <> NIL) THEN
               BEGIN SOURCE.CWDISPL := SOURCE.CWDISPL - LOW;
                IF INDEX.KIND = CST THEN
                 BEGIN SOURCE.CWDISPL := SOURCE.CWDISPL+INDEX.CVAL.IVAL;
                  LOADADDRESS(SOURCE,I) 
                 END
                ELSE
                 BEGIN LOADADDRESS(SOURCE,J); LOAD(INDEX,K);
                  DECREFX(J); NEEDX([0..7],I); GEN15(IXXPX,I,K,J) 
                 END; 
                GEN15(SBXPB,R,I,0); DECREFX(I)
               END; 
              IF AELTYPE <> NIL THEN BITS := AELTYPE^.SIZE.BITS 
              ELSE BITS := 1; 
              EPW := ELSPERWORD;
              FW := (LMAX-LMIN+1) DIV EPW;
              PW := (LMAX-LMIN+1) - FW*EPW; 
              NEEDX([1..5],K); ARGS[K].ACONT := UNSPECADDR; 
              NEEDX([6,7],J);  ARGS[J].ACONT := UNSPECADDR; 
              IF LEFTADJ THEN LOADMSK(BITS,I) 
              ELSE LOADMSK(WORDSIZE-BITS,I);
              IF FW > 0 THEN
               BEGIN
                IF FW <> 1 THEN 
                 BEGIN NEEDX([0..7],T); GEN15(SXBPB,T,4,0); 
                  LOADADDRESS(GATTR,S); DECREFX(S); NEEDB(Q); 
                  GEN15(SBXPB,4,S,0); GEN30(SBBPK,Q,4,FW,ABSR); 
                  NOOP; LADDR := IC 
                 END; 
                PACKWORD(EPW);
                IF FW = 1 THEN STORE(GATTR,J) 
                ELSE
                 BEGIN GEN15(SABPB,J,4,0); DECREFX(J);
                  GEN15(SBBPB,4,4,1); GEN30(NE,4,Q,LADDR,PROGR);
                  GEN15(SBXPB,4,T,0); DECREFX(T)
                 END
               END (*FW > 0*) ; 
              IF PW > 0 THEN
               BEGIN PACKWORD(PW);
                IF FW > 0 THEN GEN15(SAAPB,J,J,1) ELSE STORE(GATTR,J);
               END
             END
            ELSE
             BEGIN (* NOT PARTWORDELS *)
              INDEXUNPACKEDARRAY(SOURCE,INDEX,LOW); 
              INDEX := GATTR;  (* DESTINATION *)
              GATTR := SOURCE; (* SOURCE *) 
              GATTR.TYPTR := INDEX.TYPTR; 
              ASSIGNTO(INDEX) 
             END
           END
         ELSE ERROR(116)
        END 
       ELSE ERROR(116); 
     CLEARREGS; 
     EXPECTSYMBOL(RPARENT,4)
    END (*PACK*) ;
  
    PROCEDURE UNPACK; 
     VAR BITS: BITRANGE; FW,LADDR: ADDRRANGE; 
       I,J,K,Q,R,T: REGNR; LSP,LSP1: STP; SOURCE,DEST: ATTR;
       EPW,PW,LOW,HIGH,LMIN,LMAX: INTEGER; LMODE: (USRADJ,SRADJ,USLADJ);
  
     PROCEDURE UNPACKWORD(NROFELS: EPWRANGE); 
      VAR LADDR: ADDRRANGE; S: REGNR; 
     BEGIN NEEDB(S); GEN30(SBBPK,S,R,NROFELS,ABSR); 
      NOOP; LADDR := IC;
      XRGS[K].XCONT := OTHER; 
      CASE LMODE OF 
       USRADJ:  
        BEGIN GEN15(LXJK,K,0,BITS); GEN15(BXXTCX,J,K,I) END;
       SRADJ: 
        BEGIN GEN15(BXX,J,K,K); GEN15(LXJK,K,0,BITS); 
         GEN15(AXJK,J,0,WORDSIZE-BITS)
        END;
       USLADJ:  
        BEGIN GEN15(BXXTX,J,I,K); GEN15(LXJK,K,0,BITS) END
      END;
      GEN15(SABPB,J,R,0); GEN15(SBBPB,R,R,1); 
      GEN30(NE,R,S,LADDR,PROGR); BRGS[S].BCONT := FREE
     END (*UNPACKWORD*);
  
    BEGIN (*UNPACK*)
     EXPECTSYMBOL(LPARENT,9); 
     EXPRESSION(FSYS+[COMMA,RPARENT]); SOURCE := GATTR; 
     LSP := NIL; LSP1 := NIL; LMIN := 0; LMAX := 0; 
     FW := 1; PW := 0; EPW := 60; BITS := 1; LMODE := USRADJ; 
     IF GATTR.TYPTR <> NIL THEN 
      WITH GATTR.TYPTR^ DO
       IF FORM = ARRAYS THEN
        IF PCKDARR THEN 
         IF CONFORMARRAY(GATTR.TYPTR) THEN ERROR(224) 
         ELSE 
         BEGIN LSP := INXTYPE; LSP1 := AELTYPE; 
          IF LSP <> NIL THEN GETBOUNDS(LSP,LMIN,LMAX);
          IF (LSP1 <> NIL) AND PARTWORDELS THEN 
           BEGIN
            WITH LSP1^ DO 
             BEGIN BITS := SIZE.BITS; 
              IF FORM = SUBRANGE THEN 
               BEGIN IF MIN.IVAL < 0 THEN LMODE := SRADJ
               END
              ELSE
               IF FORM IN [ARRAYS,RECORDS] THEN LMODE := USLADJ 
             END; 
            EPW := ELSPERWORD;
            FW := (LMAX - LMIN + 1) DIV EPW;
            PW := (LMAX - LMIN + 1) - FW*EPW
           END
         END
        ELSE ERROR(116) 
       ELSE ERROR(116); 
     EXPECTSYMBOL(COMMA,20);
     VARIABLE(FSYS+[COMMA,RPARENT]); DEST := GATTR; 
     IF GATTR.TYPTR <> NIL THEN 
      WITH GATTR.TYPTR^ DO
       IF FORM = ARRAYS THEN
        IF NOT PCKDARR AND (AELTYPE = LSP1) THEN
         IF CONFORMARRAY(GATTR.TYPTR) THEN ERROR(224) 
         ELSE 
         BEGIN LOW := 0; HIGH := 0; 
          IF INXTYPE <> NIL THEN GETBOUNDS(INXTYPE,LOW,HIGH); 
          IF LMAX - LMIN > HIGH - LOW THEN ERROR(116) 
         END
        ELSE ERROR(116) 
       ELSE ERROR(116); 
     EXPECTSYMBOL(COMMA,20);
     EXPRESSION(FSYS+[RPARENT]);
     IF NOT COMPTYPES(GATTR.TYPTR,LSP) THEN ERROR(116); 
     IF (SOURCE.TYPTR <> NIL) AND (DEST.TYPTR <> NIL) 
      AND (GATTR.TYPTR <> NIL) THEN 
      BEGIN 
       IF GATTR.KIND = CST THEN 
        WITH GATTR.CVAL DO
         IF (IVAL < LOW) OR (IVAL > HIGH - (LMAX - LMIN)) THEN
          ERROR(302)
       ELSE 
        IF DEBUG THEN 
         BEGIN
          LOAD(GATTR,I);
          CHECKBNDS(I,LOW,HIGH-(LMAX-LMIN),INXERR); 
          DECREFX(I)
         END; 
       IF SOURCE.TYPTR^.PARTWORDELS THEN
        BEGIN 
         (*LOAD DESTINATION ADDRESS (DEST[GATTR]) INTO B-R:*) 
         NEEDB(R);
         DEST.CWDISPL := DEST.CWDISPL - LOW;
         IF GATTR.KIND = CST THEN 
          BEGIN DEST.CWDISPL := DEST.CWDISPL + GATTR.CVAL.IVAL; 
           LOADADDRESS(DEST,I)
          END 
         ELSE 
           BEGIN LOADADDRESS(DEST,I); LOAD(GATTR,J);
           OPERATION(IXXPX,K,I,J); I := K 
          END;
         GEN15(SBXPB,R,I,0); DECREFX(I);
         NEEDX([6,7],J); ARGS[J].ACONT := UNSPECADDR; 
         IF LMODE = USRADJ THEN LOADMSK(WORDSIZE-BITS,I)
         ELSE 
          IF LMODE = USLADJ THEN LOADMSK(BITS,I); 
         IF FW > 0 THEN 
          BEGIN 
           IF (FW > 1)OR (PW > 0) THEN
            BEGIN NEEDB(Q); LOADADDRESS(SOURCE,K); GEN15(SBXPB,Q,K,0);
             DECREFX(K) 
            END;
           IF FW > 1 THEN 
            BEGIN NEEDX([0..7],T); GEN15(SXBPB,T,4,0);
             GEN30(SBBPK,4,Q,FW,ABSR);
             NOOP; LADDR := IC
            END;
           IF (FW = 1) AND (PW = 0) THEN
            LOAD(SOURCE,K)
           ELSE 
            BEGIN NEEDX([1..5],K); ARGS[K].ACONT := UNSPECADDR; 
             GEN15(SABPB,K,Q,0) 
            END;
           UNPACKWORD(EPW); 
           IF FW > 1 THEN 
            BEGIN GEN15(SBBPB,Q,Q,1); GEN30(NE,Q,4,LADDR,PROGR);
             GEN15(SBXPB,4,T,0); DECREFX(T) 
            END 
          END;
         IF PW > 0 THEN 
          BEGIN 
           IF FW > 0 THEN 
            IF FW = 1 THEN GEN15(SABPB,K,Q,1) ELSE GEN15(SABPB,K,Q,0) 
           ELSE 
            LOAD(SOURCE,K); 
           UNPACKWORD(PW) 
          END 
        END 
       ELSE 
        BEGIN (* NOT PARTWORDELS *) 
         INDEXUNPACKEDARRAY(DEST,GATTR,LOW);
         GATTR := SOURCE; 
         DEST.TYPTR := GATTR.TYPTR; 
         ASSIGNTO(DEST) 
        END 
      END;
     CLEARREGS; 
     EXPECTSYMBOL(RPARENT,4)
    END (*UNPACK*); 
  
     PROCEDURE NEWDISPOSE(FEXT: EXTERNALNAME);
      LABEL 1;
      VAR LSP,LSP1: STP; LVAL: VALU; LSIZE: ADDRRANGE; I: REGNR;
        LELTYPE: STP; 
        LFTYPE,LDBG: BOOLEAN; 
        LXRGS: XRGSTATUS; 
  
     BEGIN (* NEWDISPOSE *) 
      EXPECTSYMBOL(LPARENT,9);
      IF LKEY = DISPOSEKW THEN EXPRESSION(FSYS+[COMMA,RPARENT]) 
      ELSE (* NEW *)
       BEGIN  NEEDX([6],I);  (* PREVENT USE OF X6 *)
        VARIABLE(FSYS+[COMMA,RPARENT]);  DECREFX(6);
       END; 
      LSP := NIL;  LSIZE := 0;  LELTYPE := NIL; 
      LFTYPE := FALSE;
      LDBG := FALSE;
      IF GATTR.TYPTR <> NIL THEN
       WITH GATTR.TYPTR^ DO 
        IF FORM = POINTER THEN
         BEGIN  LDBG := DBG;
          LELTYPE := ELTYPE;
          IF LELTYPE <> NIL THEN WITH LELTYPE^ DO 
           BEGIN LSIZE := FULLWORDS(SIZE);
            IF FORM = RECORDS THEN LSP := RECVAR; 
            LFTYPE := FTYPE 
           END
         END
        ELSE ERROR(116);
      WHILE SY = COMMA DO 
       BEGIN INSYMBOL; CONSTANT(FSYS+[COMMA,RPARENT],LSP1,LVAL);
        IF LSP = NIL THEN ERROR(158)
        ELSE
          IF LSP^.TAGFIELDP <> NIL THEN 
           IF STRING(LSP1)OR (LSP1 = REALPTR) THEN ERROR(159) 
           ELSE 
            IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1) THEN
             BEGIN
              LSP1 := LSP^.FSTVAR;
              WHILE LSP1 <> NIL DO
               WITH LSP1^ DO
                IF VARVAL.IVAL = LVAL.IVAL THEN 
                 BEGIN LSP := SUBVAR; LSIZE := FULLWORDS(SIZE); 
                  GOTO 1
                 END
                ELSE LSP1 := NXTVAR;
              ERROR(158); 
              LSIZE := FULLWORDS(LSP^.SIZE); LSP := NIL 
             END
            ELSE ERROR(116);
     1:  END (*WHILE*) ;
      IF LDBG THEN FEXT := SUCC(FEXT);
      IF LKEY = DISPOSEKW THEN
       BEGIN
        LOAD(GATTR,I);
        IF LFTYPE THEN (* MUST CLOSE FILES *) 
         BEGIN
          (* SAVE POINTER VALUE *)
          IF I < 6 THEN BEGIN BXIXJ(6,I); I := 6 END; 
          GEN30(SABPK,I,5,LC,ABSR); 
          LC := LC + 1; 
          IF LC > LCMAX THEN LCMAX := LC; 
          IF DEBUG AND LDBG THEN CHECKPTRREF(I);
          GEN15(SBXPB,2,I,0);  DECREFX(I);
          DYNFILE := TRUE;  EXTFILE := FALSE; 
          SUBFILES(LELTYPE,0,CLOSEFL);
          LC := LC - 1; 
          GEN30(SABPK,1,5,LC,ABSR); (* RESTORE PTR VALUE *) 
         END
        ELSE BXIXJ(1,I);
        GEN30(SBBPK,7,0,LSIZE,ABSR);
        RJTOEXT(EX[FEXT]) 
       END
      ELSE  (* NEW *) 
       BEGIN  SAVEREFXRGS(LXRGS); 
        IF LSIZE >= MAXADDR THEN ERROR(262);
        GEN30(SBBPK,7,0,LSIZE,ABSR);
        RJTOEXT(EX[FEXT]);
        RELOADREFXRGS(LXRGS); 
        STORE(GATTR,6); 
        IF LFTYPE THEN (* OPEN FILES *) 
         BEGIN  GEN15(SBXPB,2,6,0); 
          DYNFILE := TRUE;  EXTFILE := FALSE; 
          SUBFILES(LELTYPE,0,OPENFL)
         END
       END; 
      EXPECTSYMBOL(RPARENT,4) 
     END (*NEWDISPOSE*) ; 
  
  
     PROCEDURE FILEFUNCS; 
      VAR LATTR: ATTR;
     BEGIN
      IF SY = LPARENT THEN
       BEGIN INSYMBOL; VARIABLE(FSYS+[RPARENT]);
        EXPECTSYMBOL(RPARENT,4) 
       END
      ELSE
       WITH GATTR DO
        BEGIN TYPTR := TEXTPTR; KIND := VARBL; WORDACC := DRCT; 
         VLEVEL := 1; PCKD := FALSE;
         IF INPUTPTR = NIL THEN 
          BEGIN ERROR(175); CWDISPL := 0 END
         ELSE WITH INPUTPTR^ DO 
          BEGIN CWDISPL:=VADDR; TYPTR:=IDTYPE END;
        END;
      IF GATTR.TYPTR <> NIL THEN
       WITH GATTR, TYPTR^ DO
        IF FORM = FILES THEN
         BEGIN
          IF LKEY = EOLNKW THEN 
           BEGIN IF NOT TEXTFILE THEN ERROR(125); 
            CWDISPL := CWDISPL + CHEFET - 1 (*P-PTR*);
            IF DEBUG THEN 
             BEGIN LATTR := GATTR;
              LATTR.CWDISPL := CWDISPL + 1; 
              LOAD(LATTR,I);
              GEN30(TESTX,ORD(NG),I,EOLERR,TERAR); DECREFX(I) 
             END
           END
          ELSE
           IF TEXTFILE THEN CWDISPL := CWDISPL + CHEFET 
           ELSE CWDISPL := CWDISPL + BINEFET; (*EFET*)
          LOAD(GATTR,I);
          IF LKEY = EOSKW THEN
           BEGIN IF NOT SEGFILE THEN ERROR(125) END 
          ELSE
           IF LKEY = EOFKW THEN 
            IF SEGFILE THEN 
             BEGIN NEEDX([0..7],J); GEN15(LXBX,J,1,I);
              DECREFX(I); I := J
             END; 
          TYPTR := BOOLPTR; KIND := COND; CONDCD := PL; CDR := I; 
         END
        ELSE ERROR(125);
     END (* FILEFUNCS *); 
  
      PROCEDURE INLINEFUNCS;
       VAR I,J,K,L: REGNR;
           LSYS: SETOFSYS;
           GINT,GREAL: BOOLEAN; 
      BEGIN EXPECTSYMBOL(LPARENT,9);
       LSYS:=[RPARENT]; 
       IF LKEY = TRUNCKW THEN 
        LSYS := [COMMA,RPARENT] (* TRUNC MAY HAVE 2 ARGUMENTS *); 
       EXPRESSION(FSYS+LSYS); LOAD(GATTR,I);
       IF LKEY IN [ODDKW,TRUNCKW..SQRKW,UNDEFINEDKW..CARDKW] THEN 
        NEEDX([0..7],K); (*FUNCTION NEEDING ANOTHER X REGISTER*)
       GINT := COMPTYPES(GATTR.TYPTR,INTPTR); 
       IF (LKEY IN [ODDKW,CHRKW]) AND NOT GINT THEN ERROR(125); 
       GREAL := GATTR.TYPTR = REALPTR;
       IF (LKEY IN [ROUNDKW,TRUNCKW,UNDEFINEDKW,EXPOKW]) AND NOT GREAL
        THEN ERROR(125);
       CASE LKEY OF 
        ODDKW:  
           BEGIN GEN15(BXX,K,I,I);
           GEN15(LXJK,K,0,59(*WORDSIZE-1*));
           GEN15(BXXMX,K,I,K); DECREFX(I);
           WITH GATTR DO
            BEGIN TYPTR := BOOLPTR; KIND := COND; CONDCD := PL; 
             CDR := K 
            END 
           END; 
        UNDEFINEDKW:  
           BEGIN GEN15(SXBPB,K,1,0);
           GEN30(TESTX,ORD(XID),I,IC+1+ORD(PC.CP >= 3),PROGR);
           GEN30(TESTX,ORD(XOR),I,IC+1,PROGR);
           GEN30(SXBPK,K,0,0,ABSR); NOOP; 
           GATTR.TYPTR := BOOLPTR;
           END; 
        ROUNDKW:  
           BEGIN LOADCST(0,J); DECREFX(J);
            NEEDX([0..7],K); NEEDX([0..7],L); 
            GEN15(PXBX,K,0,J); GEN15(FXXPX,L,I,K); GEN15(DXXPX,K,I,K);
            GEN15(RXXPX,K,L,K); DECREFX(L); GEN15(UXBX,K,0,K);
            LOADCST(0,J); GEN15(IXXPX,K,K,J); DECREFX(J)
           END; 
        TRUNCKW:  
           BEGIN
            NEEDB(J); DECREFX(I); GEN15(UXBX,K,J,I);
            IF SY = COMMA  THEN 
             BEGIN EXTENSION(326); INSYMBOL; EXPRESSION(FSYS+[RPARENT]);
              IF GATTR.TYPTR <> NIL THEN
               IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN
                IF GATTR.KIND = CST THEN
                 BEGIN GEN30(SBBPK,J,J,GATTR.CVAL.IVAL,ABSR); 
                       GATTR.KIND:=EXPR 
                 END
                ELSE BEGIN LOAD(GATTR,I); GEN15(SBXPB,J,I,J); DECREFX(I)
                     END
               ELSE ERROR(125)
             END; 
            GEN15(LXBX,K,J,K); BRGS[J].BCONT := FREE; 
            LOADCST(0,I); GEN15(IXXPX,K,K,I)
           END; 
        EXPOKW: 
           BEGIN NEEDB(J);
           GEN15(UXBX,K,J,I); GEN30(SXBPK,K,J,47,ABSR); 
           BRGS[J].BCONT := FREE; 
           END; 
        ABSKW:  
           BEGIN IF (GINT OR GREAL) THEN
            BEGIN GEN15(BXX,K,I,I); GEN15(AXJK,K,0,59(*WORDSIZE-1*)); 
             GEN15(BXXMX,K,K,I) 
            END 
           ELSE ERROR(125)
           END; 
        SQRKW:  
           BEGIN IF GINT THEN 
            GEN15(DXXTX,K,I,I)
           ELSE 
            IF GREAL THEN 
             GEN15(RXXTX,K,I,I) 
            ELSE ERROR(125) 
           END; 
        ORDKW:  
           BEGIN IF GATTR.TYPTR <> NIL THEN 
            IF GATTR.TYPTR^.FORM > POINTER THEN ERROR(125)
            ELSE IF (GATTR.TYPTR^.FORM = POINTER) OR
                    (GATTR.TYPTR = REALPTR) THEN EXTENSION(327);
           END; 
        CHRKW:  
           GATTR.TYPTR := CHARPTR;
        PREDKW, 
        SUCCKW: 
           BEGIN IF GATTR.TYPTR <> NIL THEN 
            IF (GATTR.TYPTR^.FORM > SUBRANGE) OR GREAL THEN 
             ERROR(125);
            LOADCST(2*ORD(LKEY=SUCCKW)-1,J);
            DECREFX(J); NEEDX([0..7],K);
            GEN15(IXXPX,K,I,J)
           END; 
        CARDKW: 
           BEGIN IF GATTR.TYPTR <> NIL THEN 
            IF GATTR.TYPTR^.FORM <> POWER THEN ERROR(125);
           GEN15(CXX,K,I,I) 
           END
        END (*CASE*); 
       IF LKEY IN [ROUNDKW,TRUNCKW,ABSKW,SQRKW,PREDKW,SUCCKW, 
                   UNDEFINEDKW,EXPOKW,CARDKW] THEN
                  (* FUNCTIONS RETURNING RESULT IN K REGNR *) 
        BEGIN DECREFX(I); GATTR.EXPREG := K END;
       IF LKEY IN [ROUNDKW,TRUNCKW,ORDKW,EXPOKW,CARDKW] THEN
                  (* FUNCTIONS FORCING INTEGER RESULT *)
        GATTR.TYPTR := INTPTR;
       EXPECTSYMBOL(RPARENT,4)
     END (* INLINEFUNCS *); 
  
     PROCEDURE SETFUNCTIONRESULT(VAR LXRGS: XRGSTATUS; TYP: STP); 
      VAR I: REGNR; 
     BEGIN (* SETFUNCTIONRESULT *)
      XRGS := LXRGS;
      IF XRGS[6].XCONT <> AVAIL THEN
       BEGIN NEEDX([0..7],I); GEN15(BXX,I,6,6) END
      ELSE I := 6;
      CLEARREGS;
      WITH XRGS[I] DO 
       BEGIN XCONT := OTHER; REFNR := 1 END;
      RELOADREFXRGS(LXRGS); 
      WITH GATTR DO 
       BEGIN KIND := EXPR; EXPREG := I; TYPTR := TYP END
     END (* SETFUNCTIONRESULT *); 
  
     PROCEDURE CLOCKF;
      VAR LXRGS: XRGSTATUS; 
     BEGIN SAVEREFXRGS(LXRGS); RJTOEXT(EX[CLOCKEX]);
      SETFUNCTIONRESULT(LXRGS,INTPTR) 
     END (*CLOCKF*) ; 
  
     PROCEDURE ARITHFUNCS(FEXT: EXTERNALNAME);
      VAR LXRGS: XRGSTATUS; I,K: REGNR; 
     BEGIN EXPECTSYMBOL(LPARENT,9); 
      SAVEREFXRGS(LXRGS); CLEARREGS;
      EXPRESSION(FSYS+[RPARENT]); 
      LOAD(GATTR,I);
      IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN 
       BEGIN PACKANDNORM(I); GATTR.TYPTR := REALPTR END;
      IF I <> 1 THEN
       BEGIN NEEDX([1],K); BXIXJ(1,I) END;
      IF GATTR.TYPTR <> REALPTR THEN ERROR(125);
      IF LKEY IN [SINKW,COSKW] THEN GEN15(SBBPB,3,ORD(LKEY=COSKW),0); 
      RJTOEXT(EX[FEXT]);
      SETFUNCTIONRESULT(LXRGS,REALPTR); 
      EXPECTSYMBOL(RPARENT,4) 
     END (* ARITHFUNCS *);
  
     PROCEDURE CALLUSERDECLARED;
      VAR NXT,LCP: CTP; LSP,LSP1: STP; LKIND: IDKIND; 
        L,M: LEVRANGE; I,K,LXPAR: REGNR; PARAM: ATTR; 
        PVDISP,LDSP,LB6DPL: ADDRRANGE; LXRGS: XRGSTATUS;
        LMIN,LMAX: INTEGER; FTN: BOOLEAN; 
        PASS: (VAL,VARADDR,ARRDESC,PROCDESC); 
  
      FUNCTION CONFORMABLE(FSP1,FSP2: STP; FDISPL: SHRTINT): BOOLEAN; 
       (* DECIDE WHETHER THE STRUCTURE DEFINED BY THE ACTUAL ARRAY
          PARAMETER FSP2 IS CONFORMABLE TO THE FORMAL CONFORMANT
          ARRAY PARAMETER FSP1.  RUNTIME TESTS MAY BE REQUIRED. *)
       VAR CONF: BOOLEAN; LSP1,LSP2: STP; I,J,K: REGNR; 
           LMIN1,LMIN2,LMAX1,LMAX2: INTEGER;
      BEGIN (* CONFORMABLE *) 
       CONF := TRUE;
       IF FSP1 <> FSP2 THEN 
        IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN 
         BEGIN CONF := FALSE; 
          IF (FSP1^.FORM = ARRAYS) AND (FSP2^.FORM = ARRAYS) THEN 
           IF FSP1^.CONFORMANT THEN 
            IF CONFORMABLE(FSP1^.AELTYPE,FSP2^.AELTYPE,FDISPL+3) AND
               (FSP1^.PCKDARR = FSP2^.PCKDARR) THEN 
             BEGIN CONF := TRUE;
              LSP1 := FSP1^.INXTYPE; LSP2 := FSP2^.INXTYPE; 
              IF (LSP1 <> NIL) AND (LSP2 <> NIL) THEN 
               IF LSP1^.BOUNDTYPE <> NIL THEN 
                BEGIN GETBOUNDS(LSP1^.BOUNDTYPE,LMIN1,LMAX1); 
                 IF FSP2^.CONFORMANT THEN 
                  BEGIN 
                   CONF := COMPTYPES(LSP1^.BOUNDTYPE,LSP2^.BOUNDTYPE);
                   IF LSP2^.BOUNDTYPE <> NIL THEN 
                    BEGIN GETBOUNDS(LSP2^.BOUNDTYPE,LMIN2,LMAX2); 
                     IF (LMIN2 > LMAX1) OR (LMAX2 < LMIN1) THEN 
                      CONF := FALSE (* DISJOINT RANGES *) 
                     ELSE 
                      IF ((LMAX2 > LMAX1) OR (LMIN2 < LMIN1)) AND 
                         DEBUG THEN 
                       BEGIN
                        IF LMAX2 > LMAX1 THEN 
                         BEGIN LOADDESC(GATTR,K,FDISPL+1);
                          LOADCST(LMAX1,I); DECREFX(I); 
                          GEN15(IXXMX,K,I,K)
                         END; 
                        IF LMIN2 < LMIN1 THEN 
                         BEGIN LOADDESC(GATTR,J,FDISPL+2);
                          LOADCST(LMIN1,I); DECREFX(I); 
                          GEN15(IXXMX,J,J,I); 
                          IF LMAX2 > LMAX1 THEN GEN15(BXXPX,K,K,J)
                          ELSE K := J 
                         END; 
                        GEN30(TESTX,ORD(NG),K,INXERR,TERAR) 
                       END
                    END 
                  END 
                 ELSE 
                  IF LSP2 <> NIL THEN 
                   BEGIN GETBOUNDS(LSP2,LMIN2,LMAX2); 
                    CONF := COMPTYPES(LSP1^.BOUNDTYPE,LSP2) AND 
                            (LMIN2 >= LMIN1) AND (LMAX2 <= LMAX1) 
                   END
                END 
             END
         END; 
       CONFORMABLE := CONF
      END (* CONFORMABLE *);
  
      FUNCTION COMPPARAMS(FSP1,FSP2: STP; VARPARAM: BOOLEAN): BOOLEAN;
       (* DECIDE WHETHER THE STRUCTURES DEFINED BY FSP1 AND FSP2 ARE
          PARAMETER COMPATIBLE.  FSP1 DESCRIBES THE TYPE OF THE FORMAL
          PARAMETER, FSP2 DESCRIBES THE TYPE OF THE ACTUAL PARAMETER. 
          VARPARAM=TRUE IF THE FORMAL PARAMETER IS A VAR PARAMETER. *)
      BEGIN (* COMPPARAMS *)
       IF FSP1 = FSP2 THEN COMPPARAMS := TRUE 
       ELSE 
        IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN 
         IF (FSP1^.FORM = FILES) AND (FSP2^.FORM = FILES) THEN
          COMPPARAMS := FSP1^.BASEFILE = FSP2^.BASEFILE 
         ELSE 
          IF VARPARAM THEN COMPPARAMS := FALSE
          ELSE COMPPARAMS := COMPTYPES(FSP1,FSP2) 
        ELSE COMPPARAMS := TRUE 
      END (* COMPPARAMS *); 
  
      FUNCTION COMPPROCS(FCP1,FCP2: CTP) : BOOLEAN; 
       (* DECIDE WHETHER PROCS/FUNCS IDENTIFIED BY FCP1 AND FCP2 ARE
          COMPATIBLE.  THE PARAMETER LISTS MUST BE CONGROUS, AND FOR
          FUNCTIONS, THE RESULT TYPES MUST BE IDENTICAL. *) 
       VAR LCP1,LCP2: CTP; COMP: BOOLEAN; 
  
       FUNCTION EQUIVALENT(FSP1,FSP2: STP): BOOLEAN;
        (* DECIDE WHETHER THE CONFORMANT-ARRAY-SCHEMAS (OR SUBTYPES)
           DEFINED BY FSP1 AND FSP2 ARE EQUIVALENT. *)
        VAR COMP: BOOLEAN;
       BEGIN (* EQUIVALENT *) 
        COMP := TRUE; 
        IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN 
         IF FSP1 <> FSP2 THEN 
          BEGIN COMP := FALSE;
           IF (FSP1^.FORM = ARRAYS) AND (FSP2^.FORM = ARRAYS) THEN
            IF FSP1^.CONFORMANT AND FSP2^.CONFORMANT THEN 
             IF EQUIVALENT(FSP1^.AELTYPE,FSP2^.AELTYPE) AND 
                (FSP1^.PCKDARR = FSP2^.PCKDARR) THEN
              IF (FSP1^.INXTYPE <> NIL) AND (FSP2^.INXTYPE <> NIL) THEN 
               COMP := EQUIVALENT(FSP1^.INXTYPE^.BOUNDTYPE, 
                                  FSP2^.INXTYPE^.BOUNDTYPE) 
              ELSE COMP := TRUE 
          END;
        EQUIVALENT := COMP
       END (* EQUIVALENT *);
  
      BEGIN (* COMPPROCS *) 
       IF (FCP1 <> NIL) AND (FCP2 <> NIL) THEN
        BEGIN LCP1 := FCP1^.PARAMLIST; LCP2 := FCP2^.PARAMLIST; 
         COMP := FCP1^.IDTYPE = FCP2^.IDTYPE; 
         WHILE COMP AND (LCP1 <> NIL) AND (LCP2 <> NIL) DO
          BEGIN 
           IF LCP1^.KLASS = LCP2^.KLASS THEN
            IF LCP1^.KLASS IN [PROC,FUNC] THEN
             COMP := COMPPROCS(LCP1,LCP2) 
            ELSE
             COMP := EQUIVALENT(LCP1^.IDTYPE,LCP2^.IDTYPE) AND
                     (LCP1^.VKIND = LCP2^.VKIND) AND
                     (LCP1^.FIRSTINPARMGROUP = LCP2^.FIRSTINPARMGROUP)
           ELSE COMP := FALSE;
           LCP1 := LCP1^.NEXT; LCP2 := LCP2^.NEXT 
          END;
         COMPPROCS := COMP AND (LCP1 = LCP2)
        END 
       ELSE COMPPROCS := TRUE 
      END (* COMPPROCS *);
  
      PROCEDURE CNFPARAM(VAR FATTR: ATTR; VAR FI: REGNR); 
       (* LOAD PARAMETER OF CONFORMANT ARRAY INTO X.FI, BUILDING THE
          DESCRIPTOR IF NECESSARY.  ASSUMES FATTR.KIND = VARBL. *)
       VAR I,J: REGNR; LCSP: CTAILP; LATTR: ATTR; 
  
       PROCEDURE NODOUBLEREFX(VAR FJ: REGNR; FI: REGNR);
       BEGIN
        IF XRGS[FI].REFNR = 1 THEN FJ := FI 
        ELSE
         BEGIN NEEDX([0..7],FJ); GEN15(BXX,FJ,FI,FI); DECREFX(FI) END;
        XRGS[FJ].XCONT := OTHER 
       END (* NODOUBLEREFX *);
  
       PROCEDURE BUILDCSTDESC(FSP: STP; VAR FP:CTAILP); 
        (* BUILD A CONSTANT DESCRIPTOR. *)
        VAR MIN,MAX: INTEGER; P1,P2:CTAILP; 
       BEGIN FP := NIL; 
        IF FSP <> NIL THEN
         IF FSP^.FORM = ARRAYS THEN 
          BEGIN BUILDCSTDESC(FSP^.AELTYPE,P2);
           GETBOUNDS(FSP^.INXTYPE,MIN,MAX); 
           NEW(P1);  WITH P1^ DO BEGIN NXTCSP := P2; CSVAL := MIN END;
           NEW(P2);  WITH P2^ DO BEGIN NXTCSP := P1; CSVAL := MAX END;
           NEW(FP);  WITH FP^ DO
            BEGIN NXTCSP := P2; CSVAL := FULLWORDS(FSP^.SIZE) END 
          END 
       END (* BUILDCSTDESC *);
  
      BEGIN (* CNFPARAM *)
       WITH FATTR DO
        IF TYPTR <> NIL THEN
         BEGIN
          IF KIND = VARBL THEN
           IF PCKD THEN 
            BEGIN 
             LOAD(FATTR,I); 
             WITH LATTR DO
              BEGIN 
               TYPTR := FATTR.TYPTR;  KIND := VARBL;
               WORDACC := DRCT;  PCKD := FALSE; 
               VLEVEL := LEVEL;  CWDISPL := LC; 
               LC := LC+1 
              END;
             STORE(LATTR,I);
             LOADADDRESS(LATTR,I) 
            END 
           ELSE LOADADDRESS(FATTR,I)
          ELSE LOADADDRESS(FATTR,I);
          IF NXT^.FIRSTINPARMGROUP THEN 
           BEGIN
            IF TYPTR^.CONFORMANT THEN 
             BEGIN (* ACCESS TO PARAMETER WORD ACCORDING TO DRCT *) 
              WITH LATTR DO 
               BEGIN TYPTR := INTPTR; PCKD := FALSE; KIND := VARBL; 
                WORDACC := DRCT; VLEVEL := FATTR.VLEVEL;
                CWDISPL := FATTR.TYPTR^.DESCADDR
               END; 
              LOADADDRESS(LATTR,J); NODOUBLEREFX(J,J) 
             END
            ELSE
             BEGIN BUILDCSTDESC(TYPTR,LCSP);
              NEEDX([0..7],J); GEN30(SXBPK,J,0,0,PROGR);
              ENTERCST(LCSP); 
             END; 
            (* PACK DESCRIPTOR ADDRESS AND ARRAY ADDRESS INTO X.J *)
            GEN15(LXJK,J,0,18); GEN15(BXXPX,J,J,I); DECREFX(I)
           END
          ELSE J := I 
         END
        ELSE NEEDX([0..7],J); 
       FI := J
      END (* CNFPARAM *); 
  
     BEGIN (* CALLUSERDECLARED *) 
      LB6DPL := B6DPL;
      WITH FCP^ DO
       BEGIN NXT := PARAMLIST; LKIND := PFKIND; 
        FTN := FALSE; 
        IF LKIND = ACTUAL THEN FTN := PFDECL = FTNDECL; 
        IF KLASS = FUNC THEN
         BEGIN SAVEREFXRGS(LXRGS);
          IF B6DPL <> PFLC THEN 
           BEGIN
            FOR I := 0 TO 7 DO
             BEGIN
              WITH ARGS[I] DO 
               IF ACONT = SIMPADDR THEN 
                IF ALEV = 0 THEN ACONT := UNSPECADDR; 
              WITH XRGS[I] DO 
               IF XCONT = SIMPVAR THEN
                IF XLEV = 0 THEN XCONT := AVAIL 
             END; 
            GEN30(SBBPK,6,6,B6DPL,ABSR);
            GEN30(GE,6,4,WSFERR,TERAR)
           END; 
         END
       END; 
      LXPAR := 0; LDSP := PFLC; PVDISP := LC; 
      IF SY = LPARENT THEN
       BEGIN
        REPEAT PASS := VAL; 
          IF NXT = NIL THEN ERROR(126)
          ELSE
           IF NXT^.KLASS IN [PROC,FUNC] THEN PASS := PROCDESC;
         INSYMBOL;
         IF PASS = PROCDESC THEN
          BEGIN 
           IF SY <> IDENT THEN
            BEGIN ERROR(2); SKIP(FSYS+[COMMA,RPARENT]); 
             NEEDX([0..7],I)
            END 
           ELSE 
            BEGIN 
             IF NXT^.KLASS = PROC THEN SEARCHID([PROC],LCP) 
             ELSE 
              BEGIN SEARCHID([FUNC],LCP); 
              END;
            IF LCP^.PFDECKIND = PREDECLARED THEN
             BEGIN ERROR(164); NEEDX([0..7],I) END
            ELSE
            BEGIN IF LCP^.PFXOPT <> NXT^.PFXOPT THEN ERROR(179);
             IF NOT COMPPROCS(LCP,NXT) THEN ERROR(128); 
             IF LCP^.PFKIND = ACTUAL THEN 
              BEGIN (*SET UP DESCRIPTOR:*)
               WITH LCP^ DO 
                BEGIN 
                 IF FTN AND (PFDECL<>FTNDECL) THEN ERROR(173) 
                 ELSE 
                  IF NOT FTN AND (PFDECL=FTNDECL) THEN ERROR(174);
                 NEEDX([0..7],I); 
                 SEARCHEXTID(EPT);
                 GEN30(SXBPK,I,0,0,ABSR); 
                 IF (PFLEV <> 1)AND NOT FTN THEN (*ADD SURR. BASE ADR*) 
                  BEGIN 
                   LOADBASE(PFLEV,K); 
                   GEN15(SXXPB,K,K,0);  (* TRUNCATE TO 18 BITS *) 
                   GEN15(LXJK,K,0,18); GEN15(BXXPX,I,I,K);
                   DECREFX(K) 
                  END 
                END;
              END (*LCP^.PFKIND = ACTUAL*)
             ELSE 
              BEGIN (* LOAD DESCRIPTOR: *)
               WITH LCP^, PARAM DO
                BEGIN TYPTR := INTPTR; KIND := VARBL; 
                 WORDACC := DRCT; VLEVEL := PFLEV;
                 CWDISPL := PFADDR; PCKD := FALSE 
                END;
               LOAD(PARAM,I)
              END;
            END;
            END (*SY = IDENT*); 
           GATTR.TYPTR := INTPTR; 
           INSYMBOL;
           CHECKCONTEXT(FSYS+[COMMA,RPARENT],6,[])
          END (*PASS = PROCDESC*) 
         ELSE 
          BEGIN 
           IF NXT <> NIL THEN 
            BEGIN LSP := NXT^.IDTYPE; 
             IF NXT^.FIRSTINPARMGROUP THEN LSP1 := NIL; 
             IF NXT^.VKIND = INDRCT THEN
              BEGIN VARIABLE(FSYS+FACBEGSYS+[COMMA,RPARENT]); 
               IF NOT (SY IN [COMMA,RPARENT]) THEN
                BEGIN ERROR(142); 
                 EXPRESSION(FSYS+[COMMA,RPARENT]);
                 GATTR.TYPTR := NIL 
                END 
               ELSE 
                IF GATTR.TYPTR <> NIL THEN
                 BEGIN
                  IF GATTR.DCLPCKD THEN ERROR(142); 
                  IF GATTR.TAGF THEN ERROR(187) 
                 END; 
               PASS := VARADDR
              END 
             ELSE 
              BEGIN EXPRESSION(FSYS+[COMMA,RPARENT]); 
               IF (GATTR.TYPTR <> NIL) AND (LSP <> NIL) THEN
                BEGIN 
                 IF CONFORMARRAY(GATTR.TYPTR) THEN EXTENSION(332);
                 IF FULLWORDS(LSP^.SIZE) <> 1 THEN
                  PASS := VARADDR;
                 IF PASS = VAL THEN 
                  BEGIN 
                   IF LSP = REALPTR THEN
                    BEGIN 
                     IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN
                      BEGIN LOAD(GATTR,I); PACKANDNORM(I);
                       GATTR.TYPTR := REALPTR; GATTR.EXPREG := I
                      END 
                    END 
                   ELSE 
                    IF LSP^.FORM = POWER THEN CHECKSET(LSP,I) 
                    ELSE
                     IF DEBUG AND (LSP <> INTPTR) AND 
                        (LSP^.FORM <= SUBRANGE) THEN
                      BEGIN GETBOUNDS(LSP,LMIN,LMAX); LOAD(GATTR,I);
                       CHECKBNDS(I,LMIN,LMAX,ASSERR)
                      END 
                  END 
                END (* GATTR.TYPTR <> NIL *)
              END;
             IF NXT^.CONFORMNT THEN 
              BEGIN PASS := ARRDESC;
               IF LSP1 = NIL THEN LSP1 := GATTR.TYPTR 
               ELSE 
                IF GATTR.TYPTR <> LSP1 THEN ERROR(127); 
               IF NXT^.FIRSTINPARMGROUP THEN
                IF NOT CONFORMABLE(LSP,GATTR.TYPTR,0) THEN ERROR(142) 
              END 
             ELSE 
              IF NOT COMPPARAMS(LSP,GATTR.TYPTR,NXT^.VKIND = INDRCT)
               THEN ERROR(142)
            END 
           ELSE (* NXT = NIL *) 
            BEGIN EXPRESSION(FSYS+[COMMA,RPARENT]); 
             GATTR.TYPTR := NIL 
            END;
           IF GATTR.TYPTR <> NIL THEN 
            CASE PASS OF
             VAL     : LOAD(GATTR,I); 
             VARADDR : LOADADDRESS(GATTR,I);
             ARRDESC : CNFPARAM(GATTR,I)
            END 
           ELSE NEEDX([0..7],I) 
          END (*PASS <> PROCDESC*) ;
         IF (LXPAR < FCP^.PFXOPT) AND NOT FTN THEN
          BEGIN 
           IF I <> LXPAR THEN 
            BEGIN NEEDX([LXPAR],LXPAR); BXIXJ(LXPAR,I); 
            END;
           LXPAR := LXPAR + 1 
          END 
         ELSE 
          BEGIN 
           WITH PARAM DO
            BEGIN TYPTR := GATTR.TYPTR; KIND := VARBL;
             WORDACC := DRCT; PCKD := FALSE;
             IF FTN AND (PASS IN [VARADDR,PROCDESC,ARRDESC]) THEN 
              BEGIN VLEVEL := LEVEL; CWDISPL := LC END
             ELSE 
              BEGIN VLEVEL := 0; CWDISPL := LDSP END; 
            END;
           STORE(PARAM,I);
           IF FTN THEN
            BEGIN 
             IF PASS = VAL THEN 
              BEGIN NEEDX([6,7],I); GEN30(SXBPK,I,6,LDSP,ABSR); 
               WITH PARAM DO
                BEGIN VLEVEL := LEVEL; CWDISPL := LC END; 
               STORE(PARAM,I) 
              END;
             LC := LC + 1 
            END;
           B6DPL := LDSP + 1
          END;
         LDSP := LDSP + 1;
         IF NXT <> NIL THEN NXT := NXT^.NEXT
        UNTIL SY <> COMMA;
       EXPECTSYMBOL(RPARENT,4)
      END (*IF LPARENT*); 
      FOR I := 0 TO LXPAR - 1 DO ROTATEX(I);
      IF NOT FTN AND (NXT <> NIL) THEN ERROR(126);
      IF LKIND = ACTUAL THEN
       IF FTN THEN
        BEGIN CLEARREGS;
         (*SET SENTINEL FOR PARAMETER VECTOR:*) 
         GEN15(BXXMX,6,6,6); GEN30(SABPK,6,5,LC,ABSR);
         LC := LC + 1;
         (*SAVE B4/B5/B6:*) 
         GEN15(SXBPB,6,4,0);
         FOR I := 5 TO 6 DO 
          BEGIN GEN15(LXJK,6,0,18); GEN15(SXBPB,0,I,0); 
           GEN15(BXXPX,6,6,0) 
          END;
         GEN30(SABPK,6,0,PTRS,GLOBLR);
         (*SET FTN INDICATOR FOR PMD:*) 
         IF PMD = PMDON 
          THEN GEN30(SXBPK,6,0,LINENUM+400000B,ABSR)
          ELSE GEN15(SXBPB,6,1,0);
         GEN15(SAAMB,6,6,1);  (* NOTE: PTRS-1 = FORT *) 
         (*LOAD 1. WORD OF PARAMETER VECTOR AND RJ:*) 
         GEN30(SABPK,1,5,PVDISP,ABSR);
         NOOP;
         SEARCHEXTID(FCP^.EPT); 
         GEN30(RJ,0,0,0,ABSR);
         GEN30(PS,0,0,400000B,PROGR); 
         CLEARREGS; 
         GEN30(SBBPK,1,0,1,ABSR); 
         GEN30(SABPK,1,0,PTRS,GLOBLR);
         FOR I := 6 DOWNTO 5 DO 
          BEGIN GEN15(SBXPB,I,1,0); GEN15(AXJK,1,0,18) END; 
         GEN15(SBXPB,4,1,0);
         (*CLEAR FTN INDICATOR:*) 
         GEN15(BXXMX,7,7,7);
         GEN15(SAAMB,7,1,1);  (* NOTE: PTRS-1 = FORT *) 
        END 
       ELSE 
        WITH FCP^ DO
         BEGIN  (* LOAD STATIC LINK OF CALLED PROCEDURE *)
          IF PFLEV <> 1 THEN
           IF PFLEV IN LEVELS THEN GEN15(SXBPB,5,BRG[PFLEV],0)
           ELSE 
            IF PFLEV+1 IN LEVELS THEN GEN15(SABPB,5,BRG[PFLEV+1],0) 
            ELSE GEN15(MXJK,5,0,LEVEL-PFLEV-1); 
          RJTOEXT(EPT)
         END
      ELSE
       BEGIN
        WITH FCP^, PARAM DO 
         BEGIN TYPTR := INTPTR; KIND := VARBL; WORDACC := DRCT; 
          VLEVEL := PFLEV; CWDISPL := PFADDR; PCKD := FALSE 
         END; 
        LOAD(PARAM,I);
        BXIXJ(5,I); 
        RJTOEXT('P.VPE     ');
       END; 
      IF LC > LCMAX THEN LCMAX := LC; 
      LC := PVDISP; 
      B6DPL := LB6DPL;
       IF FCP^.KLASS = FUNC THEN
        BEGIN 
         IF B6DPL <> PFLC THEN GEN30(SBBPK,6,6,-B6DPL,ABSR);
         SETFUNCTIONRESULT(LXRGS,FCP^.IDTYPE) 
        END;
      SETLINENUM := TRUE
     END (* CALLUSERDECLARED *);
  
    BEGIN (*CALL*)
     IF FCP^.PFDECKIND = USERDECLARED THEN CALLUSERDECLARED 
     ELSE 
      BEGIN 
       LKEY := FCP^.KEY;
       CASE LKEY OF 
        ABSKW,
        CARDKW, 
        CHRKW,
        EXPOKW, 
        ODDKW,
        ORDKW,
        PREDKW, 
        ROUNDKW,
        SQRKW,
        SUCCKW, 
        TRUNCKW,
        UNDEFINEDKW:  INLINEFUNCS;
        ARCTANKW:     ARITHFUNCS(ATANEX); 
        COSKW,
        SINKW:        ARITHFUNCS(SINCOEX);
        EXPKW:        ARITHFUNCS(EXPEX);
        LNKW:         ARITHFUNCS(LNEX); 
        SQRTKW:       ARITHFUNCS(SQRTEX); 
        CLOCKKW:      CLOCKF; 
        DATEKW:       TIMEDATE(DATEEX); 
        TIMEKW:       TIMEDATE(TIMEEX); 
        DISPOSEKW:    NEWDISPOSE(DISPEX); 
        NEWKW:        NEWDISPOSE(NEWEX);
        EOFKW,
        EOLNKW, 
        EOSKW:        FILEFUNCS;
        GETKW:        FILEPROCS(GETBEX);
        GETSEGKW:     FILEPROCS(GETSEX);
        PUTKW:        FILEPROCS(PUTBEX);
        PUTSEGKW:     FILEPROCS(PUTSEX);
        RESETKW:      FILEPROCS(RESETEX); 
        REWRITEKW:    FILEPROCS(REWRTEX); 
        HALTKW:       HALT; 
        MESSAGEKW:    MESSAGE;
        PACKKW:       PACK; 
        PAGEKW:       PAGE; 
        READKW, 
        READLNKW:     READ; 
        UNPACKKW:     UNPACK; 
        WRITEKW,
        WRITELNKW:    WRITE 
       END (*CASE*) 
      END 
    END (*CALL*) ;
  
    PROCEDURE EXPRESSION; 
     VAR LATTR: ATTR; LOP: OPERATOR; WRDS,LADDR: ADDRRANGE; 
          BTS : BITRANGE; I,J,K,L,M,N,R,II,JJ : REGNR;
       LOPCD: OPCODE; 
        TOPLEVEL : BOOLEAN; 
       LVENTOUT:BOOLEAN; LOW,HIGH:INTEGER;
       LPL1,LPL2: PLACE;
       IREG,JREG : REGNR; 
  
     PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
      VAR LATTR: ATTR; LOP: OPERATOR; SIGN: (NONE,POS,NEG); 
        LINT,GINT,LOPPLUS: BOOLEAN; 
        I,J,K: REGNR; 
  
     PROCEDURE BOOLOP(VAR FATTR: ATTR; FOP: OPERATOR);
      (*GENERATE CODE FOR <FATTR> <FOP> <GATTR> (FOP IN [ANDOP,OROP])*) 
      (*RESULTING ATTRIBUTES IN GATTR*) 
      VAR I,J,K,L: REGNR; IND1,IND2,SHFT: INTEGER;
  
      PROCEDURE LDOPD(VAR FATTR: ATTR; VAR FI: REGNR;VAR FIND: INTEGER);
       (*LOAD OPERAND DESCRIBED BY FATTR INTO X-FI AND SET INDICATOR
       FIND TO DISTINGUISH BETWEEN 5 CASES: 
          VALUE OF FIND:     0     1     2     3     4
          X-FI CONTAINS:  LOGICAL ZR    NZ    PL    NG*)
       VAR I,J: REGNR;
      BEGIN 
       WITH FATTR DO
        IF KIND = COND THEN 
         BEGIN
          IF CONDCD IN [ZR,NZ] THEN 
           BEGIN LOADCST(0,J); DECREFX(J); NEEDX([0..7],I); 
            GEN15(IXXMX,I,J,CDR); 
            IF CONDCD = ZR THEN GEN15(BXXMX,I,CDR,I)
            ELSE GEN15(BXXMCX,I,CDR,I); 
            DECREFX(CDR); FI := I 
           END
          ELSE FI := CDR; 
          FIND := ORD(CONDCD) + 1 
         END
        ELSE
         BEGIN LOAD(FATTR,FI); FIND := 0 END
      END (*LDOPD*) ; 
  
     BEGIN (*BOOLOP*) LDOPD(FATTR,I,IND1); LDOPD(GATTR,J,IND2); 
      IF IND2 < IND1 THEN (*TRANSPOSE OPS*) 
       BEGIN K := I; I := J; J := K;
        K := IND1; IND1 := IND2; IND2 := K
       END; 
      IF (IND1=0)AND (IND2 IN [3,4]) THEN 
       BEGIN
        IF FOP =ANDOP THEN
         BEGIN K := J; SHFT := 1 END
        ELSE
         BEGIN K := I; SHFT := 59 END;
        WITH XRGS[K] DO 
         IF REFNR = 1 THEN
          BEGIN GEN15(LXJK,K,0,SHFT); XCONT := OTHER END
         ELSE 
          BEGIN NEEDX([0..7],L); GEN15(BXX,L,K,K);
           GEN15(LXJK,L,0,SHFT); DECREFX(K);
           IF FOP = ANDOP THEN J := L ELSE I := L 
          END 
       END; 
      NEEDX([0..7],K);
      (*SET RESULT ATTRIBUTES:*)
      WITH GATTR DO 
       BEGIN TYPTR := BOOLPTR;
        IF IND1 = 0 THEN
         BEGIN KIND := EXPR; EXPREG := K END
        ELSE
         BEGIN KIND := COND; CONDCD := PL; CDR := K END 
       END; 
      IF (IND2 = 4) AND (IND1 = 4) THEN GATTR.CONDCD := NG; 
      GEN15(BOOLOPCD[FOP=ANDOP,IND1=4,IND2=4],K,I,J); 
      IF (FOP = OROP)AND (IND1 = 0)AND (IND2 <> 0) THEN 
       BEGIN
        WITH GATTR DO 
         BEGIN KIND := COND; CONDCD := PL; CDR := K END;
        IF IND2 IN [1,2] THEN GEN15(LXJK,K,0,59)
       END; 
      DECREFX(I); DECREFX(J)
     END (*BOOLOP*) ; 
  
      PROCEDURE TERM(FSYS: SETOFSYS); 
       VAR LATTR: ATTR; LOP: OPERATOR;
         I,J,K,L: REGNR; LREC: CSTREC;
          LINT,GINT,OPISDIV: BOOLEAN; 
  
       PROCEDURE FACTOR(FSYS: SETOFSYS);
        VAR LCP: CTP; LSP: STP; I,J,K,L,M: REGNR; LCSTATTR,LATTR: ATTR; 
          VARPART,EXITLOOP: BOOLEAN; N: INTEGER;
       BEGIN
        IF NOT (SY IN FACBEGSYS) THEN 
         BEGIN ERROR(58); SKIP(FSYS+FACBEGSYS); 
          GATTR.TYPTR := NIL
         END; 
        REPEAT
         IF SY IN FACBEGSYS THEN
         BEGIN
          CASE SY OF
 (*ID*)    IDENT: 
            BEGIN SEARCHID([KONST,VARS,BOUNDID, 
                            FIELD,TAGFIELD,FUNC],LCP);
             INSYMBOL;
             CASE LCP^.KLASS OF 
              KONST:  
               WITH LCP^, GATTR DO
                BEGIN TYPTR := IDTYPE; KIND := CST; 
                 CVAL := VALUES 
                END;
              VARS, 
              TAGFIELD, 
              FIELD:  
               SELECTOR(FSYS,LCP);
              BOUNDID:  
               WITH LCP^,GATTR DO 
                BEGIN TYPTR := IDTYPE; KIND := VARBL; PCKD := FALSE;
                 WORDACC := DRCT; VLEVEL := BLEV; CWDISPL := BADDR; 
                 LOAD(GATTR,I)
                END;
              FUNC: 
               CALL(FSYS,LCP) 
             END
            END;
 (*CST*)   INTCONST:  
            BEGIN 
             WITH GATTR DO
              BEGIN TYPTR := INTPTR; KIND := CST; 
               CVAL.IVAL := IVAL
              END;
             INSYMBOL 
            END;
           REALCONST: 
            BEGIN 
             WITH GATTR DO
              BEGIN TYPTR := REALPTR; KIND := CST;
               CVAL.RVAL := RVAL
              END;
             INSYMBOL 
            END;
           CHARCONST: 
            BEGIN 
             WITH GATTR DO
              BEGIN TYPTR := CHARPTR; KIND := CST;
               CVAL.IVAL := IVAL
              END;
             INSYMBOL 
            END;
           STRINGCONST: 
            BEGIN 
             WITH GATTR DO
              BEGIN STRINGTYPE(TYPTR); KIND := CST; 
               CVAL.VALP := CONSTP
              END;
             INSYMBOL 
            END;
 (*NIL*)   NILSY: 
            BEGIN 
             WITH GATTR DO
              BEGIN 
               TYPTR := NILPTR; KIND := CST;
               CVAL.IVAL := NILP
              END;
             INSYMBOL 
            END;
  (*(*)    LPARENT: 
            BEGIN INSYMBOL; EXPRESSION(FSYS+[RPARENT]); 
             EXPECTSYMBOL(RPARENT,4)
            END;
 (*NOT*)  NOTSY:  
            BEGIN INSYMBOL; FACTOR(FSYS); 
             IF COMPTYPES(GATTR.TYPTR,BOOLPTR) AND
              (GATTR.TYPTR <> NIL) THEN 
              WITH GATTR DO 
               IF KIND = COND THEN
                CASE CONDCD OF
                 ZR: CONDCD := NZ;
                 NZ: CONDCD := ZR;
                 PL: CONDCD := NG;
                 NG: CONDCD := PL 
                END 
               ELSE 
                BEGIN LOAD(GATTR,I); LOADMSK(59,J); 
                 DECREFX(I); DECREFX(J);
                 NEEDX([0..7],K); GEN15(BXXMCX,K,I,J);
                 GATTR.EXPREG := K
                END 
             ELSE 
              BEGIN ERROR(135); GATTR.TYPTR := NIL END
            END;
 (*[*)     LBRACK:  
            BEGIN INSYMBOL; 
             NEW(LSP,POWER);
             WITH LSP^ DO 
              BEGIN ELSET := NIL; FORM := POWER;
               PCKDSET := [PCKD, UNPCKD]; 
               FTYPE := FALSE;
               WITH SIZE DO 
                BEGIN WORDS := 1; BITS := 0 END 
              END;
             VARPART := FALSE;
             WITH LCSTATTR DO 
              BEGIN TYPTR := LSP; KIND := CST; CVAL.PVAL := [ ] 
              END;
             IF SY = RBRACK THEN INSYMBOL 
             ELSE 
              BEGIN 
               (*LOOP UNTIL SY <> COMMA:*)
               REPEAT EXPRESSION(FSYS+[COMMA,DOTDOT,RBRACK]); 
                IF GATTR.TYPTR <> NIL THEN
                 IF GATTR.TYPTR^.FORM > SUBRANGE THEN 
                  BEGIN ERROR(136); GATTR.TYPTR := NIL END
                 ELSE 
                  IF NOT COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
                   THEN ERROR(137); 
                IF SY = DOTDOT THEN 
                 BEGIN LATTR := GATTR; INSYMBOL;
                  EXPRESSION(FSYS+[COMMA,RBRACK]);
                  IF GATTR.TYPTR <> NIL THEN
                   IF GATTR.TYPTR^.FORM > SUBRANGE THEN 
                    BEGIN ERROR(136); GATTR.TYPTR := NIL
                    END 
                   ELSE 
                    IF NOT COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
                     ERROR(137);
                  IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) 
                   THEN 
                   BEGIN
                    IF (LATTR.KIND = CST)AND (GATTR.KIND = CST) 
                     THEN 
                     BEGIN
                      IF (LATTR.CVAL.IVAL<0)OR (GATTR.CVAL
                       .IVAL > 58) THEN ERROR(304)
                      ELSE
                       FOR N := LATTR.CVAL.IVAL TO GATTR
                        .CVAL.IVAL DO 
                        LCSTATTR.CVAL.PVAL := LCSTATTR
                         .CVAL.PVAL+[N] 
                     END
                    ELSE
                     BEGIN LOAD(LATTR,I); 
                      IF DEBUG THEN CHECKBNDS(I,0,58,ASSERR); 
                      LOAD(GATTR,J);
                      IF DEBUG THEN CHECKBNDS(J,0,58,ASSERR); 
                      K := I; DECREFX(K); 
                      NEEDX([0..7],I); GEN15(IXXMX,I,J,K);
                      NEEDX([0..7],K); GEN15(MXJK,K,0,1); 
                      NEEDB(L); GEN15(SBXPB,L,I,0); 
                      GEN15(AXBX,K,L,K); GEN15(SBXPB,L,J,1);
                      GEN15(AXJK,I,0,59); GEN15(LXBX,K,L,K);
                      GEN15(BXXTCX,I,K,I);
                      DECREFX(J); DECREFX(K); BRGS[L].BCONT := FREE;
                      IF VARPART THEN 
                       BEGIN GEN15(BXXPX,M,I,M); DECREFX(I) 
                       END
                      ELSE
                       BEGIN M := I; VARPART := TRUE END
                     END
                   END
                END (* SY = DOTDOT *) 
               ELSE 
                 IF GATTR.TYPTR <> NIL THEN 
                  IF GATTR.KIND = CST THEN
                   BEGIN
                    IF (GATTR.CVAL.IVAL<0)OR (GATTR.CVAL.IVAL 
                     > 58) THEN ERROR(304)
                    ELSE
                    LCSTATTR.CVAL.PVAL := LCSTATTR.CVAL.PVAL
                    +[GATTR.CVAL.IVAL]
                   END
                  ELSE
                   BEGIN LOAD(GATTR,I); 
                    IF DEBUG THEN CHECKBNDS(I,0,58,ASSERR); 
                    NEEDB(J); 
                    GEN15(SBXPB,J,I,0); DECREFX(I); 
                    NEEDX([0..7],I); GEN15(SXBPB,I,1,0);
                    GEN15(LXBX,I,J,I); BRGS[J].BCONT := FREE; 
                    IF VARPART THEN 
                     BEGIN GEN15(BXXPX,M,I,M); DECREFX(I) END 
                    ELSE
                     BEGIN M := I; VARPART := TRUE END
                   END; 
                IF GATTR.TYPTR <> NIL THEN
                 BEGIN IF GATTR.TYPTR = REALPTR THEN ERROR(109);
                  LSP^.ELSET := GATTR.TYPTR 
                 END; 
               EXITLOOP := SY <> COMMA; 
               IF NOT EXITLOOP THEN INSYMBOL
              UNTIL EXITLOOP; 
               EXPECTSYMBOL(RBRACK,12)
              END;
             IF VARPART THEN
              BEGIN 
               IF LCSTATTR.CVAL.PVAL <> [ ] THEN
                BEGIN LOAD(LCSTATTR,I); GEN15(BXXPX,M,I,M); 
                 DECREFX(I) 
                END;
               WITH GATTR DO
                BEGIN TYPTR := LSP; KIND := EXPR; EXPREG := M 
                END 
              END 
             ELSE GATTR := LCSTATTR 
            END 
          END (*CASE*) ;
          CHECKCONTEXT(FSYS,6,FACBEGSYS)
         END (*IF*) 
        UNTIL SY IN FSYS
       END (*FACTOR*) ; 
  
      BEGIN (*TERM*)
       FACTOR(FSYS+[MULOP]);
       WHILE SY = MULOP DO
        BEGIN LATTR := GATTR; LOP := OP;
         INSYMBOL; FACTOR(FSYS+[MULOP]); K := 0;
         LINT := COMPTYPES(LATTR.TYPTR,INTPTR); 
         GINT := COMPTYPES(GATTR.TYPTR,INTPTR); 
         IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN 
          CASE LOP OF 
(***)        MUL:  IF LINT AND GINT THEN
               BEGIN
                IF LATTR.KIND = CST THEN
                 EXPREP(LATTR.CVAL.IVAL,LREC) 
                ELSE LREC.CKIND := NOP; 
                IF LREC.CKIND = NOP THEN
                 BEGIN LOAD(LATTR,I); 
                  IF GATTR.KIND = CST THEN
                   EXPREP(GATTR.CVAL.IVAL,LREC) 
                 END
                ELSE LOAD(GATTR,I); 
                IF LREC.CKIND = NOP THEN
                 BEGIN LOAD(GATTR,J); OPERATION(DXXTX,K,I,J); 
                  LOADCST(0,I); 
                  GEN15(IXXPX,K,K,I); DECREFX(I)
                 END
                ELSE
                 OPTMULT(I,LREC,NOT (XRGS[I].XCONT IN [SIMPVAR, 
                 INDVAR]),K)
               END
              ELSE
               BEGIN LOAD(LATTR,I); LOAD(GATTR,J);
                IF COMPTYPES(LATTR.TYPTR,INTPTR) THEN 
                 BEGIN PACKANDNORM(I);
                  LATTR.TYPTR := REALPTR
                 END
                ELSE
                 IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN
                  BEGIN PACKANDNORM(J); 
                   GATTR.TYPTR := REALPTR 
                  END;
                IF (LATTR.TYPTR = REALPTR)
                 AND (GATTR.TYPTR = REALPTR) THEN 
                 OPERATION(RXXTX,K,I,J) 
                ELSE
                 IF (LATTR.TYPTR^.FORM = POWER) 
                  AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
                  THEN
                  OPERATION(BXXTX,K,I,J)
                 ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
               END; 
(*/*)       RDIV: BEGIN LOAD(LATTR,I); LOAD(GATTR,J); 
               IF LINT THEN 
                BEGIN PACKANDNORM(I); 
                 LATTR.TYPTR := REALPTR 
                END;
               IF GINT THEN 
                 BEGIN PACKANDNORM(J);
                 GATTR.TYPTR := REALPTR 
                END;
               IF (LATTR.TYPTR = REALPTR) 
                AND (GATTR.TYPTR = REALPTR) THEN
                 BEGIN OPERATION(RXXDX,K,I,J);
                  IF DEBUG THEN 
                   BEGIN GEN30(TESTX,ORD(XID),K,DIVERR,TERAR);
                    GEN30(TESTX,ORD(XOR),K,DIVERR,TERAR)
                   END
                 END
               ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
              END;
(*DIV*)     IDIV, 
(*MOD*)     IMOD: BEGIN OPISDIV := LOP = IDIV;
               IF LINT AND GINT THEN
                BEGIN LOAD(LATTR,I);
                 IF GATTR.KIND = CST THEN 
                  BEGIN 
                   IF GATTR.CVAL.IVAL = 0 THEN ERROR(300) 
                   ELSE 
                    IF NOT OPISDIV AND (GATTR.CVAL.IVAL < 0) THEN 
                     ERROR(301) 
                    ELSE EXPREP(GATTR.CVAL.IVAL,LREC) 
                  END 
                 ELSE LREC.CKIND := NOP;
                 IF LREC.CKIND = PUREP THEN 
                  BEGIN NEEDX([0..7],K); GEN15(BXX,K,I,0);
                   GEN15(AXJK,K,0,LREC.EXP);
                   DECREFX(I);
                   IF OPISDIV THEN
                    BEGIN LOADCST(0,J); 
                     GEN15(IXXPX,K,K,J); DECREFX(J) 
                    END 
                   ELSE 
                    BEGIN GEN15(LXJK,K,0,LREC.EXP); 
                     GEN15(IXXMX,K,I,K) 
                    END 
                  END 
                 ELSE 
                  BEGIN LOAD(GATTR,J);
                   IF DEBUG THEN
                    BEGIN 
                     IF OPISDIV THEN GEN30(TESTX,ORD(ZR),J,DIVERR,TERAR)
                     ELSE 
                      BEGIN LOADCST(0,K); DECREFX(K); NEEDX([0..7],L);
                       GEN15(IXXMX,L,K,J); DECREFX(L);
                       GEN30(TESTX,ORD(PL),L,MODERR,TERAR); 
                      END;
                     PACKOFL(I) 
                    END;
                   IF OPISDIV THEN DECREFX(I) 
                   ELSE 
                    BEGIN M := J; 
                     WITH XRGS[M] DO
                      REFNR := REFNR + 1
                    END;
                   NEEDX([0..7],K); GEN15(PXBX,K,0,I);
                   PACKANDNORM(J); GEN15(FXXDX,K,K,J); DECREFX(J);
                   NEEDB(L); GEN15(UXBX,K,L,K); GEN15(LXBX,K,L,K);
                   BRGS[L].BCONT := FREE; 
                   IF OPISDIV THEN
                    BEGIN LOADCST(0,J); 
                     GEN15(IXXPX,K,K,J); DECREFX(J) 
                    END 
                   ELSE 
                    BEGIN 
                     IF LREC.CKIND <> NOP THEN
                      OPTMULT(K,LREC,TRUE,K)
                     ELSE GEN15(DXXTX,K,M,K); 
                     DECREFX(M);
                     GEN15(IXXMX,K,I,K); DECREFX(I) 
                    END 
                  END;
                 GATTR.TYPTR := INTPTR
                END 
               ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
              END;
(*AND*)      ANDOP:IF COMPTYPES(LATTR.TYPTR,BOOLPTR)AND 
               COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN
               BOOLOP(LATTR,ANDOP)
              ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END 
          END (*CASE*)
         ELSE GATTR.TYPTR := NIL; 
         IF LOP <> ANDOP THEN 
          WITH GATTR DO 
           BEGIN KIND := EXPR; EXPREG := K END; 
        END (*WHILE*) 
      END (*TERM*) ;
  
     BEGIN (*SIMPLEEXPRESSION*) 
      SIGN := NONE; 
      IF OP IN [PLUS,MINUS] THEN
       BEGIN
        IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; 
        INSYMBOL
       END; 
      TERM(FSYS+[ADDOP]); 
      IF SIGN <> NONE THEN
       IF COMPTYPES(GATTR.TYPTR,INTPTR) OR
          (GATTR.TYPTR = REALPTR) THEN
        BEGIN 
         IF SIGN = NEG THEN 
          IF GATTR.KIND = CST THEN
           GATTR.CVAL.IVAL := -GATTR.CVAL.IVAL
          ELSE
           BEGIN LOAD(GATTR,I); LOADCST(0,J); DECREFX(I); DECREFX(J); 
            NEEDX([0..7],K); GEN15(IXXMX,K,J,I);
            GATTR.EXPREG := K 
           END
        END 
       ELSE 
        BEGIN ERROR(134); GATTR.TYPTR := NIL END; 
      WHILE SY = ADDOP DO 
       BEGIN LATTR := GATTR; LOP := OP; 
        INSYMBOL; TERM(FSYS+[ADDOP]); K := 0; 
        LINT := COMPTYPES(LATTR.TYPTR,INTPTR);
        GINT := COMPTYPES(GATTR.TYPTR,INTPTR);
        IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN
         CASE LOP OF
     (*+*)PLUS, 
     (*-*)MINUS:  
           BEGIN LOAD(LATTR,I); LOAD(GATTR,J);
           LOPPLUS := LOP = PLUS; 
           IF LINT AND GINT THEN
            IF LOPPLUS
             THEN OPERATION(IXXPX,K,I,J)
             ELSE OPERATION(IXXMX,K,I,J)
           ELSE 
            BEGIN 
             IF LINT THEN 
              BEGIN PACKANDNORM(I); 
               LATTR.TYPTR := REALPTR 
              END 
             ELSE 
              IF GINT THEN
              BEGIN PACKANDNORM(J); 
                GATTR.TYPTR := REALPTR
               END; 
             IF (LATTR.TYPTR = REALPTR) 
              AND (GATTR.TYPTR = REALPTR) THEN
              BEGIN IF LOPPLUS
                THEN OPERATION(RXXPX,K,I,J) 
                ELSE OPERATION(RXXMX,K,I,J);
               GEN15(NXBX,K,0,K)
              END 
             ELSE 
              IF (LATTR.TYPTR^.FORM = POWER)
               AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
                IF LOPPLUS
                 THEN OPERATION(BXXPX,K,I,J)
                 ELSE OPERATION(BXXTCX,K,I,J) 
              ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END 
            END;
           END; 
     (*OR*)OROP:  
           IF COMPTYPES(LATTR.TYPTR,BOOLPTR)AND 
            COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN 
            BOOLOP(LATTR,OROP)
           ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
         END (*CASE*) 
        ELSE GATTR.TYPTR := NIL;
        IF LOP <> OROP THEN 
         WITH GATTR DO
          BEGIN KIND := EXPR; EXPREG := K END 
       END (*WHILE*)
     END (*SIMPLEEXPRESSION*) ; 
  
      PROCEDURE CHECKREAL;
      (* TEST RESULT OF REAL EXPRESSION. *) 
      (* ASSUMES DEBUG IS TRUE *) 
      BEGIN (* CHECKREAL *) 
       WITH GATTR DO
        IF KIND = EXPR THEN 
         IF TYPTR = REALPTR THEN
          BEGIN GEN15(NXBX,EXPREG,0,EXPREG); NOOP END 
           (* CAUSE MODE EXIT FOR BAD OPERAND AND PREVENT CHANGING
              NXBX INSTRUCTION BY BXIXJ AND PREVENT AN SA0 INSTRUCTION
              FROM BEGIN GENERATED IN THE SAME WORD.  THIS ENSURES
              THAT THE LINE NUMBER REPORTED BY PMD WILL BE CORRECT. *)
      END (* CHECKREAL *);
  
    BEGIN (*EXPRESSION*)
     TOPLEVEL := TOPEXPR; 
     TOPEXPR := FALSE;
     SIMPLEEXPRESSION(FSYS+[RELOP]);
     IF SY = RELOP THEN 
      BEGIN 
       IF DEBUG THEN CHECKREAL; 
        LATTR := GATTR; LOP := OP;
       INSYMBOL; SIMPLEEXPRESSION(FSYS);
       IF DEBUG THEN CHECKREAL; 
       IF LATTR.TYPTR <> NIL THEN 
        WITH LATTR.TYPTR^ DO
         IF (FORM = ARRAYS) AND (SIZE.WORDS > 1) AND
            COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN 
          BEGIN 
             LOADADDRESS(LATTR,II); LOADADDRESS(GATTR,JJ) 
            END 
         ELSE 
          BEGIN 
           IF LOP = INOP THEN (* DECIDE WHETHER ELEMENT EVENTUALLY
                                 OUT OF [0..63] *)
            BEGIN LVENTOUT:=TRUE; 
             WITH LATTR DO
              IF KIND = CST THEN
               BEGIN IF (CVAL.IVAL >= 0) AND (CVAL.IVAL <= 63) THEN 
                                                 LVENTOUT:=FALSE
               END
              ELSE IF KIND = VARBL THEN 
               IF (TYPTR <> NIL) AND (TYPTR <> INTPTR) THEN 
                IF TYPTR^.FORM IN [SCALAR,SUBRANGE] THEN
                 BEGIN GETBOUNDS(TYPTR,LOW,HIGH); 
                  IF (LOW >= 0) AND (HIGH <= 63) THEN LVENTOUT:=FALSE 
                 END
            END;
           LOAD(LATTR,I); LOAD(GATTR,J);
          END;
          K := 0; 
       IF (LATTR.TYPTR <> NIL)AND (GATTR.TYPTR <> NIL) THEN 
        IF LOP = INOP THEN
         IF GATTR.TYPTR^.FORM = POWER THEN
          IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET) THEN 
           BEGIN
            IF  LVENTOUT THEN 
             BEGIN LOADMSK(54,L); DECREFX(L); NEEDX([0..7],K);
              GEN15(BXXTX,K,I,L); GEN30(TESTX,ORD(NZ),K,IC+1,PROGR);
              DECREFX(K)
             END; 
            NEEDX([0..7],K);
            NEEDB(L); GEN15(SBXPB,L,I,0); 
            DECREFX(I); DECREFX(J); GEN15(AXBX,K,L,J);
            IF LVENTOUT THEN NOOP;
            GEN15(LXJK,K,0,59); BRGS[L].BCONT := FREE;
            WITH GATTR DO 
             BEGIN TYPTR := BOOLPTR; CONDCD := PL END;
           END
          ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END 
         ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END
        ELSE
         BEGIN
          IF NOT COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
           IF COMPTYPES(LATTR.TYPTR,INTPTR) THEN
            BEGIN PACKANDNORM(I); 
             LATTR.TYPTR := REALPTR 
            END 
           ELSE 
            IF COMPTYPES(GATTR.TYPTR,INTPTR) THEN 
             BEGIN PACKANDNORM(J);
              GATTR.TYPTR := REALPTR
             END; 
          IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
           BEGIN
            CASE LATTR.TYPTR^.FORM OF 
             SCALAR,
             SUBRANGE:  
              ; 
             POINTER: 
              BEGIN 
               IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131); 
              END;
             POWER: 
              BEGIN IF LOP IN [LTOP,GTOP] THEN ERROR(132);
             END; 
             ARRAYS:  
              IF NOT STRING(LATTR.TYPTR) THEN ERROR(134)
              ELSE IF CONFORMARRAY(LATTR.TYPTR) THEN ERROR(225);
             RECORDS: ERROR(134); 
             FILES: 
              ERROR(133)
            END;
         CASE LATTR.TYPTR^.FORM OF
          SCALAR, 
          SUBRANGE, 
          POINTER:  
           BEGIN
            IF LATTR.TYPTR = REALPTR THEN 
             LOPCD := FXXMX 
            ELSE
             LOPCD := IXXMX;
            CASE LOP OF 
             LTOP,GEOP: OPERATION(LOPCD,K,I,J); 
             LEOP,GTOP: OPERATION(LOPCD,K,J,I); 
             NEOP,EQOP: OPERATION(IXXMX,K,I,J)
            END;
            WITH GATTR DO 
             BEGIN TYPTR := BOOLPTR;
              CASE LOP OF 
               LTOP,GTOP: CONDCD := PL; 
               LEOP,GEOP: CONDCD := NG; 
                  NEOP: CONDCD := ZR; 
                  EQOP: CONDCD := NZ
              END 
             END
           END ;
          POWER:  
           BEGIN
            CASE LOP OF 
             LTOP,GTOP: ; 
             LEOP     : OPERATION(BXXTCX,K,I,J);
             GEOP     : OPERATION(BXXTCX,K,J,I);
             NEOP,EQOP: OPERATION(BXXMX,K,I,J)
            END;
            WITH GATTR DO 
             BEGIN TYPTR := BOOLPTR;
              IF LOP = NEOP THEN CONDCD := ZR ELSE CONDCD := NZ 
             END
           END; 
          ARRAYS: 
           BEGIN
            WITH LATTR.TYPTR^.SIZE DO 
             BEGIN WRDS := WORDS; BTS := BITS END;
            IF WRDS = 0 THEN (*PART WORD COMPARISON*) 
             BEGIN
              LOADMSK(BTS,L); 
              DECREFX(I); NEEDX([0..7],II); GEN15(BXXTX,II,L,I);
              DECREFX(J); NEEDX([0..7],JJ); GEN15(BXXTX,JJ,L,J);
              DECREFX(L); 
              GEN15(LXJK,II,0,BTS); GEN15(LXJK,JJ,0,BTS); 
              IF LOP IN [LEOP,GTOP] 
               THEN OPERATION(IXXMX,K,JJ,II)
               ELSE OPERATION(IXXMX,K,II,JJ)
             END
            ELSE
              BEGIN 
               IF WRDS > 1 THEN 
                BEGIN 
                 NEEDB(L); GEN15(SBBPB,L,0,0);
                 NEEDB(R); GEN30(SBBPK,R,0,WRDS-1,ABSR);
                 NOOP; LADDR := IC; 
                 NEEDX([1..5],I); NEEDX([1..5],J);
                 ARGS[I].ACONT := UNSPECADDR; 
                 ARGS[J].ACONT := UNSPECADDR; 
                 GEN15(SAXPB,I,II,L); GEN15(SAXPB,J,JJ,L);
                END;
                IF LOP IN [LEOP,GTOP] THEN
                 BEGIN K := I; I := J; J := K END;
                IREG := I; JREG := J; 
                NEEDX([0..7],K);
                IF LOP IN [LTOP,LEOP,GEOP,GTOP] THEN
                 BEGIN GEN15(BXXMCX,K,I,J); DECREFX(I); NEEDX([0..7],M);
                  GEN15(IXXMX,M,I,J); 
                  NEEDX([0..7],I); GEN15(BXXTX,I,K,M);
                  NEEDX([0..7],N);
                  GEN15(BXXTCX,N,J,K); GEN15(BXXPX,K,I,N);
                  DECREFX(N); DECREFX(M); 
                 END
                ELSE
                 BEGIN GEN15(BXXMX,K,I,J);
                  GEN30(TESTX,ORD(NZ),K,0,PROGR); LPL1 := PC; 
                  NEEDX([0..7],N); GEN15(SXBPB,N,1,0);
                  GEN15(BXXTX,K,K,N); DECREFX(N)
                 END; 
                DECREFX(I); DECREFX(J); 
                IF (WRDS > 1) OR (BTS <> 0) THEN
                 BEGIN IF WRDS > 1 THEN GEN15(SBBPB,L,L,1); 
                  IF LOP IN [LTOP,LEOP,GEOP,GTOP] THEN
                   BEGIN GEN30(TESTX,ORD(NG),K,0,PROGR); LPL1 := PC;
                    GEN30(TESTX,ORD(NZ),M,0,PROGR); LPL2 := PC
                   END
                  ELSE IF WRDS > 1 THEN 
                   BEGIN GEN30(TESTX,ORD(NZ),K,0,PROGR);
                    LPL2 := PC
                   END; 
                  IF WRDS > 1 THEN
                   BEGIN GEN30(GE,R,L,LADDR,PROGR); 
                    DECREFX(II); DECREFX(JJ); 
                    BRGS[L].BCONT := FREE;
                    BRGS[R].BCONT := FREE 
                   END; 
                END;
               IF BTS <> 0 THEN 
                BEGIN LOADMSK(BTS,L); 
                 NEEDX([1..5],I); NEEDX([1..5],J);
                 IF I = JREG THEN 
                  BEGIN I := J; J := JREG END;
                 GEN15(SAAPB,I,IREG,1); ARGS[I].ACONT := UNSPECADDR;
                 GEN15(SAAPB,J,JREG,1); ARGS[J].ACONT := UNSPECADDR;
                 DECREFX(I); NEEDX([0..7],II); GEN15(BXXTX,II,L,I); 
                 DECREFX(J); NEEDX([0..7],JJ); GEN15(BXXTX,JJ,L,J); 
                 DECREFX(L);
                 GEN15(LXJK,II,0,BTS); GEN15(LXJK,JJ,0,BTS);
                 DECREFX(II); DECREFX(JJ);
                 GEN15(IXXMX,K,II,JJ) 
                END;
               IF (WRDS > 1) OR (BTS <> 0) THEN 
                BEGIN NOOP; INS(IC,LPL1); 
                 IF (LOP IN [LTOP,LEOP,GTOP,GEOP]) OR (WRDS > 1) THEN 
                  INS(IC,LPL2)
                END 
               ELSE IF LOP IN [EQOP,NEOP] THEN
                BEGIN NOOP; INS(IC,LPL1) END
              END;
            WITH GATTR DO 
             BEGIN TYPTR := BOOLPTR;
              CASE LOP OF 
               LTOP,GTOP: CONDCD := PL; 
               LEOP,GEOP: CONDCD := NG; 
               NEOP     : CONDCD := ZR; 
               EQOP     : CONDCD := NZ
              END 
             END
           END; 
          RECORDS,
          FILES:  
         END (*CASE*) ; 
           END
          ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END;
         END (*SY <> INOP*) 
        ELSE GATTR.TYPTR := NIL;
       WITH GATTR DO
        BEGIN KIND := COND; CDR := K END; 
      END (*SY = RELOP*) ;
      IF TOPLEVEL AND DEBUG THEN CHECKREAL; 
      TOPEXPR := TOPLEVEL 
    END (*EXPRESSION*) ;
  
    PROCEDURE GENFJMP(FADDR: ADDRRANGE);
     (*GENERATE A FALSE JUMP TO FADDR (ON GATTR)*)
     VAR I: REGNR;
    BEGIN 
     WITH GATTR DO
      IF TYPTR <> NIL THEN
       IF KIND = COND THEN
        BEGIN GEN30(TESTX,ORD(CONDCD),CDR,FADDR,PROGR); DECREFX(CDR) END
       ELSE 
        BEGIN LOAD(GATTR,I); GEN30(TESTX,ORD(ZR),I,FADDR,PROGR);
         DECREFX(I) 
        END 
    END (*GENFJMP*) ; 
  
    PROCEDURE ASSIGNMENT(FCP: CTP); 
     VAR LATTR: ATTR; 
    BEGIN THREATEN(FCP);
     SELECTOR(FSYS+[BECOMES],FCP);
     IF SY = BECOMES THEN 
      BEGIN 
       LATTR := GATTR;
       INSYMBOL; EXPRESSION(FSYS);
       ASSIGNTO(LATTR); 
      END (*SY = BECOMES*)
     ELSE ERROR(51) 
    END (*ASSIGNMENT*) ;
  
    PROCEDURE GOTOSTATEMENT;
     LABEL 1; 
     VAR LLP: LBP; I: REGNR; LFSTOCC: LOCOFREF; 
    BEGIN 
     IF SY = INTCONST THEN
      BEGIN LLP := FSTLABP; 
       WHILE LLP <> FLABP DO (*DECIDE WHETHER LOCALLY DECLARED*)
        WITH LLP^ DO
         IF LABVAL = IVAL THEN
          BEGIN 
           IF ACCESSIBLE THEN 
            BEGIN 
             IF NOT DEFINED AND (LABSTMTLEVEL = 0) THEN (* FIRST USE *) 
              LABSTMTLEVEL := STMTLEVEL 
            END 
           ELSE ERROR(188); 
           IF DEFINED THEN GEN30(EQ,0,0,LABADDR,PROGR)
           ELSE 
            BEGIN GEN30(EQ,0,0,0,PROGR); LFSTOCC := FSTOCC; 
             LINKOCC(LFSTOCC); FSTOCC := LFSTOCC
            END;
           GOTO 1 
          END 
         ELSE LLP := NEXTLAB; 
       WHILE LLP <> NIL DO (*DECIDE WHETHER GLOBALLY DECLARED*) 
        WITH LLP^ DO
         IF LABVAL = IVAL THEN
          BEGIN 
           LABSTMTLEVEL := 1; 
           IF EPT = TENBLANKS THEN
            BEGIN EPT := PASCL; 
             IF LABCNT = 36 THEN ERROR(260) 
             ELSE 
              BEGIN LABCNT := LABCNT + 1; 
               EPT[7] := CHR(LABCNT)
              END 
            END;
           IF LABLEV = 1 THEN GEN30(SBBPK,3,0,0,VARR) 
           ELSE 
            BEGIN LOADBASE(LABLEV,I); GEN15(SBXPB,3,I,0) END; 
           SEARCHEXTID(EPT); GEN30(SBBPK,7,0,0,ABSR); 
           RJTOEXT('P.GTO     '); 
           GOTO 1 
          END 
         ELSE LLP := NEXTLAB; 
       ERROR(167);
 1:    INSYMBOL 
      END 
     ELSE ERROR(15);
     CLEARREGS
    END (*GOTOSTATEMENT*) ; 
  
    PROCEDURE COMPOUNDSTATEMENT;
    BEGIN 
     STATEMENT(FSYS+[ENDSY],TRUE);
     EXPECTSYMBOL(ENDSY,13) 
    END (*COMPOUNDSTATEMENET*) ;
  
    PROCEDURE IFSTATEMENT;
     VAR LPL1,LPL2: PLACE; I: REGNR;
       LARGS: ARGSTATUS; LXRGS: XRGSTATUS; LBRGS: BRGSTATUS;
       LBRG: BASREGS; LLEVELS: SET OF LEVRANGE; 
    BEGIN EXPRESSION(FSYS+[THENSY]);
     IF NOT COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN ERROR(144); 
     GENFJMP(0);
     LPL1 := PC;
     LARGS := ARGS; LXRGS := XRGS; LBRGS := BRGS; 
     LBRG := BRG; LLEVELS := LEVELS;
     EXPECTSYMBOL(THENSY,52); 
     STATEMENT(FSYS+[ELSESY],FALSE);
     IF SY = ELSESY THEN
      BEGIN GEN30(EQ,0,0,0,PROGR); LPL2 := PC;
       NOOP; INS(IC,LPL1);
       SETLINENUM := TRUE;
       ARGS := LARGS; XRGS := LXRGS; BRGS := LBRGS; 
       BRG := LBRG; LEVELS := LLEVELS;
       INSYMBOL; STATEMENT(FSYS,FALSE); 
       NOOP; INS(IC,LPL2);
       SETLINENUM := TRUE;
      END 
     ELSE 
       BEGIN NOOP; INS(IC,LPL1) END;
     CLEARREGS
    END (*IFSTATEMENT*) ; 
  
    PROCEDURE CASESTATEMENT;
     LABEL 1; 
     CONST CASLABMAX = 2001;
     TYPE CIP = ^CASEREC; 
        CASEREC = PACKED
             RECORD NEXT: CIP;
              CSLAB: INTEGER; 
              CSADDR: ADDRRANGE 
             END; 
     VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU; 
       FSTLOCP: LOCOFREF; LPL: PLACE; 
       LDEBUG,EXITLOOP: BOOLEAN;
       I,J,K: REGNR; LARGS: ARGSTATUS; LBRGS: BRGSTATUS;
       LXRGS: XRGSTATUS;
       LBRG: BASREGS; LLEVELS: SET OF LEVRANGE; 
       LADDR: ADDRRANGE;
       LMIN,LMAX: INTEGER;
       OTHERADDR : ADDRRANGE; 
       OTHERREL : RELOCATION; 
       OTHERCLAUSE : BOOLEAN; 
       L : REGNR; 
       EVENLABEL : BOOLEAN; 
       TABLE : INTEGER; 
  
     PROCEDURE LOADCASECST(CVAL: INTEGER; REG: REGNR);
      VAR LCSP: CTAILP; 
     BEGIN (* LOADCASECST *)
      IF ABS(CVAL) >= TWOTO17 THEN
       BEGIN NEW(LCSP); 
        WITH LCSP^ DO 
         BEGIN NXTCSP := NIL; CSVAL := CVAL END;
        GEN30(SABPK,REG,0,0,PROGR); 
        ENTERCST(LCSP)
       END
      ELSE
       IF CVAL = 0 THEN GEN15(SXBPB,REG,0,0)
       ELSE 
        IF CVAL = 1 THEN GEN15(SXBPB,REG,1,0) 
        ELSE
         IF CVAL = 2 THEN GEN15(SXBPB,REG,1,1)
         ELSE 
          IF CVAL = -1 THEN GEN15(SXBMB,REG,0,1)
          ELSE GEN30(SXBPK,REG,0,CVAL,ABSR) 
     END (* LOADCASECST *); 
  
    BEGIN (* CASESTATEMENT *) 
     EXPRESSION(FSYS+[OFSY,COMMA,COLON]); 
     LSP := GATTR.TYPTR; FSTLOCP := NIL;
     IF LSP <> NIL THEN 
      IF (LSP^.FORM > SUBRANGE) OR (LSP = REALPTR) THEN 
       BEGIN ERROR(144); LSP := NIL END;
     LOAD(GATTR,I); 
     LDEBUG := DEBUG; 
     NEEDX([1..5],J); ARGS[J].ACONT := UNSPECADDR;
     NEEDX([1..5],K); ARGS[K].ACONT := UNSPECADDR;
     GEN30(EQ,0,0,0,PROGR); LPL := PC;
     DECREFX(J); DECREFX(K);
     NEEDB(L); BRGS[L].BCONT := FREE; 
     WITH XRGS[I] DO
      BEGIN 
       IF XCONT = INDVAR THEN DECREFX(XREG);
       XCONT := OTHER 
      END;
     DECREFX(I);
     LARGS := ARGS; LBRGS := BRGS; LXRGS := XRGS; 
     LBRG := BRG; LLEVELS := LEVELS;
     EXPECTSYMBOL(OFSY,8);
     FSTPTR := NIL; LPT3 := NIL;
     (*LOOP UNTIL SY <> SEMICOLON*) 
     REPEAT 
      NOOP; SETLINENUM := TRUE; 
      (*LOOP UNTIL SY <> COMMA:*) 
      REPEAT CONSTANT(FSYS+[COMMA,COLON],LSP1,LVAL);
       IF LSP1 <> NIL THEN
        IF COMPTYPES(LSP,LSP1) AND (LSP1^.FORM <= SUBRANGE) AND 
           (LSP1 <> REALPTR) THEN 
         BEGIN LPT1 := FSTPTR; LPT2 := NIL; 
          WHILE LPT1 <> NIL DO
           WITH LPT1^ DO
            BEGIN 
             IF CSLAB <= LVAL.IVAL THEN 
              BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156); 
               GOTO 1 
              END;
             LPT2 := LPT1; LPT1 := NEXT 
            END;
    1:     NEW(LPT3); 
          WITH LPT3^ DO 
           BEGIN NEXT := LPT1; CSLAB := LVAL.IVAL;
            CSADDR := IC
           END; 
          IF LPT2 = NIL THEN FSTPTR := LPT3 
          ELSE LPT2^.NEXT := LPT3 
         END
        ELSE ERROR(147);
       EXITLOOP := SY <> COMMA; 
       IF NOT EXITLOOP THEN INSYMBOL
      UNTIL EXITLOOP; 
      EXPECTSYMBOL(COLON,5);
      REPEAT STATEMENT(FSYS+[SEMICOLON,ENDSY,OTHERWISESY],FALSE); 
       IF SY IN STATBEGSYS THEN ERROR(14);
      UNTIL NOT (SY IN STATBEGSYS); 
      GEN30(EQ,0,0,0,PROGR); LINKOCC(FSTLOCP);
      EXITLOOP := SY <> SEMICOLON;
      ARGS := LARGS; XRGS := LXRGS; BRGS := LBRGS;
      BRG := LBRG; LEVELS := LLEVELS; 
      IF NOT EXITLOOP THEN
       BEGIN INSYMBOL;
        IF SY IN (FSYS+[ENDSY,OTHERWISESY]) THEN EXITLOOP := TRUE 
       END
     UNTIL EXITLOOP;
     CHECKCONTEXT([ENDSY,OTHERWISESY],6,FSYS);
     OTHERCLAUSE := SY = OTHERWISESY; 
     IF OTHERCLAUSE THEN EXTENSION(328);
     IF FSTPTR <> NIL THEN
      BEGIN LMAX := FSTPTR^.CSLAB;
       (*REVERSE POINTERS*) 
       LPT1 := FSTPTR; FSTPTR := NIL; 
       REPEAT LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR; 
        FSTPTR := LPT1; LPT1 := LPT2
       UNTIL LPT1 = NIL;
       LMIN := FSTPTR^.CSLAB; 
       SETLINENUM := FALSE; 
       NOOP;
       INS(IC,LPL); 
       IF NOT LDEBUG OR OTHERCLAUSE THEN
        BEGIN OTHERADDR := 0; OTHERREL := PROGR END 
       ELSE BEGIN OTHERADDR := INXERR; OTHERREL := TERAR END; 
       TABLE := 0;
       IF LDEBUG OR OTHERCLAUSE THEN
        BEGIN 
         IF LMIN <> 0 THEN LOADCASECST(LMIN,J)
         ELSE J := I; 
         LOADCASECST(LMAX,K); 
         IF LMIN <> 0 THEN GEN15(IXXMX,J,I,J);
         GEN15(IXXMX,K,K,I);
         GEN15(BXXPX,K,K,J);
         GEN15(LXJK,J,0,59);
         GEN30(TESTX,ORD(NG),K,OTHERADDR,OTHERREL); LPL := PC 
        END 
       ELSE 
        BEGIN 
         IF ABS(LMIN) >= TWOTO17 THEN 
          BEGIN LOADCASECST(LMIN,J); GEN15(IXXMX,J,I,J) END 
         ELSE 
          IF LMIN < 0 THEN GEN30(SXXPK,J,I,-LMIN,ABSR)
          ELSE
           BEGIN LMIN := LMIN - ORD(ODD(LMIN)); 
            TABLE := -LMIN DIV 2; J := I
           END; 
         GEN15(LXJK,J,0,59) 
        END;
       GEN15(SBXPB,L,J,0);
       GEN30(JP,L,0,IC+TABLE+ORD(PC.CP >= 3),PROGR);
       NOOP; LADDR := IC + (LMAX - LMIN) DIV 2 + 1; 
       IF NOT LDEBUG OR OTHERCLAUSE THEN
        BEGIN OTHERADDR := LADDR; 
         IF OTHERCLAUSE THEN INS(OTHERADDR,LPL) 
        END;
       EVENLABEL := TRUE; 
       IF LMAX - LMIN < CASLABMAX THEN
        BEGIN 
         REPEAT 
          WITH FSTPTR^ DO 
           BEGIN
            WHILE CSLAB > LMIN DO 
             BEGIN
              IF EVENLABEL THEN 
               GEN30(TESTX,ORD(PL),J,OTHERADDR,OTHERREL)
              ELSE GEN30(EQ,0,0,OTHERADDR,OTHERREL);
              EVENLABEL := NOT EVENLABEL; 
              LMIN := LMIN + 1
             END; 
            IF EVENLABEL THEN 
             GEN30(TESTX,ORD(PL),J,CSADDR,PROGR)
            ELSE GEN30(EQ,0,0,CSADDR,PROGR);
            EVENLABEL := NOT EVENLABEL; 
            FSTPTR := NEXT; LMIN := LMIN + 1
           END
         UNTIL FSTPTR = NIL;
        END 
       ELSE BEGIN ERROR(157); FSTLOCP := NIL END
      END (* FSTPTR <> NIL *);
     NOOP;
     IF OTHERCLAUSE THEN
      BEGIN INSYMBOL; SETLINENUM := TRUE; COMPOUNDSTATEMENT; NOOP END 
     ELSE EXPECTSYMBOL(ENDSY,13); 
     WHILE FSTLOCP <> NIL DO WITH FSTLOCP^ DO 
      BEGIN INS(IC,LOC); FSTLOCP := NXTREF END; 
     CLEARREGS; 
     SETLINENUM := TRUE;
    END (*CASESTATEMENT*) ; 
  
    PROCEDURE REPEATSTATEMENT;
     VAR LADDR: ADDRRANGE; I: REGNR;
    BEGIN CLEARREGS;
     NOOP; LADDR := IC; 
     SETLINENUM := TRUE;
     STATEMENT(FSYS+[UNTILSY],TRUE);
     IF SY = UNTILSY THEN 
      BEGIN INSYMBOL; EXPRESSION(FSYS); 
       IF NOT COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN ERROR(144); 
       GENFJMP(LADDR) 
      END 
     ELSE ERROR(53) 
    END (*REPEATSTATEMENT*) ; 
  
    PROCEDURE WHILESTATEMENT; 
     VAR LADDR: ADDRRANGE; LPL: PLACE; I: REGNR;
       LARGS: ARGSTATUS; LXRGS: XRGSTATUS; LBRGS: BRGSTATUS;
       LBRG: BASREGS; LLEVELS: SET OF LEVRANGE; 
    BEGIN CLEARREGS;
     NOOP; LADDR := IC; 
     SETLINENUM := TRUE;
     EXPRESSION(FSYS+[DOSY]); 
     IF NOT COMPTYPES(GATTR.TYPTR,BOOLPTR) THEN ERROR(144); 
     GENFJMP(0);
     LPL := PC; 
     LARGS := ARGS; LXRGS := XRGS; LBRGS := BRGS; 
     LBRG := BRG; LLEVELS := LEVELS;
     EXPECTSYMBOL(DOSY,54); 
     STATEMENT(FSYS,FALSE); 
     GEN30(EQ,0,0,LADDR,PROGR); NOOP; INS(IC,LPL);
     SETLINENUM := TRUE;
     ARGS := LARGS; XRGS := LXRGS; BRGS := LBRGS; 
     BRG := LBRG; LEVELS := LLEVELS;
    END (*WHILESTATEMENT*) ;
  
    PROCEDURE FORSTATEMENT; 
     VAR LATTR,LIMIT: ATTR; LSP: STP; LSY: SYMBOL; LADDR: ADDRRANGE;
       LPL: PLACE; I,J,K: REGNR; LCP,LCP1: CTP; LLC: ADDRRANGE; 
       LMIN,LMAX: INTEGER;
       LCONTROLVAR,CSTWARN,INITIALNOTCST: BOOLEAN;
    BEGIN (* FORSTATEMENT *)
     (* DEFINE LATTR TO PREVENT BLOW UP IN CASE OF ERRORS*) 
     WITH LATTR DO
      BEGIN TYPTR := NIL; KIND := VARBL; WORDACC := DRCT; 
      VLEVEL := LEVEL; CWDISPL := 0; PCKD := FALSE
     END; 
     CSTWARN := FALSE; INITIALNOTCST := TRUE; LLC := LC;
     IF SY = IDENT THEN 
      BEGIN SEARCHID([VARS],LCP); 
       IF LCP <> UVARPTR THEN WITH LCP^,LATTR DO
        BEGIN LCP1 := NIL;
         IF FPROCP <> NIL THEN
          BEGIN LCP1 := FPROCP^.PARAMLIST;
           WHILE (LCP1 <> NIL) AND (LCP1 <> LCP) DO 
            LCP1 := LCP1^.NEXT
          END;
         TYPTR := IDTYPE; 
         IF VKIND = DRCT THEN 
          IF VLEV = LEVEL THEN
           BEGIN VLEVEL := VLEV; CWDISPL := VADDR END 
          ELSE ERROR(155);
         LCONTROLVAR := CONTROLVAR; 
         CONTROLVAR := TRUE;
         IF LCONTROLVAR THEN ERROR(193);
         IF THREAT THEN ERROR(192); 
         IF LCP1 <> NIL THEN ERROR(180) 
        END;
       IF LATTR.TYPTR <> NIL THEN 
        IF (LATTR.TYPTR^.FORM > SUBRANGE) 
         OR (LATTR.TYPTR = REALPTR) THEN
         BEGIN ERROR(143); LATTR.TYPTR := NIL END;
       INSYMBOL 
      END 
     ELSE 
      BEGIN ERROR(2); 
       LCP := UVARPTR;
       SKIP(FSYS+[BECOMES,TOSY,DOWNTOSY,DOSY])
      END;
     GETBOUNDS(LATTR.TYPTR,LMIN,LMAX);
     GATTR.TYPTR := NIL;
     IF SY = BECOMES THEN 
      BEGIN INSYMBOL; EXPRESSION(FSYS+[TOSY,DOWNTOSY,DOSY]);
       IF GATTR.TYPTR <> NIL THEN 
         IF GATTR.TYPTR^.FORM > SUBRANGE THEN 
          BEGIN ERROR(144); GATTR.TYPTR := NIL END
         ELSE 
          IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
           BEGIN
            IF GATTR.KIND = CST THEN
             WITH GATTR.CVAL DO 
              BEGIN INITIALNOTCST := FALSE; 
               IF (IVAL < LMIN) OR (IVAL > LMAX) THEN 
                BEGIN ERROR(303); 
                 CSTWARN := TRUE
                END 
              END 
           END
          ELSE BEGIN ERROR(145); GATTR.TYPTR := NIL END 
      END 
     ELSE 
      BEGIN ERROR(51); SKIP(FSYS+[TOSY,DOWNTOSY,DOSY]) END; 
     LOAD(GATTR,I); 
     IF I <> 6 THEN BEGIN NEEDX([6],J); BXIXJ(6,I) END; 
     WITH XRGS[6] DO BEGIN XCONT := OTHER; REFNR := 1 END;
     LSY := SY; LIMIT.TYPTR := NIL; 
     IF SY IN [TOSY,DOWNTOSY] THEN
      BEGIN INSYMBOL; EXPRESSION(FSYS+[DOSY]);
       IF GATTR.TYPTR <> NIL THEN 
        IF (GATTR.TYPTR^.FORM <= SUBRANGE) AND
           (GATTR.TYPTR <> REALPTR) THEN
         IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN 
          BEGIN LIMIT := GATTR; 
           IF LIMIT.KIND = CST THEN 
            WITH LIMIT.CVAL DO
             BEGIN
              IF (IVAL < LMIN) OR (IVAL > LMAX) THEN
               BEGIN ERROR(303); CSTWARN := TRUE END; 
              IF ABS(IVAL) >= TWOTO17 THEN LOAD(LIMIT,I)
             END
          END 
         ELSE ERROR(145)
        ELSE ERROR(144) 
      END 
     ELSE BEGIN ERROR(55); SKIP(FSYS+[DOSY]) END; 
     LOAD(LIMIT,I); 
     IF LIMIT.TYPTR <> NIL THEN 
      IF LIMIT.KIND <> CST THEN 
       BEGIN GEN15(BXX,7,I,I);
        WITH LIMIT DO 
         BEGIN KIND := VARBL; WORDACC := DRCT;
          VLEVEL := LEVEL; CWDISPL := LC; PCKD := FALSE 
         END; 
        STORE(LIMIT,7); 
        LC := LC + 1; 
        IF LC > LCMAX THEN LCMAX := LC
       END; 
     NEEDX([0..7],K); DECREFX(K); 
     IF LSY = TOSY THEN GEN15(IXXMX,K,I,6)
     ELSE GEN15(IXXMX,K,6,I); 
     GEN30(TESTX,ORD(NG),K,0,PROGR); LPL := PC; 
     IF DEBUG AND (LIMIT.TYPTR <> NIL) THEN 
      IF CSTWARN THEN 
       GEN30(EQ,0,0,ASSERR,TERAR) 
      ELSE
       BEGIN
        IF INITIALNOTCST THEN 
         BEGIN LOADCST(LMIN,J); DECREFX(J); NEEDX([0..7],K);
          IF LSY = TOSY THEN GEN15(IXXMX,K,6,J) 
          ELSE GEN15(IXXMX,K,I,J) 
         END; 
        IF LIMIT.KIND <> CST THEN 
         BEGIN LOADCST(LMAX,J); 
          IF LSY = TOSY THEN GEN15(IXXMX,J,J,I) 
          ELSE GEN15(IXXMX,J,J,6);
          IF INITIALNOTCST THEN GEN15(BXXPX,K,K,J)
          ELSE K := J 
         END; 
        IF INITIALNOTCST OR (LIMIT.KIND <> CST) THEN
         GEN30(TESTX,ORD(NG),K,ASSERR,TERAR)
       END; 
     CLEARREGS; 
     WITH XRGS[6] DO
      BEGIN XCONT := SIMPVAR; REFNR := 1; LASTREF := IC;
       SHFTCNT := 0;
       XLEV := LATTR.VLEVEL; XADDR := LATTR.CWDISPL 
      END;
     EXPECTSYMBOL(DOSY,54); 
     NOOP; LADDR := IC; 
     SETLINENUM := TRUE;
     IF LATTR.TYPTR <> NIL THEN 
      BEGIN 
       GEN30(SABPK,6,5,LATTR.CWDISPL,ABSR); 
       WITH ARGS[6] DO
        BEGIN ACONT := SIMPADDR; ALEV := LEVEL; 
         ADISPL := LATTR.CWDISPL
        END 
      END;
     DECREFX(6);
     STATEMENT(FSYS,FALSE); 
     LOAD(LATTR,I); LOAD(LIMIT,J);
     LOADCST(2*ORD(LSY=TOSY)-1,K);
     GEN15(IXXMX,J,I,J);
     GEN15(IXXPX,6,I,K);
     GEN30(TESTX,ORD(NZ),J,LADDR,PROGR); NOOP; INS(IC,LPL); 
     IF LCP <> UVARPTR THEN LCP^.CONTROLVAR := LCONTROLVAR; 
     SETLINENUM := TRUE;
     IF DEBUG THEN
      IF LATTR.TYPTR <> NIL THEN
       BEGIN GEN15(MXJK,6,0,1); (* UNDEFINED INTEGER *) 
        GEN30(SABPK,6,5,LATTR.CWDISPL,ABSR) 
       END; 
     LC := LLC; 
     CLEARREGS
    END (*FORSTATEMENT*) ;
  
    PROCEDURE WITHSTATEMENT;
     VAR LCP: CTP; OLDTOP: DISPRANGE; LLC: ADDRRANGE; LATTR: ATTR;
       I: REGNR; EXITLOOP: BOOLEAN; 
    BEGIN OLDTOP := TOP; LLC := LC; 
     (*LOOP UNTIL SY <> COMMA:*)
     REPEAT 
      IF SY = IDENT THEN
       BEGIN SEARCHID([VARS,FIELD,TAGFIELD],LCP); INSYMBOL END
      ELSE BEGIN ERROR(2); LCP := UVARPTR END;
      SELECTOR(FSYS+[COMMA,DOSY],LCP);
      IF GATTR.TYPTR <> NIL THEN
       IF GATTR.TYPTR^.FORM = RECORDS THEN
        IF TOP < DISPLIMIT THEN 
         BEGIN TOP := TOP + 1;
          WITH DISPLAY[TOP], GATTR DO 
           BEGIN FNAME := TYPTR^.FIELDS; REGION := WREC;
            DCLPKD := TYPTR^.PCKDREC; 
            IF WORDACC = DRCT THEN
             BEGIN WACC := DRCT;
              LEV := VLEVEL; CWDSPL := CWDISPL
             END
            ELSE
             BEGIN
              LOADADDRESS(GATTR,I); 
              WITH LATTR DO 
               BEGIN TYPTR := GATTR.TYPTR; KIND := VARBL; 
                WORDACC := DRCT; VLEVEL := LEVEL; 
                CWDISPL := LC; PCKD := FALSE
               END; 
              STORE(LATTR,I); 
              LEV := LEVEL; CWDSPL := LC; 
              LC := LC + 1; 
              WACC := INDRCT
             END; 
            IF PCKD THEN
             BEGIN PKD := TRUE; 
              IF BITREG = NONE THEN 
               BEGIN BACC := DRCT; BDSPL := CBDISPL END 
              ELSE
               BEGIN
                IF CBDISPL <> 0 THEN
                 BEGIN NEEDX([0..7],I); 
                  IF CBDISPL = 1 THEN GEN15(SXBPB,I,0,1)
                  ELSE GEN30(SXBPK,I,0,CBDISPL,ABSR); 
                  GEN15(IXXPX,I,VBDISPL,I); 
                  DECREFX(VBDISPL)
                 END
                ELSE I := VBDISPL;
                WITH LATTR DO 
                 BEGIN TYPTR := GATTR.TYPTR; KIND := VARBL; 
                  WORDACC := DRCT; VLEVEL := LEVEL; 
                  CWDISPL := LC; PCKD := FALSE
                 END; 
                STORE(LATTR,I); 
                BACC := INDRCT; BDSPL := LC;
                LC := LC + 1; 
               END
             END (*PCKD*) 
            ELSE PKD := FALSE 
           END
         END
        ELSE ERROR(250) 
       ELSE ERROR(140); 
     EXITLOOP := SY <> COMMA; 
     IF NOT EXITLOOP THEN INSYMBOL
     UNTIL EXITLOOP;
     IF LC > LCMAX THEN LCMAX := LC;
     EXPECTSYMBOL(DOSY,54); 
     STATEMENT(FSYS,FALSE); 
     (*DISPOSE LOCALLY USED X-REGISTERS*) 
     FOR I := 0 TO 7 DO 
      WITH XRGS[I] DO 
       IF XCONT = SIMPVAR THEN
        IF (XLEV = LEVEL)AND (XADDR >= LLC) THEN XCONT := AVAIL;
     FOR I := 0 TO 7 DO 
      WITH XRGS[I] DO 
       IF XCONT = INDVAR THEN 
        IF XRGS[XREG].XCONT = AVAIL THEN XCONT := AVAIL;
     TOP := OLDTOP; LC := LLC 
    END (*WITHSTATEMENT*) ; 
  
   BEGIN (*STATEMENT*)
    IF STMTSEQUENCE THEN FSYS := FSYS + [SEMICOLON];
    STMTLEVEL := STMTLEVEL + 1; 
    REPEAT
     REPEAT 
      IF SY = INTCONST THEN (*LABEL*) 
       BEGIN CLEARREGS; NOOP; 
        SETLINENUM := TRUE; 
        LLP := FSTLABP; 
        WHILE LLP <> FLABP DO 
         WITH LLP^ DO 
          IF LABVAL = IVAL THEN 
           BEGIN
            IF DEFINED THEN ERROR(165)
            ELSE
             BEGIN LOCP := FSTOCC;
              WHILE LOCP <> NIL DO
               WITH LOCP^ DO
                BEGIN INS(IC,LOC); LOCP := NXTREF END;
              DEFINED := TRUE; LABADDR := IC; 
              IF (LABSTMTLEVEL > 0) AND (LABSTMTLEVEL < STMTLEVEL) THEN 
               ERROR(189);
              LABSTMTLEVEL := STMTLEVEL 
             END; 
            GOTO 1
           END
          ELSE LLP := NEXTLAB;
        ERROR(167); 
     1: INSYMBOL; 
        EXPECTSYMBOL(COLON,5) 
       END; 
      IF NOT (SY IN FSYS+[IDENT]) THEN
       BEGIN ERROR(6); SKIP(FSYS) END;
      IF SY IN STATBEGSYS+[IDENT] THEN
       BEGIN
        LASTSY := SY; 
        IF SY = IDENT 
         THEN BEGIN SEARCHID([VARS,FIELD,TAGFIELD,FUNC,PROC],LCP);
          INSYMBOL; 
          IF LCP^.KLASS = PROC
           THEN CALL(FSYS,LCP)
           ELSE ASSIGNMENT(LCP) 
          END 
         ELSE BEGIN 
          INSYMBOL; 
          CASE LASTSY OF
           BEGINSY  : COMPOUNDSTATEMENT;
           GOTOSY   : GOTOSTATEMENT;
           IFSY     : IFSTATEMENT;
           CASESY   : CASESTATEMENT;
           WHILESY  : WHILESTATEMENT; 
           REPEATSY : REPEATSTATEMENT;
           FORSY    : FORSTATEMENT; 
           WITHSY   : WITHSTATEMENT 
           END
          END;
        CHECKCONTEXT(FSYS,6,[]) 
       END; 
      IF STMTSEQUENCE THEN
       BEGIN  EXITLOOP := NOT (SY IN STATBEGSYS); 
        IF NOT EXITLOOP THEN ERROR(14)
       END
      ELSE EXITLOOP := TRUE 
     UNTIL EXITLOOP;
     IF STMTSEQUENCE THEN 
      BEGIN  EXITLOOP := SY <> SEMICOLON; 
       IF NOT EXITLOOP THEN INSYMBOL
      END 
    UNTIL EXITLOOP; 
    LLP := FSTLABP; 
    WHILE LLP <> FLABP DO 
     WITH LLP^ DO 
      BEGIN 
       IF ACCESSIBLE THEN 
        IF DEFINED THEN ACCESSIBLE := LABSTMTLEVEL <> STMTLEVEL 
        ELSE
         IF LABSTMTLEVEL >= STMTLEVEL THEN
          LABSTMTLEVEL := STMTLEVEL - 1;
       LLP := NEXTLAB 
      END;
    STMTLEVEL := STMTLEVEL - 1
   END (*STATEMENT*) ;
  
  
(*$L'PROCEDURE / FUNCTION BODY PROCESSOR.' *) 
  
  
  BEGIN (*BODY*)
   SETLINENUM := FALSE; 
   (* SET PMD BITS --> PMDCODE *) 
   IF PMD = PMDON THEN PMDCODE := 40B 
   ELSE IF PMD = PMDOFF THEN PMDCODE := 00B 
   ELSE PMDCODE := 20B; 
   IF LEVEL > 1 THEN
    PMDCODE := PMDCODE + ORD(FPROCP^.KLASS = FUNC) * 10B; 
   PMDCODE := PMDCODE * 01000000000000000000B;
    DP := FALSE; RCIX := 0; RCP := 15;
   WITH PC DO BEGIN SIX := 1; CIX := 0; CP := 4 END;
   NEW(CSEGP); CSEGP^.NXTSEG := NIL;
    BONUS[SHRTCST] := 20; BONUS[LONGCST] := 10; 
    BONUS[SIMPVAR] := 4; BONUS[INDVAR] := 3;
   BRG[LEVEL] := 5; BRG[1] := 0; BRG[0] := 6; 
   REL[LEVEL] := ABSR; REL[1] := VARR; REL[0] := ABSR;
   BLOCKLENGTH := 0;
   IC := 0; CADDR := 0; 
   EXT := NIL; EXTROOT := NIL; EXTIDX := 0; EXTRX := 0; 
   CLEARREGS; 
   IF LEVEL = 1 THEN
   BEGIN
    IF OUTPUTPTR = NIL THEN 
     (* SET BIT 59 IF PMD NOT ENTIRELY SUPPRESSED *)
     (* SET BIT 58 IF EXTERNAL FILES EXIST        *)
     GEN60( (ORD(PMD <> PMDNONE) * 2 + ORD(EXTFILS > 0)) *
            20000000000000000000B ) 
    ELSE
     BEGIN
      IF PMD = PMDON THEN SEARCHEXTID('P.PMD     ');
      (* SET BIT 59 IF PMD NOT ENTIRELY SUPPRESSED *) 
      (* SET BIT 58 BECAUSE EXTERNAL FILES EXIST *) 
      GEN30(PMDOPCODE[PMD = PMDNONE],0,0,0,ABSR); 
      (* ADDRESS OF OUTPUT EFET *)
      GEN30(PS,0,0,OUTPUTPTR^.VADDR+CHEFET,VARR)
     END; 
    BMSG(PROGNAME); 
    ALFINT.A := PROGNAME; GEN60(ALFINT.I);
    GEN60(PMDCODE + (IC+1) * 10000000000B); LPL1 := PC; 
    ENTRYPOINT := IC; 
    GEN15(SXAPB,5,0,0);             (* SAVE FL IN X5 *) 
    SETLINENUM := TRUE;             (* FORCE SET A0 TO LINE NUMBER *) 
    GEN30(SBBPK,7,0,EXTFILS,ABSR);  (* SET NUMBER OF EXTERNAL FILES *)
    GEN30(SXBPK,6,0,ENTRYPOINT,PROGR);  (* SET MAIN ENTRYPOINT *) 
    GEN30(SXBPK,7,0,0,VARR);        (* SET ADDRESS OF MAIN ACTIVATION *)
    GEN30(SBBPK,3,0,0,ABSR); LPL3 := PC;  (* SET W OPTION *)
    RJTOEXT('P.INIT    ');          (* INITIALIZE THE PASCAL SYSTEM *)
     IF PMD <> PMDNONE THEN RJTOEXT('P.EER     ');
    (*OPEN GLOBAL FILES:*)
    BUFFERS := 0; 
    FIRSTFILE := TRUE;
    DYNFILE := FALSE; 
    ALLFILES(DISPLAY[1].FNAME,OPENFL);
    EXFILP := FEXFILP;
    WHILE EXFILP <> NIL DO (* SEARCH FOR UNDECLARED EXTERNAL FILES *) 
     WITH EXFILP^ DO
      BEGIN 
       IF NOT DECLARED AND (FILENAME <> KW[INPUTKW])
          AND (FILENAME <> KW[OUTPUTKW]) THEN 
        BEGIN ERROR(172); 
         FLAGERROR; 
         WRITELN(' UNDECLARED FILE: ',FILENAME) 
        END;
       EXFILP := NXTP 
      END;
    (* CALL P.RESET (NO EFFECT IF ACTUAL FILE = INPUT) *) 
    IF INPUTPTR <> NIL THEN 
     BEGIN GEN30(SABPK,1,5,INPUTPTR^.VADDR+CHEFET,ABSR);
      RJTOEXT('P.RESET   ');
     END; 
    IF (OUTPUTPTR <> NIL) AND (OPTS.LINELIMIT > 0) THEN 
     BEGIN (* SET DEFAULT LINELIMIT FOR OUTPUT *) 
      LOADCST(OPTS.LINELIMIT,I); BXIXJ(6,I); CLEARREGS; 
      GEN30(SABPK,6,5,OUTPUTPTR^.VADDR,ABSR)
     END
   END ELSE 
   BEGIN
    BMSG(FPROCP^.NAME.TEN); 
    IF PMD <> PMDNONE 
     THEN BEGIN ALFINT.A := FPROCP^.NAME.TEN; GEN60(ALFINT.I);
      GEN60(PMDCODE + (IC+1) * 10000000000B); LPL1 := PC
      END;
    ENTRYPOINT := IC; 
    WITH FPROCP^ DO 
     BEGIN LCP := PARAMLIST; K := PFXOPT END; 
    I := 0; LDISP := PFLC;
    WHILE (LCP <> NIL) AND (I < K) DO 
     BEGIN
      WITH XRGS[I] DO 
       BEGIN XCONT := SIMPVAR; REFNR := 0; LASTREF := 0;
        SHFTCNT := 0; XLEV := LEVEL; XADDR := LDISP; VPADDR := FALSE
       END; 
      IF (LCP^.KLASS = VARS) AND LCP^.CONFORMNT THEN
       XRGS[I].XCONT := AVAIL;
      I := I + 1; LDISP := LDISP + 1; LCP := LCP^.NEXT
     END; 
    GEN30(SABPK,0,0,LINENUM,ABSR);
    GEN30(PS,0,0,0,ABSR); 
    SEARCHEXTID('P.PEN     '); GEN30(RJ,0,0,0,ABSR);
    (* 1/TOPLEVEL, 11/BIASED NUMBER OF PARAMS IN X-REGISTERS *) 
    GEN30(PS,0,0,0,ABSR); LPL := PC;
    IF LEVEL > 2 THEN NP := 1777B - I ELSE NP := 6000B + I; 
    INS(NP * 1000000B,LPL);  (* INSERT NUMBER OF PARAMETERS IN X-REGS *)
    SETLINENUM := TRUE; 
    IF DEBUG AND (FPROCP^.KLASS = FUNC) THEN INITFUNCTION;
    (*OPEN LOCAL FILES:*) 
    FIRSTFILE := TRUE;
    DYNFILE := FALSE; 
    ALLFILES(DISPLAY[TOP].FNAME,OPENFL);
    (*COPY MULTIPLE VALUES INTO LOCAL CELLS:*)
    LCP := FPROCP^.PARAMLIST; LDISP := PFLC;
    WHILE LCP <> NIL DO 
     WITH LCP^ DO 
      BEGIN 
       IF (IDTYPE <> NIL) AND (KLASS = VARS) THEN 
        BEGIN LSZ := FULLWORDS(IDTYPE^.SIZE); 
         IF CONFORMNT THEN
          BEGIN LDESC := IDTYPE^.DESCADDR;
           IF FIRSTINPARMGROUP OR (VKIND = DRCT) THEN 
            BEGIN GEN30(SABPK,5,5,LDISP,ABSR);
             GEN15(SXXPB,6,5,0) 
            END;
           IF FIRSTINPARMGROUP THEN 
            BEGIN 
             GEN15(AXJK,5,0,18);
             IF VKIND = INDRCT THEN GEN15(SAAPB,6,5,0); 
             (* COPY DESCRIPTOR *)
             GEN15(SAXPB,5,5,0);
             GEN15(BXX,7,5,5); GEN30(SABPK,7,5,LDESC,ABSR); 
             FOR LINDEX := 2 TO LSZ DO
              BEGIN GEN15(SAAPB,5,5,1); 
               GEN15(BXX,7,5,5); GEN15(SAAPB,7,7,1) 
              END 
            END;
           IF VKIND = DRCT THEN 
            BEGIN (*COPY ARRAY*) NEEDB(I); NEEDB(K);
             GEN30(SABPK,5,5,LDESC,ABSR); 
             GEN15(SXBPB,7,6,0);
             GEN30(SABPK,7,5,LDISP,ABSR); 
             (*TEST STACKOVERFLOW*) GEN15(SBXPB,K,5,6); 
             GEN30(SBBPK,I,K,MINFB,ABSR); 
             GEN30(GE,I,4,WSFERR,TERAR);
             GEN30(SBXPK,I,5,-1,ABSR); NOOP; (*LOOP*) 
             GEN15(SAXPB,5,6,I); GEN15(BXX,7,5,5);
             GEN15(SABPB,7,6,I); GEN15(SBBMB,I,I,1);
             GEN30(GE,I,0,IC-1,PROGR);
             GEN15(SBBPB,6,K,0);
             BRGS[I].BCONT := FREE;  BRGS[K].BCONT := FREE; 
            END;
           FOR I := 5 TO 7 DO 
            BEGIN XRGS[I].XCONT := AVAIL; 
             ARGS[I].ACONT := UNSPECADDR
            END 
          END 
         ELSE 
         IF (VKIND = DRCT) AND (LSZ <> 1) THEN
          BEGIN GEN30(SABPK,4,5,LDISP,ABSR);
           GEN30(SXBPK,7,5,VADDR,ABSR); 
           NEEDB(I); GEN30(SBBPK,I,0,LSZ-1,ABSR); NOOP; 
           GEN15(SAXPB,5,4,I); GEN15(BXX,6,5,5);
           GEN15(SAXPB,6,7,I); GEN15(SBBMB,I,I,1);
           GEN30(GE,I,0,IC-1,PROGR);
           BRGS[I].BCONT := FREE; 
           XRGS[4].XCONT := AVAIL 
          END 
        END;
        LDISP := LDISP + 1; LCP := NEXT 
      END;
   END; 
   LCMAX := LC; 
   STMTLEVEL := 0;
   STATEMENT(FSYS+[ENDSY],TRUE);
   IF LEVEL > 1 THEN INS(LCMAX,LPL);
   EXPECTSYMBOL(ENDSY,13);
   (*CLOSE LOCAL FILES:*) 
   FIRSTFILE := TRUE; 
   DYNFILE := FALSE;
   ALLFILES(DISPLAY[TOP].FNAME,CLOSEFL);
   IF LEVEL = 1 THEN
    BEGIN LGOHEAD(PROGBLOCK); 
     (*END REQUEST:*) 
     RJTOEXT('P.END     '); 
    END 
   ELSE WITH FPROCP^ DO 
    BEGIN 
     LGOHEAD(EPT);
     IF KLASS = FUNC THEN (* LOAD FUNCTION RESULT *)
      BEGIN 
       WITH GATTR DO
        BEGIN TYPTR := IDTYPE; KIND := VARBL; WORDACC := DRCT;
         VLEVEL := LEVEL; CWDISPL := FIRSTVAR - 1; PCKD := FALSE
        END;
       LOAD(GATTR,I); 
       IF I <> 6 THEN BXIXJ(6,I)
      END;
     CLEARREGS; 
     SEARCHEXTID('P.PEX     '); 
     GEN30(EQ,0,0,0,ABSR) 
    END;
   IF LCMAX > MAXADDR THEN
    BEGIN LCMAX := 0; ERROR(261) END; 
   IF LEVEL = 1 THEN
     BEGIN PRINTWS := COMPWS + LCMAX; 
     IF USERWS <> 0 THEN
       BEGIN COMPWS := USERWS - LCMAX;
       BUFFERS := BUFFERS + MINFB;
       IF COMPWS < BUFFERS THEN COMPWS := BUFFERS 
       END; 
     IF COMPWS >= MAXADDR THEN
      BEGIN COMPWS := 0; ERROR(261) END;
     IF REDUCEMODE
      THEN INS(COMPWS,LPL3) 
      ELSE INS(-COMPWS,LPL3)
     END
    ELSE
     BEGIN COMPWS := COMPWS + LCMAX;
      IF COMPWS > MAXADDR THEN COMPWS := MAXADDR
     END; 
   (*APPEND CONSTANTS TO CODE, FIXUP THEIR REFERENCES*) 
   CC := IC;
   LCSP := FSTCSP;
   WHILE LCSP <> NIL DO 
    WITH LCSP^ DO 
     BEGIN LOCP := CREF;
      WHILE LOCP <> NIL DO
       WITH LOCP^ DO
       BEGIN INS(IC,LOC); LOCP := NXTREF END; 
      CREF := NIL;
      LP := CSTP; 
      WHILE LP <> NIL DO
       WITH LP^ DO
        BEGIN GEN60(CSVAL); LP := NXTCSP END; 
      LCSP := NXTCSP; 
     END; 
   FSTCSP := LFSTCSP; 
   IF PMD <> PMDNONE THEN INS(CC*100000B+IC,LPL1);
   IF PMD = PMDON 
    THEN BEGIN PMDINFO(DISPLAY[LEVEL].FNAME); 
     GEN60(0) 
     END; 
   LGOTEXT; LGOEND; 
   IF LEVEL = 1 THEN LGOVALUE 
  END (*BODY*) ;
  
  
(*$L'PROCEDURE / FUNCTION BLOCK PROCESSOR.' *)
  
  
 BEGIN (*BLOCK*)
  FLABP := FSTLABP;  LFSTCSP := FSTCSP; 
  LFORWCNT := 0;  BLOCKSCOPE := THISSCOPE;  INORDER := TRUE;
  REPEAT
   DP := TRUE;
   CHECKCONTEXT(BLOCKBEGSYS,18,FSYS); 
   IF SY = LABELSY THEN 
    BEGIN EPT1 := TENBLANKS; INSYMBOL; LABELDECLARATION END;
   IF SY = CONSTSY THEN 
    BEGIN INSYMBOL; CONSTDECLARATION END; 
   IF SY = TYPESY THEN
    BEGIN INSYMBOL; TYPEDECLARATION END;
   IF SY = VARSY THEN 
    BEGIN INSYMBOL; VARDECLARATION END; 
   IF SY = VALUESY THEN 
    BEGIN EXTENSION(324); INSYMBOL; VALUEDECLARATION END; 
   WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO
    BEGIN LSY := SY; EPT1 := TENBLANKS; INSYMBOL; 
     PROCEDUREDECLARATION(LSY)
    END;
   EXITLOOP := SY IN STATBEGSYS;
   INORDER := INORDER AND EXITLOOP
  UNTIL EXITLOOP; 
  IF NOT INORDER THEN EXTENSION(330); 
  IF LFORWCNT > 0 THEN CHECKFORW(DISPLAY[LEVEL].FNAME); 
  EXPECTSYMBOL(BEGINSY,17); 
  PMD := PMDOPT;
  REPEAT BODY(FSYS+[CASESY]); 
   IF SY <> FSY THEN
    BEGIN ERROR(6); SKIP(FSYS) END
  UNTIL (SY = FSY)OR (SY IN BLOCKBEGSYS); 
 END (*BLOCK*) ;
  
  
(*$L'PROGRAM PROCESSOR.' *) 
  
  
 PROCEDURE PROGRAMME(FSYS: SETOFSYS); 
  (*SHOULD PREFERABLY SURROUND PROC BLOCK WHICH WAS NOT POSSIBLE*)
  (*BEFORE BOOTSTRAP DUE TO COMPILER RESTRICTION ON PROC NESTING*)
  LABEL 1;
  VAR EXFILP: EXTFILEP; LCP: CTP; 
   I : INTEGER; 
 BEGIN FEXFILP := NIL;
  EXTFILS := 0; 
  IF SY = PROGRAMSY THEN
   BEGIN EPT1 := TENBLANKS; EPT2 := TENBLANKS; INSYMBOL;
    IF SY = IDENT THEN
     BEGIN PROGNAME := ID.TEN;
     IF EPT1 = '          ' THEN
      BEGIN IF EXTON THEN PROGBLOCK := PROGNAME END 
     ELSE PROGBLOCK := EPT1;
     IF EPT2 = '          ' THEN
      BEGIN I := 6; WHILE PROGBLOCK[I] = ' ' DO I := I - 1; 
       EXTNAMES[VARR] := PROGBLOCK; EXTNAMES[VARR][I+1] := ';'
      END 
     ELSE EXTNAMES[VARR] := EPT2; 
     INSYMBOL;
      CHECKCONTEXT([SEMICOLON,LPARENT],7,FSYS); 
      IF SY = LPARENT THEN
       BEGIN
        REPEAT INSYMBOL;
         IF SY = IDENT THEN 
          BEGIN 
           IF (ID.TEN = KW[INPUTKW]) OR (ID.TEN = KW[OUTPUTKW]) THEN
            BEGIN NEW(LCP,VARS);
             WITH LCP^ DO 
              BEGIN COPYID(LCP); IDTYPE := TEXTPTR; 
               KLASS := VARS; VKIND := DRCT; NEXT := NIL; 
               VLEV := 1; VADDR := LC; VINIT := FALSE;
               THREAT := FALSE; CONTROLVAR := FALSE;
               CONFORMNT := FALSE; FIRSTINPARMGROUP := FALSE
              END;
             IF ID.TEN = KW[INPUTKW] THEN INPUTPTR := LCP 
             ELSE OUTPUTPTR := LCP; 
             ENTERID(LCP,BLCK); 
             LC := LC + TEXTPTR^.SIZE.WORDS 
            END;
           EXTFILS := EXTFILS + 1;
           EXFILP := FEXFILP; 
           WHILE EXFILP <> NIL DO 
            WITH EXFILP^ DO 
             BEGIN
              IF FILENAME = ID.TEN THEN 
               BEGIN ERROR(101); GOTO 1 END;
              EXFILP := NXTP
             END; 
 1:        NEW(EXFILP); 
           WITH EXFILP^ DO
            BEGIN FILENAME := ID.TEN; NXTP := FEXFILP;
             DECLARED := FALSE; 
             TERMINAL := FALSE; 
             INSYMBOL;
             IF OP IN [RDIV,PLUS] THEN EXTENSION(329);
             WHILE OP IN [RDIV,PLUS] DO 
              BEGIN 
               IF OP = RDIV THEN TERMINAL := TRUE 
               ELSE 
                IF FILENAME = KW[INPUTKW] THEN
                 INPUTPTR^.IDTYPE := STEXTPTR 
                ELSE
                 IF FILENAME = KW[OUTPUTKW] THEN
                  OUTPUTPTR^.IDTYPE := STEXTPTR 
                 ELSE ERROR(6); 
               INSYMBOL 
              END;
             SYSLOC := EXTFILS + 1
            END;
           FEXFILP := EXFILP
          END 
         ELSE ERROR(2); 
         CHECKCONTEXT([COMMA,RPARENT],6,FSYS) 
        UNTIL SY <> COMMA;
        EXPECTSYMBOL(RPARENT,4) 
       END; 
      EXPECTSYMBOL(SEMICOLON,14)
     END
    ELSE BEGIN ERROR(2); SKIP(FSYS) END 
   END
  ELSE BEGIN ERROR(3); SKIP(FSYS) END;
  REPEAT BLOCK(FSYS,PERIOD,NIL) 
  UNTIL SY = PERIOD 
 END (*PROGRAMME*) ;
  
  
(*$L'INITIALIZATION ROUTINES.' *) 
  
  
 PROCEDURE ENTERNAME(KY: KEYWORD; KL: IDCLASS; PTR: STP); 
  VAR CP: CTP;
 BEGIN
  NEW(CP,PROC,PREDECLARED); 
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[KY]; NAME.EXT := NIL; KLASS := KL;
    PFDECKIND := PREDECLARED; IDTYPE := PTR; NEXT := NIL; KEY := KY 
   END; 
  ENTERID(CP,BLCK)
 END (* ENTERNAME *); 
  
 PROCEDURE NONSTDPREDECLENTRIES;
  VAR SP: STP; CP: CTP; K: KEYWORD; 
 BEGIN
  NEW(STEXTPTR,FILES);                                      (*SEGTEXT*) 
  WITH STEXTPTR^ DO 
   BEGIN FILTYPE := CHARPTR; PCKDFIL := TRUE; FORM := FILES;
    BASEFILE := TEXTPTR;
    TEXTFILE := TRUE; SEGFILE := TRUE; FTYPE := TRUE; 
    BSIZE := BUFFSZ + 1;
    WITH SIZE DO
     BEGIN WORDS := CHEFETSZ; BITS := 0 END 
   END; 
  NEW(SP,SUBRANGE);                                      (*1..ALFALENG*)
  WITH SP^ DO 
   BEGIN FORM := SUBRANGE; RANGETYPE := INTPTR; FTYPE := FALSE; 
    MIN.IVAL := 1; MAX.IVAL := ALFALENG;
    WITH SIZE DO
     BEGIN WORDS := 0; BITS := 4 END; 
   END; 
  NEW(ALFAPTR,ARRAYS);                                      (*ALFA*)
  WITH ALFAPTR^ DO
   BEGIN FORM := ARRAYS; FTYPE := FALSE;
    AELTYPE := CHARPTR; INXTYPE := SP; CONFORMANT := FALSE; 
    PCKDARR := TRUE; PARTWORDELS := TRUE; ELSPERWORD := ALFALENG; 
    WITH SIZE DO
     BEGIN WORDS := 1; BITS := 0 END
   END; 
  
  NEW(CP,TYPES);                                            (*ALFA*)
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[ALFAKW]; NAME.EXT := NIL; IDTYPE := ALFAPTR;
    KLASS := TYPES
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,KONST);                                            (*COLON*) 
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[COLKW]; NAME.EXT := NIL; IDTYPE := CHARPTR; 
    KLASS := KONST; NEXT := NIL; VALUES.IVAL := 0 
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,KONST);                                            (*PERCENT*) 
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[PERKW]; NAME.EXT := NIL; IDTYPE := CHARPTR; 
    KLASS := KONST; NEXT := NIL; VALUES.IVAL := 63B 
   END; 
  ENTERID(CP,BLCK); 
  
  FOR K := GETSEGKW TO HALTKW DO                            (*PROCS*) 
   ENTERNAME(K,PROC,NIL); 
  FOR K := EOSKW TO CLOCKKW DO                              (*FUNCS*) 
   ENTERNAME(K,FUNC,NILPTR);
 END (* NONSTDPREDECLENTRIES *);
  
 PROCEDURE STDTYPENTRIES; 
 BEGIN
  NEW(INTPTR,SCALAR,PREDECLARED);                           (*INTEGER*) 
  WITH INTPTR^ DO 
   BEGIN FORM := SCALAR; SCALKIND := PREDECLARED; FTYPE := FALSE; 
    WITH SIZE DO
     BEGIN WORDS := 1; BITS := 0 END
   END; 
  NEW(REALPTR,SCALAR,PREDECLARED);                          (*REAL*)
  WITH REALPTR^ DO
   BEGIN FORM := SCALAR; SCALKIND := PREDECLARED; FTYPE := FALSE; 
    WITH SIZE DO
     BEGIN WORDS := 1; BITS := 0 END
   END; 
  NEW(CHARPTR,SCALAR,PREDECLARED);                          (*CHAR*)
  WITH CHARPTR^ DO
   BEGIN FORM := SCALAR; SCALKIND := PREDECLARED; FTYPE := FALSE; 
    WITH SIZE DO
     BEGIN WORDS := 0; BITS := CHARSIZE END 
   END; 
  NEW(BOOLPTR,SCALAR,USERDECLARED);                         (*BOOLEAN*) 
  WITH BOOLPTR^ DO
   BEGIN FORM := SCALAR; SCALKIND := USERDECLARED; FTYPE := FALSE;
    WITH SIZE DO
     BEGIN WORDS := 0; BITS := 1 END; 
   END; 
  NEW(NILPTR,POINTER);                                      (*NIL*) 
  WITH NILPTR^ DO 
   BEGIN ELTYPE := NIL; FORM := POINTER; FTYPE := FALSE;
   WITH SIZE DO 
    BEGIN WORDS := 0; BITS := 18 END
   END; 
  NEW(TEXTPTR,FILES);                                       (*TEXT*)
  WITH TEXTPTR^ DO
   BEGIN FILTYPE := CHARPTR; PCKDFIL := TRUE; FORM := FILES;
    BASEFILE := TEXTPTR;
    TEXTFILE := TRUE; SEGFILE := FALSE; FTYPE := TRUE;
    BSIZE := BUFFSZ + 1;
    WITH SIZE DO
     BEGIN WORDS := CHEFETSZ; BITS := 0 END 
   END; 
 END (*STDTYPENTRIES*); 
  
 PROCEDURE STDNAMENTRIES; 
  VAR CP,CP1: CTP; K: KEYWORD;
 BEGIN
  NEW(CP,TYPES);                                            (*INTEGER*) 
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[INTEGERKW]; NAME.EXT := NIL;
    IDTYPE := INTPTR; KLASS := TYPES
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,TYPES);                                            (*REAL*)
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[REALKW]; NAME.EXT := NIL; 
    IDTYPE := REALPTR; KLASS := TYPES 
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,TYPES);                                            (*CHAR*)
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[CHARKW]; NAME.EXT := NIL; 
    IDTYPE := CHARPTR; KLASS := TYPES 
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,TYPES);                                            (*BOOLEAN*) 
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[BOOLEANKW]; NAME.EXT := NIL;
    IDTYPE := BOOLPTR; KLASS := TYPES 
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,TYPES);                                            (*TEXT*)
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[TEXTKW]; NAME.EXT := NIL; 
    IDTYPE := TEXTPTR; KLASS := TYPES 
   END; 
  ENTERID(CP,BLCK); 
  NEW(CP,KONST);                                            (*MAXINT*)
  WITH CP^ DO 
   BEGIN NAME.TEN := KW[MAXINTKW]; NAME.EXT := NIL; 
    IDTYPE := INTPTR; KLASS := KONST; 
    NEXT := NIL; VALUES.IVAL := 7777777777777777B;
   END; 
  ENTERID(CP,BLCK); 
  CP1 := NIL; 
  FOR K := FALSEKW TO TRUEKW DO 
   BEGIN NEW(CP,KONST);                                  (*FALSE,TRUE*) 
    WITH CP^ DO 
     BEGIN NAME.TEN := KW[K]; NAME.EXT := NIL; IDTYPE := BOOLPTR; 
      KLASS := KONST; NEXT := CP1; VALUES.IVAL := ORD(K=TRUEKW) 
     END; 
    ENTERID(CP,BLCK); CP1 := CP 
   END; 
  BOOLPTR^.FCONST := CP;
  FOR K := GETKW TO DISPOSEKW DO                            (*PROCS*) 
   ENTERNAME(K,PROC,NIL); 
  FOR K := EOFKW TO SUCCKW DO                               (*FUNCS*) 
   ENTERNAME(K,FUNC,NILPTR);
  FOR K := SINKW TO LNKW DO                               (*ARITHFUNCS*)
   ENTERNAME(K,FUNC,REALPTR); 
 END (*STDNAMENTRIES*); 
  
 PROCEDURE ENTERUNDECL; 
 BEGIN
  NEW(UTYPPTR,TYPES); 
  WITH UTYPPTR^ DO
   BEGIN NAME := EMPTYID; IDTYPE := NIL; KLASS := TYPES END;
  NEW(UCSTPTR,KONST); 
  WITH UCSTPTR^ DO
   BEGIN NAME := EMPTYID; IDTYPE := NIL;
    NEXT := NIL; KLASS := KONST; VALUES.IVAL := 0 
   END; 
  NEW(UVARPTR,VARS);
  WITH UVARPTR^ DO
   BEGIN NAME := EMPTYID; IDTYPE := NIL; NEXT := NIL; 
    KLASS := VARS; VKIND := DRCT; CONFORMNT := FALSE; 
    VINIT := FALSE; VADDR := 0; VLEV := 0;
    THREAT := FALSE; CONTROLVAR := FALSE; FIRSTINPARMGROUP := FALSE 
   END; 
  NEW(UFLDPTR,FIELD); 
  WITH UFLDPTR^ DO
   BEGIN NAME := EMPTYID; IDTYPE := NIL;
    NEXT := NIL; KLASS := FIELD; FLDADDR := 0 
   END; 
  NEW(UPRCPTR,PROC,USERDECLARED,ACTUAL);
  WITH UPRCPTR^ DO
   BEGIN NAME := EMPTYID; IDTYPE := NIL;
    KLASS := PROC; PFDECKIND := USERDECLARED; PFKIND := ACTUAL; 
    PFXOPT:=4;
    NEXT := NIL; PFDECL := DECL; PFLEV := 0; FIRSTVAR := PFLC;
    PARAMLIST := NIL
   END; 
  NEW(UFCTPTR,FUNC,USERDECLARED,ACTUAL);
  WITH UFCTPTR^ DO
   BEGIN NAME := EMPTYID; IDTYPE := NIL;
    NEXT := NIL; KLASS := FUNC; PFDECKIND := USERDECLARED;
    PFKIND := ACTUAL; PFXOPT := 4;
    PFDECL := DECL; PFLEV := 0; FIRSTVAR := PFLC; 
    PARAMLIST := NIL
   END
 END (*ENTERUNDECL*) ;
  
 PROCEDURE CRACKCONTROLSTATEMENT; 
  VAR I : INTEGER;  CS : PCSIMAGE;
  
  PROCEDURE NEXTCHAR; 
  BEGIN (* NEXTCHAR *)
   REPEAT CH := LINE[I];
    IF NOT (CH IN ['.',')']) THEN I := I + 1
   UNTIL CH <> ' '
  END (* NEXTCHAR *); 
  
 BEGIN (* CRACKCONTROLSTATEMENT *)
  CSLOC(CS); UNPACK(CS^,LINE,1);
  I := 1; NEXTCHAR; 
  
  (* SKIP PROGRAM NAME: *)
  WHILE CH IN ['A'..'Z','0'..'9',' '] DO NEXTCHAR;
  
  IF NOT (CH IN [')','.']) THEN 
   BEGIN NEXTCHAR;
    WHILE NOT (CH IN ['/',')','.']) DO NEXTCHAR;
    IF CH = '/' THEN (* CRACK OPTIONS: *) 
     BEGIN OPTIONS(NEXTCHAR); 
      IF NOT (CH IN [')','.'])
       THEN HALT(' PASCAL CONTROL STATEMENT ERROR.')
     END
   END; 
  
  (* RESET CH := ' ', SO EVERYTHING IS NICE: *) 
  CH := ' ' 
 END (* CRACKCONTROLSTATEMENT *); 
  
 PROCEDURE INITIALIZE;
  VAR I: INTEGER; 
 BEGIN (* INITIALIZE *) 
 DATE(TODAY); 
 TIME(NOW); 
 FILENAME(INPUTFILENAME); 
 LINENUMBERS := INPUT^ IN DIGITS; 
 CSOPT(OPTS); 
 WITH OPTS DO 
  BEGIN 
   IF (PAGESIZE < 0) OR (PAGESIZE > 1000) THEN PAGESIZE := MAXINT 
   ELSE IF PAGESIZE < 20 THEN PAGESIZE := 20; 
   IF LISTOFF THEN BEGIN LISTON := FALSE; OLDLISTON := FALSE END
  END;
 CRACKCONTROLSTATEMENT; 
 IF NOT LISTON THEN (* SUPPRESS ALL HEADERS *) LINESLEFT := MAXINT; 
 NEXTCHSETUP(LINE,CH,CHCNT,SOURCELENGTH); 
 NEW(IDSTART); IDEND := IDSTART; IDBREAK := NIL;
 FOR I := 2 TO 16 DO (* 16 = ((MAXLINELEN-ALFALENG) DIV 7) + 1 *) 
  BEGIN NEW(IDEND^.EXTRA); IDEND := IDEND^.EXTRA END; 
 IDEND^.EXTRA := NIL; 
 BEGINLINE; 
 CH := ' '; 
 INSYMBOL;
 IF PMDOPT = PMDSUPPRESS THEN PMDOPT := PMDNONE;
  
 (*ENTER NAMES AND TYPES:*) 
 (************************) 
  
 TOP := 0;
 STDTYPENTRIES; STDNAMENTRIES; ENTERUNDECL; 
 TOP := -1; 
 NONSTDPREDECLENTRIES;
 TOP := 1; LEVEL := 1;
  
 CATTR.TYPTR := INTPTR; 
 END (* INITIALIZE *);
  
  
 PROCEDURE EXPLAINERRORS; 
  CONST MINWARNING = 320; 
  VAR MSGSPRINTED,WARNINGSONLY: BOOLEAN;
      INDEX: ERRINDEX; NEXT: INTEGER; 
  
  PROCEDURE READERRORNUMBER;
  BEGIN 
   IF EOF(ALTFILE) THEN NEXT := MAXINT
   ELSE READ(ALTFILE,NEXT)
  END (* READERRORNUMBER *);
  
 BEGIN (* EXPLAINERRORS *)
  MSGSPRINTED := FALSE; WARNINGSONLY := TRUE; 
  FIND(ALTFILE,TENBLANKS,LANG[LANGUAGE]); 
  READERRORNUMBER;
  FOR INDEX := 1 TO ERRMAX DO 
   IF ERLIST[INDEX] THEN
    BEGIN 
     WHILE INDEX > NEXT DO
      BEGIN READLN(ALTFILE); READERRORNUMBER END; 
     IF INDEX = NEXT THEN 
      BEGIN 
       IF INDEX < MINWARNING THEN WARNINGSONLY := FALSE;
       IF NOT MSGSPRINTED THEN
        BEGIN 
         CASE LANGUAGE OF 
          ENGLISH: WRITELN(' COMPILER ERROR MESSAGE(S):');
          FRENCH : WRITELN(' DICTIONNAIRE DES ERREURS:'); 
          GERMAN : WRITELN(' FEHLER-ZUSAMMENFASSUNG:')
         END; 
         WRITELN; MSGSPRINTED := TRUE 
        END;
       WRITE(INDEX:5);
       WHILE NOT EOLN(ALTFILE) DO 
        BEGIN OUTPUT^ := ALTFILE^; PUT(OUTPUT); GET(ALTFILE) END; 
       WRITELN
      END 
     ELSE HALT(' COMPILER ERROR--MISSING ERROR MESSAGES.')
    END;
  IF WARNINGSONLY AND MSGSPRINTED THEN
   MESSAGE(' WARNING(S) IN PASCAL PROGRAM.')
  ELSE
   BEGIN
    LGO^ := 05222217222355111655B;  PUT(LGO);  (* 'ERRORS IN ' *) 
    LGO^ := 20012303011455202217B;  PUT(LGO);  (* 'PASCAL PRO' *) 
    LGO^ := 07220115575500000000B;  PUT(LGO);  (* 'GRAM. ' EOL *) 
    PUTSEG(LGO);
     CLOSET(ALTFILE);                  (* RETURN PASCLIB FILE *)
     HALT(' ERROR(S) IN PASCAL PROGRAM.') 
   END
 END (* EXPLAINERRORS *); 
  
  
(*$L'MAIN PROGRAM.' *)
  
  
BEGIN (* PASCALCOMPILER *)
  
 INITIALIZE;
  
 (*COMPILE:*) 
 (**********) 
  
 IF OPTS.LOADANDGO THEN REWRITE(LGO); 
  
 PROGRAMME(BLOCKBEGSYS+STATBEGSYS-[CASESY]);
 ENDLINE; 
 IF NOT EOS(INPUT) THEN 
  BEGIN FLAGERROR;
   WRITELN(' LINES FOLLOWING END OF PROGRAM IGNORED.'); 
   REPEAT BEGINLINE; ENDLINE UNTIL EOS(INPUT) 
  END;
 IF LISTON THEN 
  BEGIN 
   IF LINESLEFT < 2 THEN HEADING; 
   WRITELN; 
   WRITE(' ': 14, 'COMPILER-ESTIMATED ''W'' OPTION = ');
   WRITEOCT(OUTPUT,PRINTWS,6); WRITELN('B.'); 
  END;
13: 
 CLOSET(ALTFILE); 
 IF VALUES <> NIL THEN CLOSEB(VALUES^); 
 IF LISTON THEN BEGIN WRITELN; WRITELN END; 
 IF PRINTWS > MAXADDR THEN
  BEGIN 
   ERRORS := TRUE;  ERLIST[265] := TRUE 
  END;
  IF ERRORS THEN EXPLAINERRORS; 
 IF OPTS.LOADANDGO THEN 
  BEGIN 
   IF LISTON THEN BEGIN WRITELN; WRITELN END; 
   PUTSEG(OUTPUT); LOADGO(LGO)
  END 
END (* PASCALCOMPILER *). 
