(*$c+,t-,d-,l-*)
{*******************************************************************************
*                                                                              *
*                     Portable Pascal assembler/interpreter                    *
*                     *************************************                    *
*                                                                              *
*                                 Pascal P5                                    *
*                                                                              *
*                                 ETH May 76                                   *
*                                                                              *
* Authors:                                                                     *
*    Urs Ammann                                                                *
*    Kesav Nori                                                                *
*    Christian Jacobi                                                          *
*    K. Jensen                                                                 *
*    N. Wirth                                                                  *
*    Ch. Jacobi                                                                *
*                                                                              *
*    Address:                                                                  *
*       Institut Fuer Informatik                                               *
*       Eidg. Technische Hochschule                                            *
*       CH-8096 Zuerich                                                        *
*                                                                              *
*  This code is fully documented in the book                                   *
*        "Pascal Implementation"                                               *
*   by Steven Pemberton and Martin Daniels                                     *
* published by Ellis Horwood, Chichester, UK                                   *
*         ISBN: 0-13-653-0311                                                  *
*       (also available in Japanese)                                           *
*                                                                              *
* Steven Pemberton, CWI/AA,                                                    *
* Kruislaan 413, 1098 SJ Amsterdam, NL                                         *
* Steven.Pemberton@cwi.nl                                                      *
*                                                                              *
* Adaption from P4 to P5 by:                                                   *
*    Scott A. Moore                                                            *
*    samiam@moorecad.com                                                       *
*                                                                              *
* P5 is an extended version of P4 with the following goals:                    *
*                                                                              *
* 1. The remaining unimplemented functions of Pascal are implemented, so that  *
*    P5 is no longer a "subset" of full Pascal. This was done because it is    *
*    no longer necessary to produce a minimum size implementation, and it      *
*    allows any standard program to be used with P5.                           *
*                                                                              *
* 2. The P5 compiler is brought up to ISO 7185 level 0 standards, both in the  *
*    language it compiles for, and the language it is implemented in.          *
*                                                                              *
* 3. The internal storage efficiency is increased. For example, character      *
*    strings no longer take as much space per character as integers and other  *
*    data. Sets are placed in their own space so that the minimum stack size   *
*    not determined by set size.                                               *
*                                                                              *
* 4. The remaining limitations and dependencies on the CDC 6000 version are    *
*    removed. For example, the instruction store no longer is packed 2         *
*    instructions to a 60 bit word.                                            *
*                                                                              *
* 5. General clean up. Longstanding bugs and issues are addressed. Constants   *
*    that were buried in the source (magic numbers) were made constants. The   *
*    type 'alpha' (specific to CDC 6000) was replaced with idstr, etc.         *
*                                                                              *
* The idea of P5 is to obtain a compiler that is ISO 7185 compliant, can       *
* compile itself, can compile any reasonable standard program, and is          *
* efficient enough to be used as a normal compiler for some certain uses.      *
* Finally, it can serve as a starting implementation for native compilers.     *
*                                                                              *
* P5 machine instructions added:                                               *
*                                                                              *
* rnd    round:   expects a float on stack, performs round() and places the    *
*                 result back on the stack as an integer.                      *
*                                                                              *
* pck ln pack:    Expects a packed array on stack top, followed by the         *
*                 starting subscript, then the unpacked array. The parameter   *
*                 contains the length of packed array in elements. Performs    *
*                 pack(upa, ss, pa) and removes all from stack. The starting   *
*                 subscript is zero based and scaled to the element size.      *
*                                                                              *
* upk ln pack:    Expects the starting subscript on stack top, followed by the *
*                 unpacked array, then the packed array. The parameter         *
*                 contains the length of packed array in elements. Performs    *
*                 unpack(pa, upa, ss) and removes all from stack. The starting *
*                 subscript is zero based and scaled to the element size.      *
*                                                                              *
* rgs    set rng: Expects a set range specification on stack, with the last    *
*                 value on the top, and the first value next. The two values   *
*                 are replaced with a set with all of the values between and   *
*                 including the first and last values.                         *
*                                                                              *
* fbv ad buf val: Validates a file buffer variable. Expects a file address on  *
*                 stack. The buffer is "validated" for lazy I/O, which means   *
*                 that if the associated file is in read mode, the delayed     *
*                 read to the buffer variable occurs. The file address remains *
*                 on the stack.                                                *
*                                                                              *
* ipj v l ip jmp: Interprocedure jump. Contains the level of the target        *
*                 procedure, and the label to jump to. The stack is adjusted   *
*                 to remove all nested procedures/functions, then the label is *
*                 unconditionally jumped to.                                   *        
*                                                                              *
* cip p           Call indirect procedure/function. The top of stack has the   *
*                 address of a mp/address pair pushed by lpa. The dl of the    *
*                 current mark is replaced by the mp, and the address replaces *
*                 the current pc. The mp/ad address is removed from stack.     *
*                                                                              *
* lpa p l q       Load procedure address. The current mark pointer is loaded   *
*                 onto the stack, followed by the target procedure or function *
*                 address. This puts enough information on the stack to call   *
*                 it with the callers environment.                             *
*                                                                              *
* efb    eof:     Find eof for binary file. The top of stack is a logical file *
*                 number. The eof boolean vale replaces it.                    *
*                                                                              *
* fvb ad buf val: Expects the length of the file buffer on stack, and the file *
*                 address under that. The buffer is "validated" for lazy I/O,  *
*                 which means that if the associated file is in read mode, the *
*                 delayed read to the buffer variable occurs. The buffer       *
*                 length is removed only.                                      *
*                                                                              *
* dmp q           Subtracts the value from the stack top. Used to dump the top *
*                 of the stack.                                                *
*                                                                              *
* swp q           Pulls the second on stack to the top, swapping the top to    *
*                 elements. The size of the top is specified, but the second   *
*                 on stack is implied as a pointer.                            *
*                                                                              *
* tjp q           Expects a boolean on stack. Jumps to the address if the      *
*                 value is true. Removes the value from the stack.             *
*                                                                              *
* P5 machine built in procedures/functions added:                              *
*                                                                              *
* pag    page:    Expects a logical file number on stack top. Performs page(). *
*                                                                              *
* rsf    reset:   Expects a logical file number on stack top. Performs         *
*                 reset() and sets the file to text mode.                      *
*                                                                              *
* rwf    rewrite: Expects a logical file number on stack top. Performs         *
*                 reset() and sets the file to text mode.                      *
*                                                                              *
* wrb    write:   Expects a logical file number on stack top, followed by a    *
*                 field number, then a boolean to print. The boolean is output *
*                 as per ISO 7185. All but the file are removed from stack.    *
*                                                                              *
* rgs    set rng: Expects a set range specification on stack, with the last    *
*                 value on the top, and the first value next. The two values   *
*                 are replaced with a set with all of the values between and   *
*                 including the first and last values.                         *
*                                                                              *
* wrf    write:   Expects a logical file number on stack top, followed by a    *
*                 field number, then a fraction, then a real to print. The     *
*                 real is output in r:f:f (fraction) format. All but the file  *
*                 are removed from stack.                                      *
*                                                                              *
* wbf    write:   Expects a file address on stack top, followed by the length  *
*                 of the type to write, then the variable address to write     *
*                 from. Writes binary store to the file.                       *
*                                                                              *
* wbi    write:   Expects a file address on stack top, followed by an integer. *
*                 Writes the integer to the file in binary format.             *
*                                                                              *
* wbr    write:   Expects a file address on stack top, followed by a real.     *
*                 Writes the real to the file in binary format.                *
*                                                                              *
* wbc    write:   Expects a file address on stack top, followed by a           *
*                 character. Writes the character to the file in binary        *
*                 format.                                                      *
*                                                                              *
* wbb    write:   Expects a file address on stack top, followed by a boolean.  *
*                 Writes the boolean to the file in binary format.             *
*                                                                              *
* rbf    read:    Expects a file address on stack top, followed by the length  *
*                 of the type to read, then the variable address to read       *
*                 from. Reads binary store from the file.                      *
*                                                                              *
* rsb    reset:   Expects a logical file number on stack top. Performs         *
*                 reset() and sets the file to binary mode.                    *
*                                                                              *
* rwb    rewrite: Expects a logical file number on stack top. Performs         *
*                 reset() and sets the file to binary mode.                    *
*                                                                              *
* gbf    get:     Get file binary. Expects the length of a file element on     *
*                 stack top, followed by a pointer to the file. The next file  *
*                 element is loaded to the file buffer.                        *
*                                                                              *
* pbf    put:     Put file binary. Expects the length of a file element on     *
*                 stack top, followed by a pointer to the file. Writes the     *
*                 file buffer to thr file.                                     *
*                                                                              *
* Note that the previous version of P4 added some type specified instructions  *
* that used to be unified, typeless instructions.                              *
*                                                                              *
* P5 errors added:                                                             *
*                                                                              *
* 182 identifier too long                                                      *
* 183 For index variable must be local to this block                           *
* 184 Interprocedure goto does not reference outter block of destination       *
* 185 Goto references deeper nested statement                                  *
* 186 Label referenced by goto at lesser statement level                       *
* 187 Goto references label in different nested statement                      *
* 188 Label referenced by different nested statement                           *
* 189 Parameter lists of formal and actual parameters not congruous.           *
*                                                                              *
* P5 instructions modified:                                                    *
*                                                                              *
* lca'string'       '                                                          *
*                                                                              *
* was changed to                                                               *
*                                                                              *
* lca 'string'''                                                               *
*                                                                              *
* That is, lca has a space before the opening quote, no longer pads to the     *
* right, and represents single quotes with a quote image. pint converts quote  *
* images back to single quotes, and pads out strings to their full length.     *
*                                                                              *
* In addition, the way files work was extensively modified. Original P5 could  *
* not represent files as full1y expressed variables, such as within an array   *
* or record, and were effectively treated as constants. To treat them as true  *
* variable accesses, the stacking order of the file in all file subroutines    *
* was changed so that the file is on the bottom. This matches the source       *
* order of the file in write(f, ...) or read(f, ...). Also, the file           *
* operations now leave the file on the stack for the duration of a write or    *
* read, then dump them using a specific new instruction "dmp". This allows     *
* multiparameter writes and reads to be effectively a chain of single          *
* operations using one file reference. Finally, files were tied to the type    *
* ending 'a', because files are now full variable references.                  *
*                                                                              *
* Bugs/issues:                                                                 *
*                                                                              *
* 1. Change type matching to ISO 7185 standard.                                *
*                                                                              *
* 2. pack and unpack don't check for array access beyond end.                  *
*                                                                              *
* 3. Implement the underlying method for dispose.                              *
*                                                                              *
* 4. If we make the length of constant strings a parameter of them, we can     *
* remove blanks from the right side of them.                                   *
*                                                                              *
* 5. Include function result type in congruence check for function parameters. *
*                                                                              *
* 6. Commenting out the header parameters like                                 *
*                                                                              *
*    program test<left bracket>(output)<right bracket>;                        *
*                                                                              *
* causes errors.                                                               *
*                                                                              *
*******************************************************************************}

program pascalcompiler(source,output,prr);

label 99; { terminate immediately }

const displimit = 20; maxlevel = 10;
   intsize     =      1;
   intal       =      1;
   realsize    =      1;
   realal      =      1;
   charsize    =      1;
   charal      =      1;
   charmax     =      1;
   boolsize    =      1;
   boolal      =      1;
   ptrsize     =      1;
   adral       =      1;
   setsize     =      1;
   setal       =      1;
   filesize    =      1; { required runtime space for file (logical no.) }
   stackal     =      1;
   stackelsize =      1;
   strglgth    =     80; { String length, must not be too large/small }
   sethigh     =    255; { Sets are 256 values }
   setlow      =      0;
   ordmaxchar  =    255; { Characters are 8 bit ISO/IEC 8859-1 }
   ordminchar  =      0;
   lcaftermarkstack = 5;
   fileal      = charal;
   (* stackelsize = minimum size for 1 stackelement
                  = k*stackal
      stackal     = scm(all other al-constants)
      charmax     = scm(charsize,charal)
                    scm = smallest common multiple
      lcaftermarkstack >= 4*ptrsize+max(x-size)
                        = k1*stackelsize          *)
   maxstack   =       1;
   parmal     = stackal;
   parmsize   = stackelsize;
   recal      = stackal;
   filebuffer =       4; { number of system defined files }
   maxaddr    =  maxint;
   maxsp      = 39;  { number of standard procedures/functions }
   maxins     = 74;  { maximum number of instructions }
   maxids     = 250; { maximum characters in id string (basically, a full line) }
   maxstd     = 39;  { number of standard identifiers }
   maxres     = 35;  { number of reserved words }
   reslen     = 9;   { maximum length of reserved words }
   varsqt     = 10;  { variable string quanta }
   prtlln     = 10;  { number of label characters to print in dumps }

   { default field sizes for write }
   intdeff    = 11; { default field length for integer }
   reldeff    = 22; { default field length for real }
   chrdeff    = 1;  { default field length for char (usually 1) }
   boldeff    = 5;  { default field length for boolean (usually 5 for 'false' }

type                                                        (*describing:*)
                                                            (*************)

     {marktype= ^integer;}
                                                            (*basic symbols*)
                                                            (***************)

     symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
               lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
               colon,becomes,range,labelsy,constsy,typesy,varsy,funcsy,progsy,
               procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
               beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
               gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
               thensy,othersy);
     operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
                 neop,eqop,inop,noop);
     setofsys = set of symbol;
     chtp = (letter,number,special,illegal,
             chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace,chlcmt);
     { Here is the variable length string containment to save on space. strings
       strings are only stored in their length rounded to the nearest 10th. }
     strvsp = ^strvs; { pointer to variable length id string }
     strvs = record { id string variable length }
                 str:   packed array [1..varsqt] of char; { data contained }
                 next:  strvsp { next }
               end;

                                                            (*constants*)
                                                            (***********)
     setty = set of setlow..sethigh;
     cstclass = (reel,pset,strg);
     csp = ^ constant;
     constant = record
                       rnext: csp; { recycling link }
                       case cclass: cstclass of
                         reel: (rval: packed array [1..strglgth] of char);
                         pset: (pval: setty);
                         strg: (slgth: 0..strglgth;
                                sval: strvsp)
                       end;

     valu = record case intval: boolean of  (*intval never set nor tested*)
                     true:  (ival: integer);
                     false: (valp: csp)
                   end;

                                                           (*data structures*)
                                                           (*****************)
     levrange = 0..maxlevel; addrrange = 0..maxaddr;
     structform = (scalar,subrange,pointer,power,arrays,records,files,
                   tagfld,variant);
     declkind = (standard,declared);
     stp = ^ structure; 
     ctp = ^ identifier;

     structure = packed record
                   rnext: stp; { recycling link }
                   marked: boolean;   (*for test phase only*)
                   size: addrrange;
                   case form: structform of
                     scalar:   (case scalkind: declkind of
                                  declared: (fconst: ctp); standard: ());
                     subrange: (rangetype: stp; min,max: valu);
                     pointer:  (eltype: stp);
                     power:    (elset: stp);
                     arrays:   (aeltype,inxtype: stp);
                     records:  (fstfld: ctp; recvar: stp);
                     files:    (filtype: stp);
                     tagfld:   (tagfieldp: ctp; fstvar: stp);
                     variant:  (nxtvar,subvar: stp; varval: valu)
                   end;

                                                            (*names*)
                                                            (*******)

     idclass = (types,konst,vars,field,proc,func);
     setofids = set of idclass;
     idkind = (actual,formal);
     idstr = packed array [1..maxids] of char;
     restr = packed array [1..reslen] of char;
     identifier = record
                   rnext: ctp; { recycling link }
                   name: strvsp; llink, rlink: ctp;
                   idtype: stp; next: ctp;
                   case klass: idclass of
                     types: ();
                     konst: (values: valu);
                     vars:  (vkind: idkind; vlev: levrange; vaddr: addrrange);
                     field: (fldaddr: addrrange);
                     proc, func:  (pfaddr: addrrange; pflist: ctp; { param list }
                                   case pfdeckind: declkind of
                              standard: (key: 1..18);
                              declared: (pflev: levrange; pfname: integer;
                                          case pfkind: idkind of
                                           actual: (forwdecl, externl: boolean);
                                           formal: ()))
                   end;


     disprange = 0..displimit;
     where = (blck,crec,vrec,rec);

                                                            (*expressions*)
                                                            (*************)
     attrkind = (cst,varbl,expr);
     vaccess = (drct,indrct,inxd);

     attr = record typtr: stp;
              case kind: attrkind of
                cst:   (cval: valu);
                varbl: (case access: vaccess of
                          drct: (vlevel: levrange; dplmt: addrrange);
                          indrct: (idplmt: addrrange);
           inxd: ());
      expr: ()
              end;

     testp = ^ testpointer;
     testpointer = packed record
                     rnext: testp; { recycling link }
                     elt1,elt2 : stp;
                     lasttestp : testp
                   end;

                                                                 (*labels*)
                                                                 (********)
     lbp = ^ labl;
     labl = record 
                   rnext: lbp; { recycling link }
                   nextlab: lbp; defined: boolean;
                   labval, labname: integer;
                   vlevel: levrange; { procedure level of definition }
                   slevel: integer; { statement level of definition }
                   ipcref: boolean; { was referenced by another proc/func }
                   minlvl: integer; { minimum goto reference statement lvl }
                   gcnt:   integer; { number of referencing 'goto's }
            end;
     { label statement nest tracking entries }
     lsp = ^ lstk;
     lstk = record
                  labval: integer; { target label }
                  labl:   boolean; { label or goto }
                  slvl:   integer; { statement nesting level }
                  next:   lsp;     { next entry }
            end;

     extfilep = ^filerec;
     filerec = record filename:idstr; nextfile:extfilep 
               end;

(*-------------------------------------------------------------------------*)

var
    
    source: text;                   { input file }
    prr: text;                      { output code file }
                                    (*returned by source program scanner
                                     insymbol:
                                     **********)

    sy: symbol;                     (*last symbol*)
    op: operator;                   (*classification of last symbol*)
    val: valu;                      (*value of last constant*)
    lgth: integer;                  (*length of last string constant*)
    id: idstr;                      (*last identifier (possibly truncated)*)
    kk: 1..maxids;                  (*nr of chars in last identifier*)
    ch: char;                       (*last character*)
    eol: boolean;                   (*end of line flag*)


                                    (*counters:*)
                                    (***********)

    chcnt: integer;                 (*character counter*)
    lc,ic: addrrange;               (*data location and instruction counter*)
    linecount: integer;


                                    (*switches:*)
                                    (***********)

    dp,                             (*declaration part*)
    prterr,                         (*to allow forward references in pointer type
                                      declaration by suppressing error message*)
    list,prcode,prtables: boolean;  (*output options for
                                        -- source program listing
                                        -- printing symbolic code
                                        -- displaying ident and struct tables
                                        --> procedure option*)
    debug: boolean;


                                    (*pointers:*)
                                    (***********)
    parmptr,
    intptr,realptr,charptr,
    boolptr,nilptr,textptr: stp;    (*pointers to entries of standard ids*)
    utypptr,ucstptr,uvarptr,
    ufldptr,uprcptr,ufctptr,        (*pointers to entries for undeclared ids*)
    fwptr: ctp;                     (*head of chain of forw decl type ids*)
    outputptr,inputptr: ctp;        { pointers to default files }
    fextfilep: extfilep;            (*head of chain of external files*)
    globtestp: testp;               (*last testpointer*)


                                    (*bookkeeping of declaration levels:*)
                                    (************************************)

    level: levrange;                (*current static level*)
    stalvl: integer;                { statement nesting level }
    disx,                           (*level of last id searched by searchid*)
    top: disprange;                 (*top of display*)

    display:                        (*where:   means:*)
      array [disprange] of
        packed record               (*=blck:   id is variable id*)
          fname: ctp; flabel: lbp;  (*=crec:   id is field id in record with*)
          case occur: where of      (*   constant address*)
            crec: (clev: levrange;  (*=vrec:   id is field id in record with*)
                  cdspl: addrrange);(*   variable address*)
            vrec: (vdspl: addrrange);
       blck: ();
       rec: ()
          end;                      (* --> procedure withstatement*)


                                    (*error messages:*)
                                    (*****************)

    errinx: 0..10;                  (*nr of errors in current source line*)
    errlist:
      array [1..10] of
        packed record pos: integer;
                      nmr: 1..500
               end;



                                    (*expression compilation:*)
                                    (*************************)

    gattr: attr;                    (*describes the expr currently compiled*)


                                    (*structured constants:*)
                                    (***********************)

    constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
    statbegsys,typedels: setofsys;
    chartp : array[char] of chtp;
    rw:  array [1..maxres(*nr. of res. words*)] of restr;
    frw: array [1..10] of 1..36(*nr. of res. words + 1*);
    rsy: array [1..maxres(*nr. of res. words*)] of symbol;
    ssy: array [char] of symbol;
    rop: array [1..maxres(*nr. of res. words*)] of operator;
    sop: array [char] of operator;
    na:  array [1..maxstd] of restr;
    mn:  array [0..maxins] of packed array [1..4] of char;
    sna: array [1..maxsp] of packed array [1..4] of char;
    cdx: array [0..maxins] of -4..+4;
    pdx: array [1..maxsp] of -7..+7;
    ordint: array [char] of integer;

    intlabel,mxint10,digmax: integer;
    inputhdf: boolean; { 'input' appears in header files }
    outputhdf: boolean; { 'output' appears in header files }
    labstk: lsp; { label tracking stack }
    errtbl: array [1..500] of boolean; { error occrence tracking }
    toterr: integer; { total errors in program }

    { Dynamic recycling lists. These are only used to emulate mark/release
      behavior in the cases where finding and recycling entries is too
      difficult from existing lists. }
    stplst: stp; { structure recycling list }    
    ctplst: ctp; { identifier recycling list }
    csplst: csp; { constant recycling list }

    { Recycling tracking counters, used to check for new/dispose mismatches. }
    strcnt: integer; { strings }
    cspcnt: integer; { constants }
    stpcnt: integer; { structures }
    ctpcnt: integer; { identifiers }
    tstcnt: integer; { test entries }
    lbpcnt: integer; { label counts }
    lspcnt: integer; { label tracking counts }
    filcnt: integer; { file tracking counts }
    cipcnt: integer; { case entry tracking counts }

    i: integer;
    f: boolean;
   
(*-------------------------------------------------------------------------*)

  { recycle string list }
  procedure putstrs(p: strvsp);
  var p1: strvsp;
  begin
    while p <> nil do begin
      p1 := p; p := p^.next; dispose(p1); strcnt := strcnt-1
    end
  end;

  { push structure entry to recycle list }
  procedure pshstp(p: stp);
  begin
    p^.rnext := stplst;
    stplst := p
  end;

  { recycle structure list }
  procedure putstps;
  var p: stp;
  begin
    while stplst <> nil do begin
      p := stplst; stplst := stplst^.rnext; dispose(p); stpcnt := stpcnt-1
    end
  end;   

  { push identifier entry to recycle list }
  procedure pshctp(p: ctp);
  begin
    p^.rnext := ctplst;
    ctplst := p
  end;

  { recycle identifier list }
  procedure putctps;
  var p: ctp;
  begin
    while ctplst <> nil do begin
      p := ctplst; ctplst := ctplst^.rnext; 
      putstrs(p^.name);
      dispose(p); ctpcnt := ctpcnt-1
    end
  end;   

  { push constant entry to recycle list }
  procedure pshcsp(p: csp);
  begin
    p^.rnext := csplst;
    csplst := p
  end;

  { recycle constant list }
  procedure putcsps;
  var p: csp;
  begin
    while csplst <> nil do begin
      p := csplst; csplst := csplst^.rnext;
      if p^.cclass =  strg then putstrs(p^.sval);
      dispose(p); cspcnt := cspcnt-1
    end
  end;   

  { scrub display level }
  procedure putdsp(l: disprange);
   var p: lbp;
  begin
    while display[l].flabel <> nil do begin
      p := display[l].flabel; display[l].flabel := p^.nextlab; dispose(p); 
      lbpcnt := lbpcnt-1
    end 
  end;

  { scrub all display levels until given }
  procedure putdsps(l: disprange);
  var t: disprange;
  begin
    if l > top then begin
      writeln('*** Compiler internal error');
      goto 99
    end;
    t := top;
    while t > l do begin
      putdsp(t); t := t-1
    end
  end;

  { find lower case of character }
  function lcase(c: char): char;
  begin
    if c in ['A'..'Z'] then c := chr(ord(c)-ord('A')+ord('a'));
    lcase := c
  end { lcase };

  { convert string to lower case }
  procedure lcases(var s: idstr);
  var i: integer;
  begin
    for i := 1 to maxids do s[i] := lcase(s[i]);
  end;

  { find reserved word string equal to id string }
  function strequri(a: restr; var b: idstr): boolean;
  var m: boolean; i: integer;
  begin
    m := true;
    for i := 1 to reslen do if lcase(a[i]) <> lcase(b[i]) then m := false;
    for i := reslen+1 to maxids do if b[i] <> ' ' then m := false;
    strequri := m
  end { equstr };

  { write variable length id string to output }
  procedure writev(s: strvsp; fl: integer);
  var i: integer; c: char;
  begin i := 1;
    while fl > 0 do begin
      c := ' '; if s <> nil then begin c := s^.str[i]; i := i+1 end;
      write(c); fl := fl-1;
      if i > varsqt then begin s := s^.next; i := 1 end
    end
  end;

  { assign fixed to variable length string, including allocation }
  procedure strassvf(var a: strvsp; var b: idstr);
  var i, j, l: integer; p, lp: strvsp;
  begin l := maxids; p := nil; a := nil; j := 1;
    while (l > 1) and (b[l] = ' ') do l := l-1; { find length of fixed string }
    if b[l] = ' ' then l := 0;
    for i := 1 to l do begin
      if j > varsqt then p := nil;
      if p = nil then begin 
        new(p); strcnt := strcnt+1; j := 1; 
        if a = nil then a := p else lp^.next := p; lp := p
      end;
      p^.str[j] := b[i]; j := j+1
    end;
    if p <> nil then for j := j to varsqt do p^.str[j] := ' '
  end;

  { assign reserved word fixed to variable length string, including allocation }
  procedure strassvr(var a: strvsp; b: restr);
  var i, j, l: integer; p, lp: strvsp;
  begin l := reslen; p := nil; a := nil; lp := nil; j := 1;
    while (l > 1) and (b[l] = ' ') do l := l-1; { find length of fixed string }
    if b[l] = ' ' then l := 0;
    for i := 1 to l do begin
      if j > varsqt then p := nil;
      if p = nil then begin 
        new(p); strcnt := strcnt+1; j := 1; 
        if a = nil then a := p else lp^.next := p; lp := p
      end;
      p^.str[j] := b[i]; j := j+1
    end;
    if p <> nil then for j := j to varsqt do p^.str[j] := ' '
  end;

  { compare variable length id strings }
  function strequvv(a, b: strvsp): boolean;
  var m: boolean; i: integer;
  begin
    m := true;
    while (a <> nil) and (b <> nil) do begin
      for i := 1 to varsqt do if lcase(a^.str[i]) <> lcase(b^.str[i]) then m := false;
      a := a^.next; b := b^.next
    end;
    if a <> b then m := false;
    strequvv := m
  end;

  { compare variable length id strings, a < b }
  function strltnvv(a, b: strvsp): boolean;
  var i: integer; ca, cb: char;
  begin ca := ' '; cb := ' ';
    while (a <> nil) or (b <> nil) do begin
      i := 1;
      while (i <= varsqt) and ((a <> nil) or (b <> nil)) do begin
        if a <> nil then ca := lcase(a^.str[i]) else ca := ' ';
        if b <> nil then cb := lcase(b^.str[i]) else cb := ' ';
        if ca <> cb then begin a := nil; b := nil end;
        i := i+1
      end;
      if a <> nil then a := a^.next; if b <> nil then b := b^.next
    end;
    strltnvv := ca < cb
  end;

  { compare variable length id string to fixed }
  function strequvf(a: strvsp; var b: idstr): boolean;
  var m: boolean; i, j: integer; c: char;
  begin
    m := true; j := 1;
    for i := 1 to maxids do begin
      c := ' '; if a <> nil then begin c := a^.str[j]; j := j+1 end;
      if lcase(c) <> lcase(b[i]) then m := false;
      if j > varsqt then begin a := a^.next; j := 1 end
    end;
    strequvf := m
  end;

  { compare variable length id string to fixed, a < b }
  function strltnvf(a: strvsp; var b: idstr): boolean;
  var m: boolean; i, j, f: integer; c: char;
  begin
    m := true; i := 1; j := 1;
    while i < maxids do begin
      c := ' '; if a <> nil then begin c := a^.str[j]; j := j+1 end;
      if lcase(c) <> lcase(b[i]) then begin f := i; i := maxids end else i := i+1;
      if j > varsqt then begin a := a^.next; j := 1 end
    end;
    strltnvf := lcase(c) < lcase(b[f])
  end;

  { dump the display }
  procedure prtdsp;
  var i: integer;
  procedure prtlnk(p: ctp; f: integer);
  var i: integer;
  begin
    if p <> nil then begin
      for i := 1 to f do write(' ');
      writev(p^.name, 10); writeln;
      if p^.llink <> nil then prtlnk(p^.llink, f+3);
      if p^.rlink <> nil then prtlnk(p^.rlink, f+3)
    end
  end;
  begin
    writeln;
    writeln('Display:');
    writeln;
    for i := 0 to displimit do prtlnk(display[i].fname, 0);
    writeln;
  end;

  procedure endofline;
    var lastpos,freepos,currpos,currnmr,f,k: integer;
  begin
    if errinx > 0 then   (*output error messages*)
      begin write(output,linecount:6,' ****  ':9);
        lastpos := 0; freepos := 1;
        for k := 1 to errinx do
          begin
            with errlist[k] do
              begin currpos := pos; currnmr := nmr end;
            if currpos = lastpos then write(output,',')
            else
              begin
                while freepos < currpos do
                  begin write(output,' '); freepos := freepos + 1 end;
                write(output,'^');
                lastpos := currpos
              end;
            if currnmr < 10 then f := 1
            else if currnmr < 100 then f := 2
              else f := 3;
            write(output,currnmr:f);
            freepos := freepos + f + 1
          end;
        writeln(output); errinx := 0
      end;
    linecount := linecount + 1;
    if list and (not eof(source)) then
      begin write(output,linecount:6,'  ':2);
        if dp then write(output,lc:7) else write(output,ic:7);
        write(output,' ')
      end;
    chcnt := 0
  end  (*endofline*) ;

  procedure errmsg(ferrnr: integer);
  begin case ferrnr of
    1:   write('Error in simple type');
    2:   write('Identifier expected');
    3:   write('''program'' expected');
    4:   write(''')'' expected');
    5:   write(''':'' expected');
    6:   write('Illegal symbol');
    7:   write('Error in parameter list');
    8:   write('''of'' expected');
    9:   write('''('' expected');
    10:  write('Error in type');
    11:  write('''['' expected');
    12:  write(''']'' expected');
    13:  write('''end'' expected');
    14:  write(''':'' expected');
    15:  write('Integer expected');
    16:  write('''='' expected');
    17:  write('''begin'' expected');
    18:  write('Error in declaration part');
    19:  write('Error in field-list');
    20:  write(''','' expected');
    21:  write('''*'' expected');

    50:  write('Error in constant');
    51:  write(''':='' expected');
    52:  write('''then'' expected');
    53:  write('''until'' expected');
    54:  write('''do'' expected');
    55:  write('''to''/''downto'' expected');
    56:  write('''if'' expected');
    57:  write('''file'' expected');
    58:  write('Error in factor');
    59:  write('Error in variable');

    101: write('Identifier declared twice');
    102: write('Low bound exceeds highbound');
    103: write('Identifier is not of appropriate class');
    104: write('Identifier not declared');
    105: write('Sign not allowed');
    106: write('Number expected');
    107: write('Incompatible subrange types');
    108: write('File not allowed here');
    109: write('Type must not be real');
    110: write('Tagfield type must be scalar or subrange');
    111: write('Incompatible with tagfield type');
    112: write('Index type must not be real');
    113: write('Index type must be scalar or subrange');
    114: write('Base type must not be real');
    115: write('Base type must be scalar or subrange');
    116: write('Error in type of standard procedure parameter');
    117: write('Unsatisfied forward reference');
    118: write('Forward reference type identifier in variable declaration');
    119: write('Forward declared; repetition of parameter list not allowed');
    120: write('Function result type must be scalar, subrange or point');
    121: write('File value parameter not allowed');
    122: write('Forward declared function; repetition of result type not allowed');
    123: write('Missing result type in function declaration');
    124: write('F-format for real only');
    125: write('Error in type of standard function parameter');
    126: write('Number of parameters does not agree with declaration');
    127: write('Illegal parameter substitution');
    128: write('Result type of parameter function does not agree with declaration');
    129: write('Type conflict of operands');
    130: write('Expression is not of set type');
    131: write('Tests on equality allowed only');
    132: write('Strict inclusion not allowed');
    133: write('File comparison not allowed');
    134: write('Illegal type of operand(s)');
    135: write('Type of operand must be Boolean');
    136: write('Set element type must be scalar nr subrange');
    137: write('Set element types not compatible');
    138: write('Type of variable is not array');
    139: write('Index type is not compatible with declaration');
    140: write('Type of variable is not record');
    141: write('Type of variable must be file or pointer');
    142: write('Illegal parameter substitution');
    143: write('Illegal type of loop control variable');
    144: write('Illegal type of expression');
    145: write('Type conflict');
    146: write('Assignment of files not allowed');
    147: write('Label type incompatible with selecting expression');
    148: write('Subrange bounds must be scalar');
    149: write('Index type must not be integer');
    150: write('Assignment to standard function is not allowed');
    151: write('Assignment to formal function is not allowed');
    152: write('No such field in this record');
    153: write('Type error in read');
    154: write('Actual parameter must be a variable');
    155: write('Control variable must ~ot be declared on intermediate');
    156: write('Multidefined case label');
    157: write('Too many cases in case statement');
    158: write('Missing corresponding variant declaration');
    159: write('Real or string tagfields not allowed');
    160: write('Previous declaration was not forward');
    161: write('Again forward declared');
    162: write('Parameter size must be constant');
    163: write('Missing variant in declaration');
    164: write('Substitution of standard proc/func not allowed');
    165: write('Multidefined label');
    166: write('Multideclared label');
    167: write('Undeclared label');
    168: write('Undefined label');
    169: write('Error in base set');
    170: write('Value parameter expected');
    171: write('Standard file was redeclared');
    172: write('Undeclared external file');
    173: write('Fortran procedure or function expected');
    174: write('Pascal procedure or function expected');
    175: write('Missing file "input" in program heading');
    176: write('Missing file "output" in program heading');
    177: write('Assiqnment to function identifier not allowed here');
    178: write('Multidefined record variant');
    179: write('X-opt of actual proc/funcdoes not match formal declaration');
    180: write('Control variable must not be formal');
    181: write('Constant part of address out of ranqe');
    182: write('identifier too long');
    183: write('For index variable must be local to this block');
    184: write('Interprocedure goto does not reference outter block of destination');
    185: write('Goto references deeper nested statement');
    186: write('Label referenced by goto at lesser statement level');
    187: write('Goto references label in different nested statement');
    188: write('Label referenced by different nested statement');
    189: write('Parameter lists of formal and actual parameters not congruous');

    201: write('Error in real constant: digit expected');
    202: write('String constant must not exceed source line');
    203: write('Integer constant exceeds range');
    204: write('8 or 9 in octal number');
    205: write('Zero strinq not allowed');
    206: write('Integer part of real constant exceeds ranqe');

    250: write('Too many nestedscopes of identifiers');
    251: write('Too many nested procedures and/or functions');
    252: write('Too many forward references of procedure entries');
    253: write('Procedure too long');
    254: write('Too many long constants in this procedure');
    255: write('Too many errors on this source line');
    256: write('Too many external references');
    257: write('Too many externals');
    258: write('Too many local files');
    259: write('Expression too complicated');
    260: write('Too many exit labels');

    300: write('Division by zero');
    301: write('No case provided for this value');
    302: write('Index expression out of bounds');
    303: write('Value to be assigned is out of bounds');
    304: write('Element expression out of range');

    398: write('Implementation restriction');
    399: write('Feature not implemented');

    400,
    500: write('Compiler internal error');
    end    
  end;

  procedure error(ferrnr: integer);
  begin

    { This diagnostic is here because error buffers error numbers til the end
      of line, and sometimes you need to know exactly where they occurred. }

    {
    writeln('error: ', ferrnr:1);
    }

    errtbl[ferrnr] := true; { track this error }
    if errinx >= 9 then
      begin errlist[10].nmr := 255; errinx := 10 end
    else
      begin errinx := errinx + 1;
        errlist[errinx].nmr := ferrnr
      end;
    errlist[errinx].pos := chcnt;
    toterr := toterr+1
  end (*error*) ;

  procedure insymbol;
    (*read next basic symbol of source program and return its
    description in the global variables sy, op, id, val and lgth*)
    label 1,2;
    var i,k,j: integer;
        digit: packed array [1..strglgth] of char;
        string: packed array [1..strglgth] of char;
        lvp: csp; test, ferr: boolean; p, lp: strvsp;

    procedure nextch;
    begin if eol then
      begin if list then writeln(output); endofline
      end;
      if not eof(source) then
       begin eol := eoln(source); read(source,ch);
        if list then write(output,ch);
        chcnt := chcnt + 1
       end
      else
        begin writeln(output,'   *** eof ','encountered');
          test := false
        end
    end;

    procedure options;
    begin
      repeat nextch;
        if ch <> '*' then
          begin
            if ch = 't' then
              begin nextch; prtables := ch = '+' end
            else
              if ch = 'l' then
                begin nextch; list := ch = '+';
                  if not list then writeln(output)
                end
              else
             if ch = 'd' then
               begin nextch; debug := ch = '+' end
             else
                if ch = 'c' then
                  begin nextch; prcode := ch = '+' end;
            nextch
          end
      until ch <> ','
    end (*options*) ;

  begin (*insymbol*)
  1:
    { Skip both spaces and controls. This allows arbitrary formatting characters
      in the source. }
    repeat while (ch <= ' ') and not eol do nextch;
      test := eol;
      if test then nextch
    until not test;
    if chartp[ch] = illegal then
      begin sy := othersy; op := noop;
        error(399); nextch
      end
    else
    case chartp[ch] of
      letter:
        begin k := 0; ferr := true;
          repeat
            if k < maxids then
             begin k := k + 1; id[k] := ch end
            else if ferr then begin error(182); ferr := false end;
            nextch
          until chartp[ch] in [special,illegal,chstrquo,chcolon,
                                chperiod,chlt,chgt,chlparen,chspace];
          if k >= kk then kk := k
          else
            repeat id[kk] := ' '; kk := kk - 1
            until kk = k;
          sy := ident; op := noop;
          if k <= reslen then
            for i := frw[k] to frw[k+1] - 1 do
              if strequri(rw[i], id) then
                begin sy := rsy[i]; op := rop[i]; goto 2 end;
  2:    end;
      number:
        begin op := noop; i := 0;
          repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
          until chartp[ch] <> number;
          if ((ch = '.') and (source^ <> '.') and (source^ <> ')')) or 
             (ch = 'e') then
            begin
              k := i;
              if ch = '.' then
                begin k := k+1; if k <= digmax then digit[k] := ch;
                  nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*)
                  if chartp[ch] <> number then error(201)
                  else
                    repeat k := k + 1;
                      if k <= digmax then digit[k] := ch; nextch
                    until chartp[ch] <>  number
                end;
              if ch = 'e' then
                begin k := k+1; if k <= digmax then digit[k] := ch;
                  nextch;
                  if (ch = '+') or (ch ='-') then
                    begin k := k+1; if k <= digmax then digit[k] := ch;
                      nextch
                    end;
                  if chartp[ch] <> number then error(201)
                  else
                    repeat k := k+1;
                      if k <= digmax then digit[k] := ch; nextch
                    until chartp[ch] <> number
                 end;
               new(lvp,reel); cspcnt := cspcnt+1; pshcsp(lvp); sy:= realconst; 
               lvp^.cclass := reel;
               with lvp^ do
                 begin for i := 1 to strglgth do rval[i] := ' ';
                   if k <= digmax then
                     for i := 2 to k + 1 do rval[i] := digit[i-1]
                   else begin error(203); rval[2] := '0';
                          rval[3] := '.'; rval[4] := '0'
                        end
                 end;
               val.valp := lvp
            end
          else
            begin
              if i > digmax then begin error(203); val.ival := 0 end
              else
                with val do
                  begin ival := 0;
                    for k := 1 to i do
                      begin
                        if ival <= mxint10 then
                          ival := ival*10+ordint[digit[k]]
                        else begin error(203); ival := 0 end
                      end;
                    sy := intconst
                  end
            end
        end;
      chstrquo:
        begin lgth := 0; sy := stringconst;  op := noop;
          repeat
            repeat nextch; lgth := lgth + 1;
                   if lgth <= strglgth then string[lgth] := ch
            until (eol) or (ch = '''');
            if eol then error(202) else nextch
          until ch <> '''';
          lgth := lgth - 1;   (*now lgth = nr of chars in string*)
          if lgth = 0 then error(205) else
          if lgth = 1 then val.ival := ord(string[1])
          else
            begin new(lvp,strg); cspcnt := cspcnt+1; pshcsp(lvp); 
              lvp^.cclass:=strg;
              if lgth > strglgth then
                begin error(399); lgth := strglgth end;
              with lvp^ do
                begin slgth := lgth; p := nil; sval := nil; j := 1;
                  for i := 1 to lgth do begin
                    if j > varsqt then p := nil;
                    if p = nil then begin 
                      new(p); strcnt := strcnt+1; j := 1; 
                      if sval = nil then sval := p else lp^.next := p; lp := p
                    end;
                    p^.str[j] := string[i]; j := j+1;
                  end;
                  if p <> nil then for j := j to varsqt do p^.str[j] := ' '
                end;
              val.valp := lvp
            end
        end;
      chcolon:
        begin op := noop; nextch;
          if ch = '=' then
            begin sy := becomes; nextch end
          else sy := colon
        end;
      chperiod:
        begin op := noop; nextch;
          if ch = '.' then begin sy := range; nextch end
          else if ch = ')' then begin sy := rbrack; nextch end
          else sy := period
        end;
      chlt:
        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;
      chgt:
        begin nextch; sy := relop;
          if ch = '=' then
            begin op := geop; nextch end
          else op := gtop
        end;
      chlparen:
       begin nextch;
         if ch = '*' then
           begin nextch;
             if ch = '$' then options;
             repeat
               while (ch <> '*') and not eof(source) do nextch;
               nextch
             until (ch = ')') or eof(source);
             nextch; goto 1
           end
         else if ch = '.' then begin sy := lbrack; nextch end
         else sy := lparent; 
         op := noop
       end;
      chlcmt:
       begin nextch;
         if ch = '$' then options;
         while (ch <> '}') and not eof(source) do nextch;
         nextch; goto 1
       end;
      special:
        begin sy := ssy[ch]; op := sop[ch];
          nextch
        end;
      chspace: sy := othersy
    end; (*case*)

    { uncommment for lexical dump }

    {
    writeln;
    write('symbol: ');
    case sy of
       ident:       write('ident: ', id:0);
       intconst:    write('int const: ', val.ival:1);
       realconst:   write('real const');
       stringconst: write('string const');
       notsy: write('not'); mulop: write('*'); addop: write('+'); 
       relop: write('<'); lparent: write('('); rparent: write(')');
       lbrack: write('['); rbrack: write(']'); comma: write(',');
       semicolon: write(';'); period: write('.'); arrow: write('^');
       colon: write(':'); becomes: write(':='); range: write('..'); 
       labelsy: write('label'); constsy: write('const'); typesy: write('type');
       varsy: write('var'); funcsy: write('function'); progsy: write('program');
       procsy: write('procedure'); setsy: write('set'); 
       packedsy: write('packed'); arraysy: write('array');
       recordsy: write('record'); filesy: write('file'); 
       forwardsy: write('forward'); beginsy: write('begin');
       ifsy: write('if'); casesy: write('case'); repeatsy: write('repeat');
       whilesy: write('while'); forsy: write('for'); withsy: write('with');
       gotosy: write('goto'); endsy: write('end'); elsesy: write('else');
       untilsy: write('until'); ofsy: write('of'); dosy: write('do');
       tosy: write('to'); downtosy: write('downto'); thensy: write('then');
       othersy: write('<other>');
    end;
    writeln
    }

  end (*insymbol*) ;

  procedure enterid(fcp: ctp);
    (*enter id pointed at by fcp into the name-table,
     which on each declaration level is organised as
     an unbalanced binary tree*)
    var lcp, lcp1: ctp; lleft: boolean;
  begin
    lcp := display[top].fname;
    if lcp = nil then
      display[top].fname := fcp
    else
      begin
        repeat lcp1 := lcp;
          if strequvv(lcp^.name, fcp^.name) then (*name conflict, follow right link*)
            begin error(101); lcp := lcp^.rlink; lleft := false end
          else
            if strltnvv(lcp^.name, fcp^.name) then
              begin lcp := lcp^.rlink; lleft := false end
            else begin lcp := lcp^.llink; lleft := true end
        until lcp = nil;
        if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
      end;
    fcp^.llink := nil; fcp^.rlink := nil
  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;
     var ts: idstr;
  begin
    while fcp <> nil do begin
      ts := id; lcases(ts);
      if strequvf(fcp^.name, ts) then goto 1
      else if strltnvf(fcp^.name, ts) then fcp := fcp^.rlink
        else fcp := fcp^.llink;
    end;
1:  fcp1 := fcp
  end (*searchsection*) ;

  procedure searchidne(fidcls: setofids; var fcp: ctp);
    label 1;
    var lcp: ctp;
        disxl: disprange;
        ts: idstr;
  begin
    for disxl := top downto 0 do
      begin lcp := display[disxl].fname;
        while lcp <> nil do begin
          ts := id; lcases(ts);
          if strequvf(lcp^.name, ts) then
            if lcp^.klass in fidcls then begin disx := disxl; goto 1 end
            else
              begin if prterr then error(103);
                lcp := lcp^.rlink
              end
          else
            if strltnvf(lcp^.name, ts) then
              lcp := lcp^.rlink
            else lcp := lcp^.llink
        end
      end;
      disx := 0;
      lcp := nil; { make sure this is not found }
1:  fcp := lcp
  end (*searchid*) ;

  procedure searchid(fidcls: setofids; var fcp: ctp);
    label 1;
    var lcp: ctp;
  begin
    searchidne(fidcls, lcp); { perform no error search }
    if lcp <> nil then goto 1; { found }
    (*search not successful; suppress error message in case
     of forward referenced type id in pointer type definition
     --> procedure simpletype*)
    if prterr 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
  end (*searchid*) ;

  procedure getbounds(fsp: stp; var fmin,fmax: integer);
    (*get internal bounds of subrange or scalar type*)
    (*assume fsp<>intptr and fsp<>realptr*)
  begin
    fmin := 0; fmax := 0;
    if fsp <> nil then
    with fsp^ do
      if form = subrange then
        begin fmin := min.ival; fmax := max.ival end
      else
          if fsp = charptr then
            begin fmin := ordminchar; fmax := ordmaxchar
            end
          else
            if fconst <> nil then
              fmax := fconst^.values.ival
  end (*getbounds*) ;

  function alignquot(fsp: stp): integer;
  begin
    alignquot := 1;
    if fsp <> nil then
      with fsp^ do
        case form of
          scalar:   if fsp=intptr then alignquot := intal
                    else if fsp=boolptr then alignquot := boolal
                    else if scalkind=declared then alignquot := intal
                    else if fsp=charptr then alignquot := charal
                    else if fsp=realptr then alignquot := realal
                    else (*parmptr*) alignquot := parmal;
          subrange: alignquot := alignquot(rangetype);
          pointer:  alignquot := adral;
          power:    alignquot := setal;
          files:    alignquot := fileal;
          arrays:   alignquot := alignquot(aeltype);
          records:  alignquot := recal;
          variant,tagfld: error(501)
        end
  end (*alignquot*);

  procedure align(fsp: stp; var flc: addrrange);
    var k,l: integer;
  begin
    k := alignquot(fsp);
    l := flc-1;
    flc := l + k  -  (k+l) mod k
  end (*align*);

  procedure printtables(fb: boolean);
    (*print data structure and name table*)
    (* Added these functions to convert pointers to integers.
      Works on any machine where pointers and integers are the same format.
      The original code was for a processor where "ord" would do this, a
      very nonstandard feature [sam] *)
    const intsize = 11; (* size of printed integer *)

    var i, lim: disprange;

    function stptoint(p: stp): integer;
    var r: record case boolean of false: (p: stp); true: (i: integer) end;
    begin r.p := p; stptoint := r.i end;

    function ctptoint(p: ctp): integer;
    var r: record case boolean of false: (p: ctp); true: (i: integer) end;
    begin r.p := p; ctptoint := r.i end;

    procedure marker;
      (*mark data structure entries to avoid multiple printout*)
      var i: integer;

      procedure markctp(fp: ctp); forward;

      procedure markstp(fp: stp);
        (*mark data structures, prevent cycles*)
      begin
        if fp <> nil then
          with fp^ do
            begin marked := true;
              case form of
              scalar:   ;
              subrange: markstp(rangetype);
              pointer:  (*don't mark eltype: cycle possible; will be marked
                        anyway, if fp = true*) ;
              power:    markstp(elset) ;
              arrays:   begin markstp(aeltype); markstp(inxtype) end;
              records:  begin markctp(fstfld); markstp(recvar) end;
              files:    markstp(filtype);
              tagfld:   markstp(fstvar);
              variant:  begin markstp(nxtvar); markstp(subvar) end
              end (*case*)
            end (*with*)
      end (*markstp*);

      procedure markctp;
      begin
        if fp <> nil then
          with fp^ do
            begin markctp(llink); markctp(rlink);
              markstp(idtype)
            end
      end (*markctp*);

    begin (*marker*)
      for i := top downto lim do
        markctp(display[i].fname)
    end (*marker*);

    procedure followctp(fp: ctp); forward;

    procedure followstp(fp: stp);
    begin
      if fp <> nil then
        with fp^ do
          if marked then
            begin marked := false; write(output,' ':4,stptoint(*ord*)(fp):intsize(*6*),size:10);
              case form of
              scalar:   begin write(output,'scalar':10);
                          if scalkind = standard then
                            write(output,'standard':10)
                          else write(output,'declared':10,' ':4,ctptoint(*ord*)(fconst):intsize(*6*));
                          writeln(output)
                        end;
              subrange: begin
                          write(output,'subrange':10,' ':4,stptoint(*ord*)(rangetype):6);
                          if rangetype <> realptr then
                            write(output,min.ival,max.ival)
                          else
                            if (min.valp <> nil) and (max.valp <> nil) then
                              write(output,' ',min.valp^.rval:9,
                                    ' ',max.valp^.rval:9);
                          writeln(output); followstp(rangetype);
                        end;
              pointer:  writeln(output,'pointer':10,' ':4,stptoint(*ord*)(eltype):intsize(*6*));
              power:    begin writeln(output,'set':10,' ':4,stptoint(*ord*)(elset):intsize(*6*));
                          followstp(elset)
                        end;
              arrays:   begin
                          writeln(output,'array':10,' ':4,stptoint(*ord*)(aeltype):intsize(*6*),' ':4,
                            stptoint(*ord*)(inxtype):6);
                          followstp(aeltype); followstp(inxtype)
                        end;
              records:  begin
                          writeln(output,'record':10,' ':4,ctptoint(*ord*)(fstfld):intsize(*6*),' ':4,
                            stptoint(*ord*)(recvar):intsize(*6*)); followctp(fstfld);
                          followstp(recvar)
                        end;
              files:    begin write(output,'file':10,' ':4,stptoint(*ord*)(filtype):intsize(*6*));
                          followstp(filtype)
                        end;
              tagfld:   begin writeln(output,'tagfld':10,' ':4,ctptoint(*ord*)(tagfieldp):intsize(*6*),
                            ' ':4,stptoint(*ord*)(fstvar):intsize(*6*));
                          followstp(fstvar)
                        end;
              variant:  begin writeln(output,'variant':10,' ':4,stptoint(*ord*)(nxtvar):intsize(*6*),
                            ' ':4,stptoint(*ord*)(subvar):intsize(*6*),varval.ival);
                          followstp(nxtvar); followstp(subvar)
                        end
              end (*case*)
            end (*if marked*)
    end (*followstp*);

    procedure followctp;
    begin
      if fp <> nil then
        with fp^ do
          begin write(output,' ':4,ctptoint(*ord*)(fp):intsize(*6*),' '); 
                writev(name, 9); write(' ':4,ctptoint(*ord*)(llink):intsize(*6*),
            ' ':4,ctptoint(*ord*)(rlink):intsize(*6*),' ':4,stptoint(*ord*)(idtype):intsize(*6*));
            case klass of
              types: write(output,'type':10);
              konst: begin write(output,'constant':10,' ':4,ctptoint(*ord*)(next):intsize(*6*));
                       if idtype <> nil then
                         if idtype = realptr then
                           begin
                             if values.valp <> nil then
                               write(output,' ',values.valp^.rval:9)
                           end
                         else
                           if idtype^.form = arrays then  (*stringconst*)
                             begin
                               if values.valp <> nil then
                                 begin write(output,' ');
                                   with values.valp^ do
                                     writev(sval, slgth)
                                 end
                             end
                           else write(output,values.ival)
                     end;
              vars:  begin write(output,'variable':10);
                       if vkind = actual then write(output,'actual':10)
                       else write(output,'formal':10);
                       write(output,' ':4,ctptoint(*ord*)(next):intsize(*6*),vlev,' ':4,vaddr:6 );
                     end;
              field: write(output,'field':10,' ':4,ctptoint(*ord*)(next):intsize(*6*),' ':4,fldaddr:6);
              proc,
              func:  begin
                       if klass = proc then write(output,'procedure':10)
                       else write(output,'function':10);
                       if pfdeckind = standard then
                         write(output,'standard':10, key:10)
                       else
                         begin write(output,'declared':10,' ':4,ctptoint(*ord*)(next):intsize(*6*));
                           write(output,pflev,' ':4,pfname:6);
                           if pfkind = actual then
                             begin write(output,'actual':10);
                               if forwdecl then write(output,'forward':10)
                               else write(output,'notforward':10);
                               if externl then write(output,'extern':10)
                               else write(output,'not extern':10);
                             end
                           else write(output,'formal':10)
                         end
                     end
            end (*case*);
            writeln(output);
            followctp(llink); followctp(rlink);
            followstp(idtype)
          end (*with*)
    end (*followctp*);

  begin (*printtables*)
    writeln(output); writeln(output); writeln(output);
    if fb then lim := 0
    else begin lim := top; write(output,' local') end;
    writeln(output,' tables '); writeln(output);
    marker;
    for i := top downto lim do
      followctp(display[i].fname);
    writeln(output);
    if not eol then write(output,' ':chcnt+16)
  end (*printtables*);

  procedure genlabel(var nxtlab: integer);
  begin intlabel := intlabel + 1;
    nxtlab := intlabel
  end (*genlabel*);

  procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
    var lsy: symbol; test: boolean;

    procedure skip(fsys: setofsys);
      (*skip input string until relevant symbol found*)
    begin
      if not eof(source) then
        begin while not(sy in fsys) and (not eof(source)) do insymbol;
          if not (sy in fsys) then insymbol
        end
    end (*skip*) ;

    procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
      var lsp: stp; lcp: ctp; sign: (none,pos,neg);
          lvp: csp; i: 2..strglgth;
    begin lsp := nil; fvalu.ival := 0;
      if not(sy in constbegsys) then
        begin error(50); skip(fsys+constbegsys) end;
      if sy in constbegsys then
        begin
          if sy = stringconst then
            begin
              if lgth = 1 then lsp := charptr
              else
                begin
                  new(lsp,arrays); stpcnt := stpcnt+1; pshstp(lsp);
                  with lsp^ do
                    begin aeltype := charptr; inxtype := nil;
                       size := lgth*charsize; form := arrays
                    end
                end;
              fvalu := val; insymbol
            end
          else
            begin
              sign := none;
              if (sy = addop) and (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
                            begin new(lvp,reel); cspcnt := cspcnt+1; pshcsp(lvp);
                              if fvalu.valp^.rval[1] = '-' then
                                lvp^.rval[1] := '+'
                              else lvp^.rval[1] := '-';
                              for i := 2 to strglgth do
                                lvp^.rval[i] := fvalu.valp^.rval[i];
                              fvalu.valp := lvp;
                            end
                          end
                        else error(105);
                  insymbol;
                end
              else
                if sy = intconst then
                  begin if sign = neg then val.ival := -val.ival;
                    lsp := intptr; fvalu := val; insymbol
                  end
                else
                  if sy = realconst then
                    begin if sign = neg then val.valp^.rval[1] := '-';
                      lsp := realptr; fvalu := val; insymbol
                    end
                  else
                    begin error(106); skip(fsys) end
            end;
          if not (sy in fsys) then
            begin error(6); skip(fsys) end
          end;
      fsp := lsp
    end (*constant*) ;

    function equalbounds(fsp1,fsp2: stp): boolean;
      var lmin1,lmin2,lmax1,lmax2: integer;
    begin
      if (fsp1=nil) or (fsp2=nil) then equalbounds := true
      else
        begin
          getbounds(fsp1,lmin1,lmax1);
          getbounds(fsp2,lmin2,lmax2);
          equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
        end
    end (*equalbounds*) ;

    function comptypes(fsp1,fsp2: stp) : boolean;
      (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
      var nxt1,nxt2: ctp; comp: boolean;
        ltestp1,ltestp2 : testp;
    begin
      if fsp1 = fsp2 then comptypes := true
      else
        if (fsp1 <> nil) and (fsp2 <> nil) then
          if fsp1^.form = fsp2^.form then
            case fsp1^.form of
              scalar:
                comptypes := false;
                (* identical scalars declared on different levels are
                 not recognized to be compatible*)
              subrange:
                comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
              pointer:
                  begin
                    comp := false; ltestp1 := globtestp;
                    ltestp2 := globtestp;
                    while ltestp1 <> nil do
                      with ltestp1^ do
                        begin
                          if (elt1 = fsp1^.eltype) and
                             (elt2 = fsp2^.eltype) then comp := true;
                          ltestp1 := lasttestp
                        end;
                    if not comp then
                      begin new(ltestp1); tstcnt := tstcnt+1;
                        with ltestp1^ do
                          begin elt1 := fsp1^.eltype;
                            elt2 := fsp2^.eltype;
                            lasttestp := globtestp
                          end;
                        globtestp := ltestp1;
                        comp := comptypes(fsp1^.eltype,fsp2^.eltype);
                        dispose(ltestp1); tstcnt := tstcnt-1
                      end;
                    comptypes := comp; globtestp := ltestp2
                  end;
              power:
                comptypes := comptypes(fsp1^.elset,fsp2^.elset);
              arrays:
                begin
                  comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
                      and comptypes(fsp1^.inxtype,fsp2^.inxtype);
                  comptypes := comp and (fsp1^.size = fsp2^.size) and
                      equalbounds(fsp1^.inxtype,fsp2^.inxtype)
                end;
              records:
                begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
                  while (nxt1 <> nil) and (nxt2 <> nil) do
                    begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
                      nxt1 := nxt1^.next; nxt2 := nxt2^.next
                    end;
                  comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
                              and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
                end;
                (*identical records are recognized to be compatible
                 iff no variants occur*)
              files:
                comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
            end (*case*)
          else (*fsp1^.form <> fsp2^.form*)
            if fsp1^.form = subrange then
              comptypes := comptypes(fsp1^.rangetype,fsp2)
            else
              if fsp2^.form = subrange then
                comptypes := comptypes(fsp1,fsp2^.rangetype)
              else comptypes := false
        else comptypes := true
    end (*comptypes*) ;

    function string(fsp: stp) : boolean;
    begin string := false;
      if fsp <> nil then
        if fsp^.form = arrays then
          if comptypes(fsp^.aeltype,charptr) then string := true
    end (*string*) ;

    procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
      var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
          lsize,displ: addrrange; lmin,lmax: integer;

      procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange);
        var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
            lcnt: integer; lvalu: valu;
      begin fsize := 1;
        if not (sy in simptypebegsys) then
          begin error(1); skip(fsys + simptypebegsys) end;
        if sy in simptypebegsys then
          begin
            if sy = lparent then
              begin ttop := top;   (*decl. consts local to innermost block*)
                while display[top].occur <> blck do begin 
                  putdsp(top); top := top - 1
                end;
                new(lsp,scalar,declared); stpcnt := stpcnt+1; pshstp(lsp);
                with lsp^ do
                  begin size := intsize; form := scalar;
                    scalkind := declared
                  end;
                lcp1 := nil; lcnt := 0;
                repeat insymbol;
                  if sy = ident then
                    begin new(lcp,konst); ctpcnt := ctpcnt+1; pshctp(lcp);
                      with lcp^ do
                        begin strassvf(name, id); idtype := lsp; next := lcp1;
                          values.ival := lcnt; klass := konst
                        end;
                      enterid(lcp);
                      lcnt := lcnt + 1;
                      lcp1 := lcp; insymbol
                    end
                  else error(2);
                  if not (sy in fsys + [comma,rparent]) then
                    begin error(6); skip(fsys + [comma,rparent]) end
                until sy <> comma;
                lsp^.fconst := lcp1; putdsps(ttop); top := ttop;
                if sy = rparent then insymbol else error(4)
              end
            else
              begin
                if sy = ident then
                  begin searchid([types,konst],lcp);
                    insymbol;
                    if lcp^.klass = konst then
                      begin new(lsp,subrange); stpcnt := stpcnt+1; pshstp(lsp);
                        with lsp^, lcp^ do
                          begin rangetype := idtype; form := subrange;
                            if string(rangetype) then
                              begin error(148); rangetype := nil end;
                            min := values; size := intsize
                          end;
                        if sy = range then insymbol else error(5);
                        constant(fsys,lsp1,lvalu);
                        lsp^.max := lvalu;
                        if lsp^.rangetype <> lsp1 then error(107)
                      end
                    else
                      begin lsp := lcp^.idtype;
                        if lsp <> nil then fsize := lsp^.size
                      end
                  end (*sy = ident*)
                else
                  begin new(lsp,subrange); stpcnt := stpcnt+1; pshstp(lsp); 
                    lsp^.form := subrange;
                    constant(fsys + [range],lsp1,lvalu);
                    if string(lsp1) then
                      begin error(148); lsp1 := nil end;
                    with lsp^ do
                      begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
                    if sy = range then insymbol else error(5);
                    constant(fsys,lsp1,lvalu);
                    lsp^.max := lvalu;
                    if lsp^.rangetype <> lsp1 then error(107)
                  end;
                if lsp <> nil then
                  with lsp^ do
                    if form = subrange then
                      if rangetype <> nil then
                        if rangetype = realptr then error(399)
                        else
                          if min.ival > max.ival then error(102)
              end;
            fsp := lsp;
            if not (sy in fsys) then
              begin error(6); skip(fsys) end
          end
            else fsp := nil
      end (*simpletype*) ;

      procedure fieldlist(fsys: setofsys; var frecvar: stp);
        var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
            minsize,maxsize,lsize: addrrange; lvalu: valu;
      begin nxt1 := nil; lsp := nil;
        if not (sy in (fsys+[ident,casesy])) then
          begin error(19); skip(fsys + [ident,casesy]) end;
        while sy = ident do
          begin nxt := nxt1;
            repeat
              if sy = ident then
                begin new(lcp,field); ctpcnt := ctpcnt+1; pshctp(lcp);
                  with lcp^ do
                    begin strassvf(name, id); idtype := nil; next := nxt;
                      klass := field
                    end;
                  nxt := lcp;
                  enterid(lcp);
                  insymbol
                end
              else error(2);
              if not (sy in [comma,colon]) then
                begin error(6); skip(fsys + [comma,colon,semicolon,casesy])
                end;
              test := sy <> comma;
              if not test  then insymbol
            until test;
            if sy = colon then insymbol else error(5);
            typ(fsys + [casesy,semicolon],lsp,lsize);
            while nxt <> nxt1 do
              with nxt^ do
                begin align(lsp,displ);
                  idtype := lsp; fldaddr := displ;
                  nxt := next; displ := displ + lsize
                end;
            nxt1 := lcp;
            while sy = semicolon do
              begin insymbol;
                if not (sy in fsys + [ident,casesy,semicolon]) then
                  begin error(19); skip(fsys + [ident,casesy]) end
              end
          end (*while*);
        nxt := nil;
        while nxt1 <> nil do
          with nxt1^ do
            begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
        if sy = casesy then
          begin new(lsp,tagfld); stpcnt := stpcnt+1; pshstp(lsp);
            with lsp^ do
              begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
            frecvar := lsp;
            insymbol;
            if sy = ident then 
              begin
                { find possible type first }
                searchidne([types],lcp1);
                { now set up as field id }
                new(lcp,field); ctpcnt := ctpcnt+1; pshctp(lcp);
                with lcp^ do
                  begin strassvf(name, id); idtype := nil; klass:=field;
                    next := nil; fldaddr := displ
                  end;
                insymbol;
                { If type only (undiscriminated variant), kill the id. Note
                  we should recycle the name entry. }
                if sy = colon then begin 
                  enterid(lcp); insymbol;
                  if sy = ident then begin searchid([types],lcp1); insymbol end
                  else begin error(2); skip(fsys + [ofsy,lparent]); lcp1 := nil end
                end else lcp^.name := nil; { set no tagfield }
                if lcp1 <> nil then begin
                  lsp1 := lcp1^.idtype;
                  if lsp1 <> nil then
                    begin align(lsp1,displ);
                      lcp^.fldaddr := displ;
                      { only allocate field if named }
                      if lcp^.name <> nil then displ := displ+lsp1^.size;
                      if (lsp1^.form <= subrange) or string(lsp1) then
                        begin if comptypes(realptr,lsp1) then error(109)
                          else if string(lsp1) then error(399);
                          lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
                        end
                      else error(110);
                    end
                  end
              end
            else begin error(2); skip(fsys + [ofsy,lparent]) end;
            lsp^.size := displ;
            if sy = ofsy then insymbol else error(8);
            lsp1 := nil; minsize := displ; maxsize := displ;
            repeat lsp2 := nil;
              if not (sy in fsys + [semicolon]) then
              begin
                repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
                  if lsp^.tagfieldp <> nil then
                   if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111);
                  new(lsp3,variant); stpcnt := stpcnt+1; pshstp(lsp3);
                  with lsp3^ do
                    begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
                      form := variant
                    end;
                  lsp4 := lsp1;
                  while lsp4 <> nil do
                    with lsp4^ do
                      begin
                        if varval.ival = lvalu.ival then error(178);
                        lsp4 := nxtvar
                      end;
                  lsp1 := lsp3; lsp2 := lsp3;
                  test := sy <> comma;
                  if not test then insymbol
                until test;
                if sy = colon then insymbol else error(5);
                if sy = lparent then insymbol else error(9);
                fieldlist(fsys + [rparent,semicolon],lsp2);
                if displ > maxsize then maxsize := displ;
                while lsp3 <> nil do
                  begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
                    lsp3^.size := displ;
                    lsp3 := lsp4
                  end;
                if sy = rparent then
                  begin insymbol;
                    if not (sy in fsys + [semicolon]) then
                      begin error(6); skip(fsys + [semicolon]) end
                  end
                else error(4);
              end;
              test := sy <> semicolon;
              if not test then
                begin displ := minsize;
                      insymbol
                end
            until test;
            displ := maxsize;
            lsp^.fstvar := lsp1;
          end
        else frecvar := nil
      end (*fieldlist*) ;

    begin (*typ*)
      if not (sy in typebegsys) then
         begin error(10); skip(fsys + typebegsys) end;
      if sy in typebegsys then
        begin
          if sy in simptypebegsys then simpletype(fsys,fsp,fsize)
          else
    (*^*)     if sy = arrow then
              begin new(lsp,pointer); stpcnt := stpcnt+1; pshstp(lsp); fsp := lsp;
                with lsp^ do
                  begin eltype := nil; size := ptrsize; form:=pointer end;
                insymbol;
                if sy = ident then
                  begin prterr := false; (*no error if search not successful*)
                    searchid([types],lcp); prterr := true;
                    if lcp = nil then   (*forward referenced type id*)
                      begin new(lcp,types); ctpcnt := ctpcnt+1; pshctp(lcp);
                        with lcp^ do
                          begin strassvf(name, id); idtype := lsp;
                            next := fwptr; klass := types
                          end;
                        fwptr := lcp
                      end
                    else
                      begin
                        if lcp^.idtype <> nil then
                          if lcp^.idtype^.form = files then error(108)
                          else lsp^.eltype := lcp^.idtype
                      end;
                    insymbol;
                  end
                else error(2);
              end
            else
              begin
                if sy = packedsy then
                  begin insymbol;
                    if not (sy in typedels) then
                      begin
                        error(10); skip(fsys + typedels)
                      end
                  end;
    (*array*)     if sy = arraysy then
                  begin insymbol;
                    if sy = lbrack then insymbol else error(11);
                    lsp1 := nil;
                    repeat new(lsp,arrays); stpcnt := stpcnt+1; pshstp(lsp);
                      with lsp^ do
                        begin aeltype := lsp1; inxtype := nil; form:=arrays end;
                      lsp1 := lsp;
                      simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize);
                      lsp1^.size := lsize;
                      if lsp2 <> nil then
                        if lsp2^.form <= subrange then
                          begin
                            if lsp2 = realptr then
                              begin error(109); lsp2 := nil end
                            else
                              if lsp2 = intptr then
                                begin error(149); lsp2 := nil end;
                            lsp^.inxtype := lsp2
                          end
                        else begin error(113); lsp2 := nil end;
                      test := sy <> comma;
                      if not test then insymbol
                    until test;
                    if sy = rbrack then insymbol else error(12);
                    if sy = ofsy then insymbol else error(8);
                    typ(fsys,lsp,lsize);
                    repeat
                      with lsp1^ do
                        begin lsp2 := aeltype; aeltype := lsp;
                          if inxtype <> nil then
                            begin getbounds(inxtype,lmin,lmax);
                              align(lsp,lsize);
                              lsize := lsize*(lmax - lmin + 1);
                              size := lsize
                            end
                        end;
                      lsp := lsp1; lsp1 := lsp2
                    until lsp1 = nil
                  end
                else
    (*record*)      if sy = recordsy then
                    begin insymbol;
                      oldtop := top;
                      if top < displimit then
                        begin top := top + 1;
                          with display[top] do
                            begin fname := nil;
                                  flabel := nil;
                                  occur := rec
                            end
                        end
                      else error(250);
                      displ := 0;
                      fieldlist(fsys-[semicolon]+[endsy],lsp1);
                      new(lsp,records); stpcnt := stpcnt+1; pshstp(lsp);
                      with lsp^ do
                        begin fstfld := display[top].fname;
                          recvar := lsp1; size := displ; form := records
                        end;
                      putdsps(oldtop); top := oldtop;
                      if sy = endsy then insymbol else error(13)
                    end
                  else
    (*set*)        if sy = setsy then
                      begin insymbol;
                        if sy = ofsy then insymbol else error(8);
                        simpletype(fsys,lsp1,lsize);
                        if lsp1 <> nil then
                          if lsp1^.form > subrange then
                            begin error(115); lsp1 := nil end
                          else
                            if lsp1 = realptr then
                              begin error(114); lsp1 := nil end
                            else if lsp1 = intptr then
                              begin error(169); lsp1 := nil end
                            else
                              begin getbounds(lsp1,lmin,lmax);
                                if (lmin < setlow) or (lmax > sethigh)
                                  then error(169);
                              end;
                        new(lsp,power); stpcnt := stpcnt+1; pshstp(lsp);
                        with lsp^ do
                          begin elset:=lsp1; size:=setsize; form:=power end;
                      end
                    else
    (*file*)        if sy = filesy then
                          begin insymbol;
                            if sy = ofsy then insymbol else error(8);
                            typ(fsys,lsp1,lsize);
                            new(lsp,files); stpcnt := stpcnt+1; pshstp(lsp);
                            with lsp^ do
                              begin filtype := lsp1; size := filesize+lsize; 
                                form := files 
                              end
                          end;
                fsp := lsp
              end;
          if not (sy in fsys) then
            begin error(6); skip(fsys) end
        end
      else fsp := nil;
      if fsp = nil then fsize := 1 else fsize := fsp^.size
    end (*typ*) ;

    procedure labeldeclaration;
      var llp: lbp; redef: boolean; lbname: integer;
    begin
      repeat
        if sy = intconst then
          with display[top] do
            begin llp := flabel; redef := false;
              while (llp <> nil) and not redef do
                if llp^.labval <> val.ival then
                  llp := llp^.nextlab
                else begin redef := true; error(166) end;
              if not redef then
                begin new(llp); lbpcnt := lbpcnt+1;
                  with llp^ do
                    begin labval := val.ival; genlabel(lbname);
                      defined := false; nextlab := flabel; labname := lbname;
                      vlevel := level; slevel := 0; ipcref := false; 
                      minlvl := maxint; gcnt := 0;
                    end;
                  flabel := llp
                end;
              insymbol
            end
        else error(15);
        if not ( sy in fsys + [comma, semicolon] ) then
          begin error(6); skip(fsys+[comma,semicolon]) end;
        test := sy <> comma;
        if not test then insymbol
      until test;
      if sy = semicolon then insymbol else error(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); ctpcnt := ctpcnt+1; pshctp(lcp);
          with lcp^ do
            begin strassvf(name, id); idtype := nil; next := nil; klass:=konst end;
          insymbol;
          if (sy = relop) and (op = eqop) then insymbol else error(16);
          constant(fsys + [semicolon],lsp,lvalu);
          enterid(lcp);
          lcp^.idtype := lsp; lcp^.values := lvalu;
          if sy = semicolon then
            begin insymbol;
              if not (sy in fsys + [ident]) then
                begin error(6); skip(fsys + [ident]) end
            end
          else error(14)
        end
    end (*constdeclaration*) ;

    procedure typedeclaration;
      var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
    begin
      if sy <> ident then
        begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
        begin new(lcp,types); ctpcnt := ctpcnt+1; pshctp(lcp);
          with lcp^ do
            begin strassvf(name, id); idtype := nil; klass := types end;
          insymbol;
          if (sy = relop) and (op = eqop) then insymbol else error(16);
          typ(fsys + [semicolon],lsp,lsize);
          enterid(lcp);
          lcp^.idtype := lsp;
          (*has any forward reference been satisfied:*)
          lcp1 := fwptr;
          while lcp1 <> nil do
            begin
              if strequvv(lcp1^.name, lcp^.name) then
                begin lcp1^.idtype^.eltype := lcp^.idtype;
                  if lcp1 <> fwptr then
                    lcp2^.next := lcp1^.next
                  else fwptr := lcp1^.next;
                end
              else lcp2 := lcp1;
              lcp1 := lcp1^.next
            end;
          if sy = semicolon then
            begin insymbol;
              if not (sy in fsys + [ident]) then
                begin error(6); skip(fsys + [ident]) end
            end
          else error(14)
        end;
      if fwptr <> nil then
        begin error(117); writeln(output);
          repeat write(' type-id '); writev(fwptr^.name, prtlln); writeln;
            fwptr := fwptr^.next
          until fwptr = nil;
          if not eol then write(output,' ': chcnt+16)
        end
    end (*typedeclaration*) ;

    procedure vardeclaration;
      var lcp,nxt: ctp; lsp: stp; lsize: addrrange;
    begin nxt := nil;
      repeat
        repeat
          if sy = ident then
            begin new(lcp,vars); ctpcnt := ctpcnt+1; pshctp(lcp);
              with lcp^ do
               begin strassvf(name, id); next := nxt; klass := vars;
                  idtype := nil; vkind := actual; vlev := level
                end;
              enterid(lcp);
              nxt := lcp;
              insymbol;
            end
          else error(2);
          if not (sy in fsys + [comma,colon] + typedels) then
            begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end;
          test := sy <> comma;
          if not test then insymbol
        until test;
        if sy = colon then insymbol else error(5);
        typ(fsys + [semicolon] + typedels,lsp,lsize);
        while nxt <> nil do
          with  nxt^ do
            begin align(lsp,lc);
              idtype := lsp; vaddr := lc;
              lc := lc + lsize; nxt := next
            end;
        if sy = semicolon then
          begin insymbol;
            if not (sy in fsys + [ident]) then
              begin error(6); skip(fsys + [ident]) end
          end
        else error(14)
      until (sy <> ident) and not (sy in typedels);
      if fwptr <> nil then
        begin error(117); writeln(output);
          repeat write(' type-id '); writev(fwptr^.name, prtlln); writeln;
            fwptr := fwptr^.next
          until fwptr = nil;
          if not eol then write(output,' ': chcnt+16)
        end
    end (*vardeclaration*) ;

    procedure procdeclaration(fsy: symbol);
      var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
          forw: boolean; oldtop: disprange;
          llc,lcm: addrrange; lbname: integer; {markp: marktype;}
          stprcy: stp; ctprcy: ctp; csprcy: csp;

      procedure pushlvl(forw: boolean; lcp: ctp);
      begin
        if level < maxlevel then level := level + 1 else error(251);
        if top < displimit then
          begin top := top + 1;
            with display[top] do
              begin
                if forw then fname := lcp^.pflist
                else fname := nil;
                flabel := nil;
                occur := blck
              end
          end
        else error(250);
      end;

      procedure parameterlist(fsy: setofsys; var fpar: ctp);
        var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
          llc,lsize: addrrange; count: integer;
          oldlev: 0..maxlevel; oldtop: disprange;
          lcs: addrrange;
      begin lcp1 := nil;
        if not (sy in fsy + [lparent]) then
          begin error(7); skip(fsys + fsy + [lparent]) end;
        if sy = lparent then
          begin if forw then error(119);
            insymbol;
            if not (sy in [ident,varsy,procsy,funcsy]) then
              begin error(7); skip(fsys + [ident,rparent]) end;
            while sy in [ident,varsy,procsy,funcsy] do
              begin
                if sy = procsy then
                  begin
                    insymbol; lcp := nil;
                    if sy = ident then
                      begin new(lcp,proc,declared,formal); ctpcnt := ctpcnt+1; 
                        pshctp(lcp);
                        with lcp^ do
                          begin strassvf(name, id); idtype := nil; next := lcp1;
                            pflev := level (*beware of parameter procedures*);
                            klass:=proc;pfdeckind:=declared;
                            pfkind:=formal; pfaddr := lc;
                          end;
                        enterid(lcp);
                        lcp1 := lcp;
                        align(parmptr,lc);
                        lc := lc+ptrsize*2; { mp and addr }
                        insymbol
                      end
                    else error(2);
                    oldlev := level; oldtop := top; pushlvl(false, lcp);
                    lcs := lc; parameterlist([semicolon,rparent],lcp2); lc := lcs;
                    if lcp <> nil then lcp^.pflist := lcp2;
                    if not (sy in fsys+[semicolon,rparent]) then
                      begin error(7);skip(fsys+[semicolon,rparent]) end;
                    level := oldlev; putdsps(oldtop); top := oldtop
                  end
                else
                  begin
                    if sy = funcsy then
                      begin lcp2 := nil;
                        insymbol;
                        if sy = ident then
                          begin new(lcp,func,declared,formal); ctpcnt := ctpcnt+1;
                            pshctp(lcp);
                            with lcp^ do
                              begin strassvf(name, id); idtype := nil; next := lcp1;
                                pflev := level (*beware param funcs*);
                                klass:=func;pfdeckind:=declared;
                                pfkind:=formal; pfaddr:=lc;
                              end;
                            enterid(lcp);
                            lcp1 := lcp;
                            align(parmptr,lc);
                            lc := lc+ptrsize*2; { mp and addr }
                            insymbol;
                          end
                        else error(2);
                        oldlev := level; oldtop := top; pushlvl(false, lcp);
                        lcs := lc; parameterlist([colon,semicolon,rparent],lcp2); lc := lcs;
                        if lcp <> nil then lcp^.pflist := lcp2;
                        if not (sy in fsys+[colon]) then
                          begin error(7);skip(fsys+[comma,semicolon,rparent]) end;
                        if sy = colon then
                          begin insymbol;
                            if sy = ident then
                              begin 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); lsp := nil end;
                                insymbol
                              end
                            else error(2);
                            if not (sy in fsys + [semicolon,rparent]) then
                              begin error(7);skip(fsys+[semicolon,rparent])end
                          end
                        else error(5);
                        level := oldlev; putdsps(oldtop); top := oldtop
                      end
                    else
                      begin
                        if sy = varsy then
                          begin lkind := formal; insymbol end
                        else lkind := actual;
                        lcp2 := nil;
                        count := 0;
                        repeat
                          if sy = ident then
                            begin new(lcp,vars); ctpcnt := ctpcnt+1; pshctp(lcp);
                              with lcp^ do
                                begin strassvf(name,id); idtype:=nil; klass:=vars;
                                  vkind := lkind; next := lcp2; vlev := level;
                                end;
                              enterid(lcp);
                              lcp2 := lcp; count := count+1;
                              insymbol;
                            end;
                          if not (sy in [comma,colon] + fsys) then
                            begin error(7);skip(fsys+[comma,semicolon,rparent])
                            end;
                          test := sy <> comma;
                          if not test then insymbol
                        until test;
                        if sy = colon then
                          begin insymbol;
                            if sy = ident then
                              begin searchid([types],lcp);
                                lsp := lcp^.idtype;
                                lsize := ptrsize;
                                if lsp <> nil then
                                  if lkind=actual then
                                    if lsp^.form<=power then lsize := lsp^.size
                                    else if lsp^.form=files then error(121);
                                align(parmptr,lsize);
                                lcp3 := lcp2;
                                align(parmptr,lc);
                                lc := lc+count*lsize;
                                llc := lc;
                                while lcp2 <> nil do
                                  begin lcp := lcp2;
                                    with lcp2^ do
                                      begin idtype := lsp;
                                        llc := llc-lsize;
                                        vaddr := llc;
                                      end;
                                    lcp2 := lcp2^.next
                                  end;
                                lcp^.next := lcp1; lcp1 := lcp3;
                                insymbol
                              end
                            else error(2);
                            if not (sy in fsys + [semicolon,rparent]) then
                              begin error(7);skip(fsys+[semicolon,rparent])end
                          end
                        else error(5);
                      end;
                  end;
                if sy = semicolon then
                  begin insymbol;
                    if not (sy in fsys + [ident,varsy,procsy,funcsy]) then
                      begin error(7); skip(fsys + [ident,rparent]) end
                  end
              end (*while*) ;
            if sy = rparent then
              begin insymbol;
                if not (sy in fsy + fsys) then
                  begin error(6); skip(fsy + fsys) end
              end
            else error(4);
            lcp3 := nil;
            (*reverse pointers and reserve local cells for copies of multiple
             values*)
            while lcp1 <> nil do
              with lcp1^ do
                begin lcp2 := next; next := lcp3;
                  if klass = vars then
                    if idtype <> nil then
                      if (vkind=actual)and(idtype^.form>power) then
                        begin align(idtype,lc);
                          vaddr := lc;
                          lc := lc+idtype^.size;
                        end;
                  lcp3 := lcp1; lcp1 := lcp2
                end;
            fpar := lcp3
          end
            else fpar := nil
    end (*parameterlist*) ;

    begin (*procdeclaration*)
      llc := lc; lc := lcaftermarkstack; forw := false;
      if sy = ident then
        begin searchsection(display[top].fname,lcp); (*decide whether forw.*)
          if lcp <> nil then
            begin
              if lcp^.klass = proc then
                forw := lcp^.forwdecl and(fsy=procsy)and(lcp^.pfkind=actual)
              else
                if lcp^.klass = func then
                  forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual)
                else forw := false;
              if not forw then error(160)
            end;
          if not forw then
            begin
              if fsy = procsy then new(lcp,proc,declared,actual)
              else new(lcp,func,declared,actual);
              ctpcnt := ctpcnt+1; pshctp(lcp);
              with lcp^ do
                begin strassvf(name, id); idtype := nil;
                  externl := false; pflev := level; genlabel(lbname);
                  pfdeckind := declared; pfkind := actual; pfname := lbname;
                  if fsy = procsy then klass := proc
                  else klass := func
                end;
              enterid(lcp)
            end
          else
            begin lcp1 := lcp^.pflist;
              while lcp1 <> nil do
                begin
                  with lcp1^ do
                    if klass = vars then
                      if idtype <> nil then
                        begin lcm := vaddr + idtype^.size;
                          if lcm > lc then lc := lcm
                        end;
                  lcp1 := lcp1^.next
                end
            end;
          insymbol
        end
      else
        begin error(2); lcp := ufctptr end;
      oldlev := level; oldtop := top;
      pushlvl(forw, lcp);
      if fsy = procsy then
        begin parameterlist([semicolon],lcp1);
          if not forw then lcp^.pflist := lcp1
        end
      else
        begin parameterlist([semicolon,colon],lcp1);
          if not forw then lcp^.pflist := lcp1;
          if sy = colon then
            begin insymbol;
              if sy = ident then
                begin if forw then error(122);
                  searchid([types],lcp1);
                  lsp := lcp1^.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 + [semicolon]) end
            end
          else
            if not forw then error(123)
        end;
      if sy = semicolon then insymbol else error(14);
      if sy = forwardsy then
        begin
          if forw then error(161)
          else lcp^.forwdecl := true;
          insymbol;
          if sy = semicolon then insymbol else error(14);
          if not (sy in fsys) then
            begin error(6); skip(fsys) end
        end
      else
        begin lcp^.forwdecl := false;
          { save and clear recyling entries } 
          stprcy := stplst; stplst := nil;
          ctprcy := ctplst; ctplst := nil;
          csprcy := csplst; csplst := nil;
          { mark(markp); }
          repeat block(fsys,semicolon,lcp);
            if sy = semicolon then
              begin if prtables then printtables(false); insymbol;
                if not (sy in [beginsy,procsy,funcsy]) then
                  begin error(6); skip(fsys) end
              end
            else error(14)
          until (sy in [beginsy,procsy,funcsy]) or eof(source);
          { release recycle entries }
          putstps; stplst := stprcy;
          putctps; ctplst := ctprcy;
          putcsps; csplst := csprcy;
          { release(markp); } (* return local entries on runtime heap *)
        end;
      level := oldlev; putdsps(oldtop); top := oldtop; lc := llc;
    end (*procdeclaration*) ;

    procedure body(fsys: setofsys);
      const cstoccmax=4000(*65*); cixmax=1000; (* cstoccmax was too small [sam] *)
      type oprange = 0..maxins;
      var
          llcp:ctp; saveid:idstr;
          cstptr: array [1..cstoccmax] of csp;
          cstptrix: 0..cstoccmax;
          (*allows referencing of noninteger constants by an index
           (instead of a pointer), which can be stored in the p2-field
           of the instruction record until writeout.
           --> procedure load, procedure writeout*)
          entname, segsize: integer;
          stacktop, topnew, topmax: integer;
          lcmax,llc1: addrrange; lcp: ctp;
          llp: lbp;
          fp: extfilep;

      procedure prglab(l: integer);
      var lp: lsp;
      begin
        lp := labstk; 
        while lp <> nil do if lp^.slvl = l then
          begin lp := labstk; labstk := labstk^.next; dispose(lp); 
            lspcnt := lspcnt-1; lp := labstk 
          end else lp := nil
      end;

      procedure mes(i: integer);
      begin topnew := topnew + cdx[i]*maxstack;
        if topnew > topmax then topmax := topnew
      end;

      procedure putic;
      begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end;

      procedure gen0(fop: oprange);
      begin
        if prcode then begin putic; writeln(prr,mn[fop]:4) end;
        ic := ic + 1; mes(fop)
      end (*gen0*) ;

      procedure gen1(fop: oprange; fp2: integer);
        var k, j: integer; p: strvsp;
      begin
        if prcode then
          begin putic; write(prr,mn[fop]:4);
            if fop = 30 then
              begin writeln(prr,sna[fp2]:12);
                topnew := topnew + pdx[fp2]*maxstack;
                if topnew > topmax then topmax := topnew
              end
            else
              begin
                if fop = 38 then
                   begin write(prr,' ''');
                     with cstptr[fp2]^ do begin p := sval; j := 1;
                       for k := 1 to slgth do begin
                         if p^.str[j] = '''' then write(prr, '''''')
                         else write(prr,p^.str[j]:1);
                         j := j+1; if j > varsqt then begin 
                           p := p^.next; j := 1 
                         end
                       end
                     end;
                     writeln(prr,'''')
                   end
                else if fop = 42 then writeln(prr,chr(fp2))
                else if fop = 67 then writeln(prr,fp2:4)
                else writeln(prr,fp2:12);
                mes(fop)
              end
          end;
        ic := ic + 1
      end (*gen1*) ;

      procedure gen2(fop: oprange; fp1,fp2: integer);
        var k : integer;
      begin
        if prcode then
          begin putic; write(prr,mn[fop]:4);
            case fop of
              45,50,54,56,74:
                writeln(prr,' ',fp1:3,fp2:8);
              47,48,49,52,53,55:
                begin write(prr,chr(fp1));
                  if chr(fp1) = 'm' then write(prr,fp2:11);
                  writeln(prr)
                end;
              51:
                case fp1 of
                  1: writeln(prr,'i ',fp2);
                  2: begin write(prr,'r ');
                       with cstptr[fp2]^ do
                         for k := 1 to strglgth do write(prr,rval[k]);
                       writeln(prr)
                     end;
                  3: writeln(prr,'b ',fp2);
                  4: writeln(prr,'n');
                  6: writeln(prr,'c ''':3,chr(fp2),'''');
                  5: begin write(prr,'(');
                       with cstptr[fp2]^ do
                         for k := setlow to sethigh do
                           (* increased for testing [sam] *)
                           if k in pval then write(prr,k:7(*3*));
                       writeln(prr,')')
                     end
                end
            end;
          end;
        ic := ic + 1; mes(fop)
      end (*gen2*) ;

      procedure gentypindicator(fsp: stp);
      begin
        if fsp<>nil then
          with fsp^ do
            case form of
             scalar: if fsp=intptr then write(prr,'i')
                     else
                       if fsp=boolptr then write(prr,'b')
                       else
                         if fsp=charptr then write(prr,'c')
                         else
                           if scalkind = declared then write(prr,'i')
                           else write(prr,'r');
             subrange: gentypindicator(rangetype);
             pointer:  write(prr,'a');
             power:    write(prr,'s');
             records,arrays: write(prr,'m');
             files:    write(prr,'a');
             tagfld,variant: error(500)
            end
      end (*typindicator*);

      procedure gen0t(fop: oprange; fsp: stp);
      begin
        if prcode then
          begin putic;
            write(prr,mn[fop]:4);
            gentypindicator(fsp);
            writeln(prr);
          end;
        ic := ic + 1; mes(fop)
      end (*gen0t*);

      procedure gen1t(fop: oprange; fp2: integer; fsp: stp);
      begin
        if prcode then
          begin putic;
            write(prr,mn[fop]:4);
            gentypindicator(fsp);
            writeln(prr,fp2:11)
          end;
        ic := ic + 1; mes(fop)
      end (*gen1t*);

      procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp);
      begin
        if prcode then
          begin putic;
            write(prr,mn[fop]: 4);
            gentypindicator(fsp);
            writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:11);
          end;
        ic := ic + 1; mes(fop)
      end (*gen2t*);

      procedure load;
      begin
        with gattr do
          if typtr <> nil then
            begin
              case kind of
                cst:   if (typtr^.form = scalar) and (typtr <> realptr) then
                         if typtr = boolptr then gen2(51(*ldc*),3,cval.ival)
                         else
                           if typtr=charptr then
                             gen2(51(*ldc*),6,cval.ival)
                           else gen2(51(*ldc*),1,cval.ival)
                       else
                         if typtr = nilptr then gen2(51(*ldc*),4,0)
                         else
                           if cstptrix >= cstoccmax then error(254)
                           else
                             begin cstptrix := cstptrix + 1;
                               cstptr[cstptrix] := cval.valp;
                               if typtr = realptr then
                                 gen2(51(*ldc*),2,cstptrix)
                               else
                                 gen2(51(*ldc*),5,cstptrix)
                             end;
                varbl: case access of
                         drct:   if vlevel<=1 then gen1t(39(*ldo*),dplmt,typtr)
                                 else gen2t(54(*lod*),level-vlevel,dplmt,typtr);
                         indrct: gen1t(35(*ind*),idplmt,typtr);
                         inxd:   error(400)
                       end;
                expr:
              end;
              kind := expr
            end
      end (*load*) ;

      procedure store(var fattr: attr);
      begin
        with fattr do
          if typtr <> nil then
            case access of
              drct:   if vlevel <= 1 then gen1t(43(*sro*),dplmt,typtr)
                      else gen2t(56(*str*),level-vlevel,dplmt,typtr);
              indrct: if idplmt <> 0 then error(400)
                      else gen0t(26(*sto*),typtr);
              inxd:   error(400)
            end
      end (*store*) ;

      procedure loadaddress;
      begin
        with gattr do
          if typtr <> nil then
            begin
              case kind of
                cst:   if string(typtr) then
                         if cstptrix >= cstoccmax then error(254)
                         else
                           begin cstptrix := cstptrix + 1;
                             cstptr[cstptrix] := cval.valp;
                             gen1(38(*lca*),cstptrix)
                           end
                       else error(400);
                varbl: case access of
                         drct:   if vlevel <= 1 then gen1(37(*lao*),dplmt)
                                 else gen2(50(*lda*),level-vlevel,dplmt);
                         indrct: if idplmt <> 0 then
                                   gen1t(34(*inc*),idplmt,nilptr);
                         inxd:   error(400)
                       end;
                expr:  error(400)
              end;
              kind := varbl; access := indrct; idplmt := 0
            end
      end (*loadaddress*) ;


      procedure genfjp(faddr: integer);
      begin load;
        if gattr.typtr <> nil then
          if gattr.typtr <> boolptr then error(144);
        if prcode then begin putic; writeln(prr,mn[33]:4,' l':8,faddr:4) end;
        ic := ic + 1; mes(33)
      end (*genfjp*) ;

      procedure genujpxjp(fop: oprange; fp2: integer);
      begin
       if prcode then
          begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end;
        ic := ic + 1; mes(fop)
      end (*genujpxjp*);

      procedure genipj(fop: oprange; fp1, fp2: integer);
      begin
       if prcode then
          begin putic; writeln(prr, mn[fop]:4,fp1:4,' l':8,fp2:4) end;
        ic := ic + 1; mes(fop)
      end (*genujpxjp*);

      procedure gencupent(fop: oprange; fp1,fp2: integer);
      begin
        if prcode then
          begin putic;
            writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4)
          end;
        ic := ic + 1; mes(fop)
      end;

      procedure genlpa(fp1,fp2: integer);
      begin
        if prcode then
          begin putic;
            writeln(prr,mn[68]:4,fp2:4,'l':4,fp1:4)
          end;
        ic := ic + 1; mes(68)
      end (*genlpa*); 

      procedure checkbnds(fsp: stp);
        var lmin,lmax: integer;
      begin
        if fsp <> nil then
          if fsp <> intptr then
            if fsp <> realptr then
              if fsp^.form <= subrange then
                begin
                  getbounds(fsp,lmin,lmax);
                  gen2t(45(*chk*),lmin,lmax,fsp)
                end
      end (*checkbnds*);


      procedure putlabel(labname: integer);
      begin if prcode then writeln(prr, 'l', labname:4)
      end (*putlabel*);

      procedure statement(fsys: setofsys);
        label 1;
        var lcp: ctp; llp: lbp; lp: lsp;
        
        function fndlab(l: boolean): integer;
        var lp: lsp; cnt: integer;
        begin
          lp := labstk; cnt := 0;
          while lp <> nil do begin 
            if (lp^.labval = val.ival) and lp^.labl = l then cnt := cnt+1;
            lp := lp ^.next
          end;
          fndlab := cnt
        end;

        procedure expression(fsys: setofsys); forward;

        procedure selector(fsys: setofsys; fcp: ctp);
        var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer;
        begin
          with fcp^, gattr do
            begin typtr := idtype; kind := varbl;
              case klass of
                vars:
                  if vkind = actual then
                    begin access := drct; vlevel := vlev;
                      dplmt := vaddr
                    end
                  else
                    begin gen2t(54(*lod*),level-vlev,vaddr,nilptr);
                      access := indrct; idplmt := 0
                    end;
                field:
                  with display[disx] do
                    if occur = crec then
                      begin access := drct; vlevel := clev;
                        dplmt := cdspl + fldaddr
                      end
                    else
                      begin
                        if level = 1 then gen1t(39(*ldo*),vdspl,nilptr)
                        else gen2t(54(*lod*),0,vdspl,nilptr);
                        access := indrct; idplmt := fldaddr
                      end;
                func:
                  if pfdeckind = standard then
                    begin error(150); typtr := nil end
                  else
                    begin
                      if pfkind = formal then error(151)
                      else
                        if (pflev+1<>level)or(fprocp<>fcp) then error(177);
                        begin access := drct; vlevel := pflev + 1;
                          dplmt := 0   (*impl. relat. addr. of fct. result*)
                        end
                    end
              end (*case*)
            end (*with*);
          if not (sy in selectsys + fsys) then
            begin error(59); skip(selectsys + fsys) end;
          while sy in selectsys do
            begin
        (*[*) if sy = lbrack then
                begin
                  repeat lattr := gattr;
                    with lattr do
                      if typtr <> nil then
                        if typtr^.form <> arrays then
                          begin error(138); typtr := nil end;
                    loadaddress;
                    insymbol; expression(fsys + [comma,rbrack]);
                    load;
                    if gattr.typtr <> nil then
                      if gattr.typtr^.form<>scalar then error(113)
                      else if not comptypes(gattr.typtr,intptr) then
                             gen0t(58(*ord*),gattr.typtr);
                    if lattr.typtr <> nil then
                      with lattr.typtr^ do
                        begin
                          if comptypes(inxtype,gattr.typtr) then
                            begin
                              if inxtype <> nil then
                                begin getbounds(inxtype,lmin,lmax);
                                  if debug then
                                    gen2t(45(*chk*),lmin,lmax,intptr);
                                  if lmin>0 then gen1t(31(*dec*),lmin,intptr)
                                  else if lmin<0 then
                                    gen1t(34(*inc*),-lmin,intptr);
                                  (*or simply gen1(31,lmin)*)
                                end