(* p5c: pascal to C compiler
 - derived from p5.
 - compiler, not translator

#    // force c preprocessor

Output C source code (gcc) rather than p-code,
 so easily ported,
 generates highly optimised code
 links directly with c libraries
 can make use of existing c tools

*)

{$short-circuit} {gpc short circuit boolean expressions}
(*$t-,d-,v-,l+ *)
{*******************************************************************************
*                                                                              *
*                     Portable Pascal assembler/interpreter                    *
*                     *************************************                    *
*                                                                              *
*                                 Pascal P5                                    *
*                                                                              *
*                                 ETH May 76                                   *
*                                                                              *
* Authors:                                                                     *
*    Urs Ammann                                                                *
*    Kesav Nori                                                                *
*    Christian Jacobi                                                          *
*    K. Jensen                                                                 *
*    N. Wirth                                                                  *
*                                                                              *
*    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                                                       *
*                                                                              *
*    The comments marked with brackets are mine [sam]                          *
*                                                                              *
* Adaption from P5 to P5c by:                                                  *
*                                                                              *
*    Trevor Blight                                                             *
*    trevorbl@users.sourceforge.net                                            *
*                                                                              *
*                                                                              *
*******************************************************************************}

{ output: .lst list file
  prd:    .pas source file
  prc:    .c file
  standard input is not used by this program
}

#include "cdefs.inc.pas"

{$ d+}
program pascalcompiler(output, prd, prc);
{$ d-}

label 99; { terminate immediately }

const
  maxintTarget = CDEF_MAXINT_TARGET;
  ordmaxchar  =      255;        { Characters are 8 bit ISO/IEC 8859-1 }
  ordminchar  =        0;

  setMax      =        255;  { used only when set size unknown at compile time }

   displimit   = 300;
   maxlevel    = 255;
   { strglgth used to define the size of all strings in pcom and pint. With the
     string quanta system, string lengths are effectively unlimited, but there
     it still sets the size of some buffers in pcom. }
   strglgth    = 250;
   { maximum number of digits in real, including sign and exponent }
   digmax      = 250;

   maxids     = 250; { maximum characters in id string (basically, a full line) }
   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 }
   maxErrNr   = 500; { error numbers range from 0 .. 500 }

   { debug flags }

   dodmplex   = false; { dump lexical }
   doprtryc   = false; { dump recycling tracker counts }
   doprtlab   = false; { print labels }
   dodmpdsp   = false; { dump the display }

   { version numbers }

   majorver   = 1; { major version number }
   minorver   = 2; { minor version number }

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

                                                            (*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,beginsy,ifsy,
               casesy,repeatsy,whilesy,forsy,withsy,gotosy,endsy,elsesy,untilsy,
               ofsy,dosy,tosy,downtosy,thensy,nilsy,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);

     { standard identifiers - see procedure stdnames }
     tStdNames = (  stdNfalse,   stdNtrue,

                    stdNinput,   stdNoutput,
                    stdNget,     stdNput,        { standard procedures }
                    stdNreset,   stdNrewrite,
                    stdNread,    stdNwrite,
                    stdNreadln,  stdNwriteln, stdNpage,
                    stdNpack,    stdNunpack,
                    stdNnew,     stdNdispose,

                    stdNtrunc,   stdNround,      { standard functions }
                    stdNabs,     stdNsqr,  stdNodd,
                    stdNord,     stdNchr,
                    stdNpred,    stdNsucc,
                    stdNeof,     stdNeoln,

                    stdNsin,     stdNcos,      { predeclared functions }
                    stdNexp,     stdNsqrt,
                    stdNln,      stdNarctan,

                    stdNmaxint );



     { Here is the variable length string containment to save on space.
       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*)
                                                            (***********)
     cstclass = (reel,strg);
     csp = ^ constant;
     constant = record
                       next: csp; { keep and dispose a list of constants }
                       case cclass: cstclass of
                         reel: (rval: strvsp);
                         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;
     structform = (scalar,subrange,pointer,power,arrays,records,files,
                   tagfld,variant);
     declkind = (standard,declared);
     stp = ^ structure;
     ctp = ^ identifier;

     { this is a type representation }
     structure = record
                   next: stp;                       { next entry link }
                   decChain: stp;                   { chain of declared types }
                   typeName: ctp;                   { id of declared type }
                   { TODO: review these & the dynamics of declaring types }
                   { decState valid iff typeName <> nil }
                   decState    : (notDeclared, forwardDeclared, voidDeclared, isDeclared);
                   isVoidPtr : boolean;
                   checkStruct : boolean;
                   checkPtr: boolean;
                   marked: boolean;                 (*for test phase only*)
                   packing: boolean; { packing status }
                   hasFile: boolean; { contains a file }
                   case form: structform of
                     scalar:   (case scalkind: declkind of
                                  declared: (fconst: ctp);
                                  standard: ());
                     subrange: (rangetype: stp;
                                smin, smax: integer);
                     pointer:  (eltype: stp);
                     power:    (elset: stp; matchpack: boolean);
                     arrays:   (aeltype, inxtype: stp;
                                lowbound, highbound: ctp; { for conformant arrays }
                                slen: integer;            {used only for strings}
                                confFlag: boolean);
                     records:  (fstfld: ctp; { first member or tag or variant }
                                recvar: stp; { pointer to tag & variant part }
                                recyc: stp);
                     files:    (filtype: stp);
                     tagfld:   (tagfieldp: ctp;
                                fstvar: stp); { list of variants }
                     variant:  (nxtvar, { list of all variants in this level }
                                subvar, { child variant }
                                caslst: stp; { list of variants for single case list }
                                vfstfld: ctp; { list of fixed members }
                                varval: integer);
                   end;

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

     idclass = (types,konst,vars,field, boundid, proc,func);
     setofids = set of idclass;
     idkind = (actual,formal);
     idstr = packed array [1..maxids] of char;
     restr = packed array [1..reslen] of char;
     nmstr = packed array [1..digmax] of char;
     csstr = packed array [1..strglgth] of char;
     identifier = record
                   name       : strvsp; llink, rlink: ctp;
                   lev        : levrange; { level is appended to name }
                   idtype     : stp; next: ctp;
                   keep       : boolean; refer: boolean; ignore: boolean;
                   case klass : idclass of
                     types    : ();
                     konst    : (values: valu);
                     vars:  (vkind: idkind; vlev: levrange;
                             threat: boolean; forcnt: integer);

                     boundid: ();  {conformant array bound}

                     field: (varnt: stp; {variant case value, etc}
                             varlb: ctp; {field must match this tag}
                             tagfield: boolean );
                     proc, func:  (pflist: ctp; { param list }
                                   case pfdeckind: declkind of
                                   standard: (key: tStdNames);
                                   declared: (pflev: levrange;
                                              pfname: tStdNames; { for predeclared functions }
                                              asgn,dbg: boolean; { assigned }
                                          case pfkind: idkind of
                                           actual: (forwdecl, externl: boolean);
                                           formal: ())) { ie a parameter }
                   end;


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

                                                            (*expressions*)
                                                            (*************)
     { code tree - expression tree }
     nodeType = (binOpNode,
                 strOpNode,
                 setOpNode,
                 unopNode,
                 pointerNode,
                 constNode,
                 varNode,
                 fParNode,   { function parameter }
                 fBufNode,   { file buffer variable }
                 arrayNode,  { array component }
                 setNode,    { set }
                 fieldNode,  { record member }
                 wfieldNode, { with statement record member }
                 callNode,   { non-standard call }
                 stdNode,    { standard call }
                 funcNode,   { function assign }
                 tmpValNode, { temporary value }
                 tmpSetNode  { temporary value }
                 );

     exprTreePtr = ^exprTree;

      pfParamPtr = ^pfParam;
      pfParam = record
                  next      : pfParamPtr;
                  parAccess : ( valueParam, varParam, funcParam );
                  parExpr   : exprTreePtr;
                  parType   : stp;
                end;

     constElementPtr = ^constElement;
     constElement = record
                      next    : constElementPtr;
                      isRange : boolean;
                      elvalue : integer;
                      hiValue : integer;
                    end;

     varElementPtr = ^varElement;
     varElement = record
                      next    : varElementPtr;
                      isRange : boolean;
                      elvalue : exprTreePtr;
                      hiValue : exprTreePtr;
                    end;

     exprTree = record
                   case n: nodeType of
                     binOpNode : ( binOpKind: operator;
                                   binOpType : stp;
                                   left : exprTreePtr;
                                   right: exprTreePtr;
                                 );
                     strOpNode : ( strOpKind : operator;
                                   slen  : integer;
                                   strLeft : exprTreePtr;
                                   strRight: exprTreePtr;
                                   lvar, rvar: boolean;
                                  );
                     setOpNode : ( setOpKind : operator;
                                   setLeft : exprTreePtr;
                                   setRight: exprTreePtr;
                                   resNr    : integer; { result is in sN }
                                   resHi, resLo  : integer; { result bounds }
                                   locked   : boolean; {xxx review this}
                                  );
                     unopNode  : ( unOpKind : (minusOp, minusOpi, notOp, parenOp);
                                   operand   : exprTreePtr );
                     constNode : ( nodeCval: valu;
                                   constType: stp;);
                     varNode   : ( nodeVar : ctp;
                                   isVar   : boolean );
                     fBufNode  : ( nodefBuf: ctp;
                                   fBufType: stp;
                                   fbParent: exprTreePtr;
                                   lvalue  : boolean);
                     arrayNode  : ( arrayType : stp;
                                    index: exprTreePtr;
                                    aparent: exprTreePtr;
                                  );
                      setNode   : ( varList: varElementPtr;
                                    constList: constElementPtr;
                                    listLo, listHi: integer;
                                    sparent: exprTreePtr;
                                    invert: boolean;
                                    newList: boolean;
                                    seltype: stp;
                                  );
                     pointerNode  : ( ptrType: stp;
                                      pparent  : exprTreePtr; );
                      fieldNode  : ( fieldName  : ctp;
                                     fParent   : exprTreePtr; );
                      wfieldNode  : ( wfieldName  : ctp;
                                     fLevel   : disprange; );
                      stdNode    : ( key: tStdNames;
                                    argType: stp;
                                    arg: exprTreePtr;
                                   );
                     callNode   : ( nodeFunc: ctp;
                                    firstPar: pfParamPtr;    { list of args }
                                  );
                     fParNode   : ( fPar : ctp );
                     funcNode   : ( lev :  levrange;
                                    fdbg :  boolean; );
                     tmpValNode : (  regNr:  integer; );
                     tmpSetNode : (  SetNr   :  integer;
                                     pSelFlag: boolean;);
                   end;

     { see Pemberton, Ch 3 }
     attrkind = (cst,        { expression is constant }
                 varbl,      { expression is a variable }
                 expr);      { expression is compilcated }
     vaccess = (drct,        {  }
                indrct,      {  }
                inxd);       { unused }

     attr = record
              typtr: stp;
              codeTree : exprTreePtr;
              case kind: attrkind of
                cst:   (cval: valu);
                varbl: (packing: boolean; packcom: boolean;
                        tagfieldg: boolean;
                        ptrref: boolean;
                        case access: vaccess of
                          drct: (vlevel: levrange);
                          indrct: ();
                        inxd: ()); { unused }
                expr: ( )
              end;

                                                                 (*labels*)
                                                                 (********)
     lbp = ^ labl;
     labl = record { 'goto' label }
                   nextlab: lbp;     { next list link }
                   defined: boolean; { label defining point was seen }
                   labval,           { numeric value of label }
                   labname: integer; { internal sequental name of label }
                   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 }
                   bact:    boolean; { containing block is active }
                   refer:   boolean  { was referred to }
            end;

     { external file tracking entries }
     extfilep = ^filerec;
     filerec = record
                 argNr    : integer;	{ position in header }
                 filename : idstr;	{ filename in header }
                 nextfile : extfilep;
               end;

     { case statement tracking entries }
     cip = ^caseinfo;
     caseinfo = record next: cip;
                  cslab: integer
                end;

     errNumType = -10..maxErrNr;  { numbers < 0 are warnings }

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

var
    prd,                            { pascal source file }
    prc: text;                      { output c 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*)
    linecount: integer;


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

    dp,                             (*declaration part*)
    list,prtables,
    chkvar: boolean;                (*output options for
                                      -- source program listing
                                      -- displaying ident and struct tables
                                      -- procedure option*)
    debug   : boolean;              { -- Debug checks }
    memDebug: boolean;              { -- Debug memory }
    lnflag  : boolean;              { -- write line numbers }
    algSet  : boolean;              { -- compare sets analytically }
    chkref  : boolean;              { -- Reference checks }


                                    (*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*)

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

    level: levrange;                (*current static 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*)
          fconst: csp; fstruct: stp;
          packing: boolean;         { used for with derived from packed }
          packcom: boolean;         { used for with derived from packed }
          ptrref: boolean;          { used for with derived from pointer }
          case occur: where of      (*   constant address*)
            crec: (clev: levrange); (*=vrec:   id is field id in record with*)
            vrec: ();
            blck: (bname: ctp;      { block id }
                   hasFile: boolean);  { this level contains a file }
            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: ErrNumType
               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 [tStdNames] of restr;
    ordint: array [char] of integer;

    intlabel,mxint10: integer;
    inputhdf: boolean; { 'input' appears in header files }
    outputhdf: boolean; { 'output' appears in header files }
    errtbl: set of ErrNumType; { error occurrence tracking }
    toterr: integer; { total errors in program }
    totwarn: integer; { total warnings in program }
    warnings: boolean; { enable warnings }

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

    f: boolean; { flag for if error number list entries were printed }
    erridx: ErrNumType; { index for error number tracking array }

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

                           { type change }

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

    { TODO: remove these, p5c can write pointers directly }

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

    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;

   { determine if fsp points to a conformant array. }
   function isConfArray(fsp: stp): boolean;
   begin
     isConfArray := false;
     if fsp <> nil then
       if fsp^.form = arrays then
         isConfArray := fsp^.confFlag
   end { isConfArray };


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

                           { recycling controls }

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

  { get string quanta }
  procedure getstr(var p: strvsp);
  begin
     new(p); { get new entry }
     strcnt := strcnt+1 { count }
  end;

  { recycle string quanta 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;

  { get label entry }
  procedure getlab(var p: lbp);
  begin
     new(p); { get new entry }
     lbpcnt := lbpcnt+1 { add to count }
  end;

  { recycle label entry }
  procedure putlab(p: lbp);
  begin
     dispose(p); { release entry }
     lbpcnt := lbpcnt-1 { remove from count }
  end;

  { push constant entry to list }
  procedure pshcst(p: csp);
  begin
     { push to constant list }
     p^.next := display[top].fconst;
     display[top].fconst := p;
     cspcnt := cspcnt+1 { count entries }
  end;

  { recycle constant entry }
  procedure putcst(p: csp);
  begin
     { recycle string if present }
     if p^.cclass = strg then putstrs(p^.sval)
     else if p^.cclass = reel then putstrs(p^.rval);
     dispose(p); { release entry }
     cspcnt := cspcnt-1 { remove from count }
  end;

  { push structure entry to list }
  procedure pshstc(p: stp);
  begin
     { push to structures list }
     p^.next := display[top].fstruct;
     display[top].fstruct := p;
     stpcnt := stpcnt+1 { count entries }
  end;

  { recycle structure entry }
  procedure putstc(p: stp);
  begin
     dispose(p); { release entry }
     stpcnt := stpcnt-1
  end;

  { initialize and register identifier entry }
  procedure ininam(p: ctp);
  begin
     ctpcnt := ctpcnt+1; { count entry }
     p^.lev := level;    { store level }
     p^.keep := false; { clear keepme flag }
     p^.ignore := false; { clear ignore flag }
     p^.refer := false { clear referred flag }
  end;

  procedure putConfArray( p: stp ); forward;

  { recycle identifier entry }
  procedure putnam(p: ctp);
  var p1, p2: ctp;
  begin
    if (p^.klass = proc) or (p^.klass = func) then begin

      p1 := p^.pflist;
      while p1 <> nil do begin
        { scavenge the parameter list }
        p2 := p1^.next;
        { dispose only last param type in group }
        if isConfArray( p1^.idtype ) then
          if (p2 = nil) or
            (p1^.idtype <> p2^.idtype) then
            putConfArray( p1^.idtype );
        putnam(p1); { release }
        p1 := p2;
      end; {while}
    end; { if }
    putstrs(p^.name); { release name string }
    dispose(p); { release entry }
    ctpcnt := ctpcnt-1 { remove from count }
  end; { putnam }

  { recycle conformant array entry }
  procedure putConfArray;
  begin
    with p^ do begin
      if lowbound <> nil then putnam(lowbound);
      if highbound <> nil then putnam(highbound);
      if isConfArray( aelType ) then
        putConfArray( aelType );
    end;
    putstc( p );
  end; { putConfArray }

  { recycle identifier tree }
  procedure putnams(p: ctp);
  begin
      if p <> nil then begin
      putnams(p^.llink); { release left }
      putnams(p^.rlink); { release right }
      { "keep" means it is a parameter and stays with its procedure or
        function entry. }
      if not p^.keep then putnam(p) { release the id entry }
    end
  end; { putnams }

  { scrub display level }
  procedure putdsp(l: disprange);
     var llp: lbp; lvp: csp; lsp: stp;
     { release substructure }
     procedure putsub(p: stp);
        var p1: stp;
     begin
        { clear record recycle list if record }
        if p^.form = records then begin
           { clear structure list }
           while p^.recyc <> nil do begin
              { remove top of list }
              p1 := p^.recyc; p^.recyc := p1^.next;
              putsub(p1) { release that element }
           end;
           putnams(p^.fstfld) { clear id list }
        end else if p^.form = tagfld then begin
              if p^.tagfieldp <> nil then
                 { recycle anonymous tag fields }
                 if p^.tagfieldp^.name = nil then putnam(p^.tagfieldp)
        end;
        putstc(p) { release head entry }
     end;
  begin { putdsp }
    putnams(display[l].fname); { dispose of identifier tree }
    { dispose of label list }
    while display[l].flabel <> nil do begin
      llp := display[l].flabel; display[l].flabel := llp^.nextlab; putlab(llp)
    end;
    { dispose of constant list }
    while display[l].fconst <> nil do begin
      lvp := display[l].fconst; display[l].fconst := lvp^.next; putcst(lvp)
    end;
    { dispose of structure list }
    while display[l].fstruct <> nil do begin
      { remove top from list }
      lsp := display[l].fstruct; display[l].fstruct := lsp^.next;
      if not isConfArray(lsp) then putsub(lsp)
    end
  end; { putdsp }

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

  { get external file entry }
  procedure getfil(var p: extfilep);
  begin
     new(p); { get new entry }
     filcnt := filcnt+1 { count entry }
  end;

  { recycle external file entry }
  procedure putfil(p: extfilep);
  begin
     dispose(p); { release entry }
     filcnt := filcnt-1 { count entry }
  end;

  { get case tracking entry }
  procedure getcas(var p: cip);
  begin
     new(p); { get new entry }
     cipcnt := cipcnt+1 { count entry }
  end;

  { recycle case tracking entry }
  procedure putcas(p: cip);
  begin
     dispose(p); { release entry }
     cipcnt := cipcnt-1 { count entry }
  end;

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

                { character and string quanta functions }

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

  { 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 };

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

  { write variable length id string to output }
  procedure writev(var f: text; 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(f, c); fl := fl-1;
      if i > varsqt then begin s := s^.next; i := 1 end
    end
  end;

  { escape c special chars '"' & '\' }
  procedure writeve(var f: text; 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;
      if (c = '"') or (c='\') then
        write(f,'\' );
      write(f, c);
      fl := fl-1;
      if i > varsqt then begin s := s^.next; i := 1 end
    end
  end;

  { find padded length of variable length id string }
  function lenpv(s: strvsp): integer;
  var i, l, lc: integer;
  begin l := 1; lc := 0;
    while s <> nil do begin
      for i := 1 to varsqt do begin
        if s^.str[i] <> ' ' then lc := l;
        l := l+1; { count characters }
      end;
      s := s^.next
    end;
    lenpv := lc
  end;


 { assign fixed to variable length string, including allocation }
  procedure strassvf(var a: strvsp;
                         b: packed array[lo..hi: integer] of char);
  var i, j, l: integer; p, lp: strvsp;
  begin l := hi; p := nil; a := nil; j := lo;
    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
        getstr(p); p^.next := nil; 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 variable length string to fixed identifier }
  procedure strassfv(var a: idstr; b: strvsp);
  var i, j: integer;
  begin for i := 1 to maxids do a[i] := ' '; i := 1;
     while b <> nil do begin
        for j := 1 to varsqt do begin a[i] := b^.str[j]; i := i+1 end;
        b := b^.next
     end
  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;
    i := 1;
    while m and (i <= maxids) do begin
      if a <> nil then begin
        c := lcase(a^.str[j]);
        j := j+1;
        if j > varsqt then begin a := a^.next; j := 1 end;
        if c <> lcase(b[i]) then
          m := false;
      end
      else begin
        if b[i] <> ' ' then
          m := false;
        i := maxids; {force end of loop}
      end;
      i := i+1;
    end; {while}
   strequvf := m
  end;

  { compare variable length id string to fixed, a < b }
  {NOTE: f is uninitialised iff strings are maxids length, and equal
         but pcom calls this function only when the strings are unequal}
  function strltnvf(a: strvsp; var b: idstr): boolean;
  var i, j, f: integer; c: char;
  begin
    i := 1; j := 1;
    while i < maxids do begin
      c := ' '; if a <> nil then begin c := lcase(a^.str[j]); j := j+1 end;
      if 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;

  { get character from variable length string }
  function strchr(a: strvsp; x: integer): char;
  var c: char; i: integer; q: integer;
  begin
     c := ' '; i := 1; q := 1;
     while i < x do begin
        if q >= varsqt then begin q := 1; if a <> nil then a := a^.next end
        else q := q+1;
        i := i+1
     end;
     if a <> nil then c := a^.str[q];
     strchr := c
   end;

  { put character to variable length string }
  procedure strchrass(var a: strvsp; x: integer; c: char);
  var i: integer; q: integer; p, l: strvsp;

  { get a string quantum for p }
  procedure getsqt;
  var y: integer;
  begin
     if p = nil then begin
       getstr(p);
       for y := 1 to varsqt do
         p^.str[y] := ' ';
        p^.next := nil;
       if a = nil then
         a := p
       else begin
         l^.next := p
       end;
     end
  end; { getsqt }

  begin
    i := 1; q := 1; p := a; l := nil;
    getsqt;
    while i < x do begin
      if q >= varsqt then begin
        q := 1; l := p; p := p^.next;
        getsqt;
      end
      else q := q+1;
      i := i+1
    end;
    p^.str[q] := c;
  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(output, 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 if display[i].fname <> nil then begin

       writeln('level ', i:1);
       writeln;
       prtlnk(display[i].fname, 0);
       writeln

    end;
    writeln;
  end;

  procedure endofline;
    var lastpos,freepos,currpos,currnmr,f,k: integer;
  begin
    if list then writeln(output);
    if errinx > 0 then begin  (*output error messages*)
      write(output, linecount:6, ' **** ');
      lastpos := -1; 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 < 0 then begin { warning if -ve }
          write(output, 'W' ); freepos := freepos + 1;
          currnmr := -currnmr;
        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; { for }
      writeln(output); errinx := 0
    end;
    linecount := linecount + 1;
    if list and (not eof(prd)) then begin
      write(output, linecount:6, '       ')
    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'} 'identifier or case expected');
    20:  write(''','' expected');
    21:  write('''..'' expected');
    22:  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'); {unused}
    57:  write('''file'' expected'); {unused}
    58:  write('Error in factor');
    59:  write('Error in variable');

    101: write('Identifier declared previously');
    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');
    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'); {unused}
    119: write('Forward declared; repetition of parameter list not allowed');
    120: write('Function result type must be scalar, subrange or pointer');
    121: write('value parameter that is or contains a file not allowed');
    122: write('Forward declared function; repetition of result type not allowed');
    123: write('Missing result type in function declaration');

     { TODO: split error 125 into several messages that give better info }
    125: write('Error in type of standard function parameter');
    126: write('Number of parameters does not agree with declaration');
    127: write('All parameters in a group must have the same type');
    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('''<'' and ''>'' not allowed for sets');
    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 ordinal');
    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('Loop control variable type must be ordinal');
    144: write('Illegal type of expression');
    145: write('Type conflict');
    146: write('Assignment of files not allowed');
    147: write('Incorrect type of case constant');
    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'); {unused}
    154: write('Actual parameter must be a variable');
    155: write('Control variable must not be declared on intermediate');
    156: write('case value defined again');
    157: write('Too many cases in case statement'); {unused}
    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'); {unused, see 158}
    164: write('Substitution of standard proc/func not allowed'); {unused}
    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'); {unused}
    171: write('Standard file was redeclared'); {unused}
    172: write('Undeclared external file'); {unused}
    173: write('Fortran procedure or function expected'); {unused}
    174: write('Pascal procedure or function expected'); {unused}
    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'); {unused}
    178: write('Multidefined record variant');
    179: write('X-opt of actual proc/func does not match formal declaration'); {unused}
    180: write('Control variable must not be formal'); {unused}
    181: write('Constant part of address out of ranqe'); {unused}
    182: write('identifier too long');
    183: write('For index variable must be local to this block');
    184: write('Interprocedure goto does not reference outer block of destination');
    {TODO: merge errors 185,186,187 & 188?}
    185: write('Goto references deeper nested statement');
    186: write('Goto references label within a nested statement');
    187: write('Goto references label in different nested statement');
    188: write('Label referenced by goto in different nested statement'); {unused}
    189: write('Parameter lists of formal and actual parameters not congruous');
    190: write('identifier used in this scope before it has been declared'); {unused}
    191: write('File component may not contain other files');
    192: write('Assignment to function that is not active');
    193: write('Function does not assign to result');
    194: write('Exponent too large');
    195: write('For loop index is threatened');
    196: write('Label must be in range 0..9999');
    197: write('Var parameter cannot be packed');
    198: write('Var parameter cannot be a tagfield');
    199: write('Var parameter must be same type');

    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('constant integer expression overflows');
    205: write('Zero string not allowed');
    206: write('number too long');
    207: write('real constant exceeds ranqe'); {unused}
    208: write('Fixed point format allowed for reals only');
    209: write('Fixed point precision must be >= 0');

    220: write('only the last dimension may be packed');
    221: write('type-identifier or conformant-array schema expected');
    222: write('bound-identifier expected');
    223: write('ordinal-type identifier expected');
    224: write('cannot assign new value to conformant array bounds');

    250: write('Too many nested scopes of identifiers');
    251: write('Too many nested procedures and/or functions');
    252: write('forward routine cannot be external');
    253: write('Procedure too long'); {unused}
    254: write('Too many long constants in this procedure'); {unused}
    255: write('Too many errors on this source line'); {unused}
    256: write('external reference must be at top level'); {unused}
    257: write('Too many externals'); {unused}
    258: write('Too many local files'); {unused}
    259: write('Expression too complicated'); {unused}
    260: write('Too many exit labels'); {unused}

    300: write('Division by zero');
    301: write('No case provided for this value'); {unused}
    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'); {unused}
    399: write('Feature not implemented');

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

    { --- warnings --- }
    -1: write('unknown option');
    -2: write('warning: integer set bounds limited to ', -setMax:1, '..', setMax:1 );
    -3: write('warning: comparing sets analytically' );
    -4: write('unpacked array expected');
    -5: write('packed array expected');
    end
  end;

  procedure error(ferrnr: ErrNumType);
  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);

    }

    if (ferrnr >= 0) or warnings then begin
      errtbl := errtbl + [ferrnr]; { 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;
      if ferrnr >= 0 then
        toterr := toterr+1
      else
        totwarn := totwarn + 1;
    end; { if }
  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;
    var i,k: integer;
        digit: nmstr; { temp holding for digit string }
        rvalb: nmstr; { temp holding for real string }
        string: csstr;
        lvp: csp; test, ferr: boolean;
        ev: integer;

    procedure nextch;
    begin
      if eol then begin
        endofline;
        { TODO: skip blanks at start of line - see Pemberton, Ch1, #3 }
      end;
      if not eof(prd) then begin
        eol := eoln(prd);
        read(prd,ch);
        if list then write(output,ch);
        chcnt := chcnt + 1
      end
      else begin
        { insymbol reads one char ahead, so could get here even if we
        have reached the end of the program.
        OTOH, if test is set, insymbol is still looking for another symbol,
        so the program has ended earlier than expected }
        if test then begin
          writeln('   **** eof encountered' );
          test := false;
        end;
        ch := ' ';
      end
    end; { nextch }


  procedure comment;
  var
    ch1 : char;
    iscmte: boolean;
    procedure switch(var opt: boolean );
    begin
      nextch;
      if ch in ['+','-'] then begin
        opt := ch = '+';
        nextch;
      end
    end; { switch() }
  begin
    nextch;
    iscmte := false;

    if ch = '@' then begin
      nextch;
      if ch = '@' then begin
        nextch;
        writeln(prc);
        repeat
          if ch <> '@' then
            write(prc, ch)
          else begin
            nextch;
            if ch <> '@' then
              write(prc, '@', ch)
            else begin
              nextch;
              while ch = '@' do begin
                write(prc, '@');
                nextch;
              end;
              if ch = '}' then
                iscmte := true
              else if ch <> '*' then
                write(prc, '@@', ch)
              else begin
                nextch;
                if ch <> ')' then
                  write(prc, '@@*', ch)
                else
                  iscmte := true;
              end;
            end;
          end;
          nextch;
          if eol then writeln(prc);
        until iscmte or eof(prd);
      end;
    end
  else if ch = '$' then begin {options}
    repeat
      nextch;
      ch1 := lcase(ch);
      if ch1 = 'l' then begin
        switch(list);
        if not list then writeln(output)
      end
      else if ch1 = 'w' then
        switch(warnings)
      else if ch1 = 'd' then begin
        switch(debug);
      end
      else if ch1 = 'n' then
      switch(lnflag)
      else if ch1 = 't' then
        switch(prtables)
      else if ch1 = 'v' then
        switch(chkvar)
      else if ch1 = 'r' then
        switch(chkref)
      else if ch1 = 'z' then begin
        switch(algSet);
      end
      else begin
        error(-1);          { unknown option }
        { skip all likely option chars }
        while ch in ['a'..'z','A'..'Z','+','-','0'..'9','_'] do
          nextch;
      end;
    until ch <> ',';
  end;

  if not iscmte then begin
    repeat
      while (ch <> '}') and (ch <> '*') and not eof(prd) do nextch;
      iscmte := ch = '}'; nextch
    until iscmte or (ch = ')') or eof(prd);
    if not iscmte then nextch;
  end;

  end; { comment }

  begin (*insymbol*)
  1: { goto here after comment }

    { Skip both spaces and controls. This allows arbitrary formatting characters
      in the source. }
    repeat
      test := true;  { test means "keep looking" }
      while (ch <= ' ') and not eol do
        nextch; { skip spaces }

      { found a non-blank char or eol or eof }
      test := eol;
      if test then begin
        nextch;
        { at the start of a line - look for cpp line control,
          get line number and copy whole line to prc }
        if ch = '#' then begin
          nextch;
          while (ch <= ' ') and not eol do nextch;
          if lnflag then write(prc, '#line ' );
          k := 0;
          while chartp[ch] = number do begin
            k := 10*k + ord(ch) - ord('0');
            if lnflag then write(prc, ch);
            nextch;
          end;
          if k > 0 then
            linecount := k-1; { this linecount value is for the following line }
          k := 2;
          while not eol do begin
            if lnflag and (k>0) then write(prc, ch);
            if ch = '"' then k := k-1;
            nextch;
          end;
          if lnflag then writeln(prc);
        end;
      end;
    until not test; { ie until found something, or eof }

    case chartp[ch] of
      illegal : begin
        sy := othersy; op := noop;
        {error(6);} nextch
      end;

      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 not (chartp[ch] in [letter, number]);
          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] end;
        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 (prd^ <> '.') and (prd^ <> ')')) or
             (ch in ['E','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 in ['E','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 begin
                ev := 0; ferr := true;
                repeat
                  k := k+1;
                  if k <= digmax then begin
                    digit[k] := ch;
                    i := ordint[ch];
                  end;
                  nextch;
                  if ferr then begin
                    if (ev < mxint10)
                      or ((ev = mxint10) and (10*ev <= maxint - i))
                    then
                      ev := ev*10 + i
                    else begin error(194); ferr := false end
                  end
                until chartp[ch] <> number
              end
            end;
            new(lvp,reel); pshcst(lvp); sy:= realconst;
            lvp^.cclass := reel;
            with lvp^ do begin
              for i := 1 to digmax do rvalb[i] := ' ';
              if k <= digmax then
                for i := 2 to k + 1 do rvalb[i] := digit[i-1]
              else begin
                error(206);
                rvalb[2] := '0'; rvalb[3] := '.'; rvalb[4] := '0'
              end;
              { place buffered real string in constant }
              strassvf(rval, rvalb)
            end;
            val.valp := lvp
          end
          else begin
            if i > digmax then begin error(206); val.ival := 0 end
            else
              with val do begin
                ival := 0;
                for k := 1 to i do begin
                  if (ival < mxint10) or
                    (ival = mxint10) and (ordint[digit[k]] <= maxint mod 10)
                  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;
          for i := 1 to strglgth do string[i] := ' ';
          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 <> '''';
          if lgth <= strglgth then begin
            string[lgth] := ' '; { get rid of trailing quote }
            lgth := lgth - 1;   (*now lgth = nr of chars in string*)
          end;
          if lgth = 1 then val.ival := ord(string[1])
          else
            begin
              if lgth = 0 then error(205);
              new(lvp,strg); pshcst(lvp);
              lvp^.cclass:=strg;
              if lgth > strglgth then
                begin error(399); lgth := strglgth end;
              with lvp^ do
                begin slgth := lgth; strassvf(sval, string) 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 comment; goto 1; end
         else if ch = '.' then begin sy := lbrack; nextch end
         else sy := lparent;
         op := noop
       end;
      chlcmt:
       begin comment; goto 1 end;
      special:
        begin sy := ssy[ch]; op := sop[ch];
          nextch
        end;
      chspace: sy := othersy
    end; (*case*)

    if dodmplex then begin {  lexical dump }

      writeln;
      write('symbol: ');
      case sy of
         ident:       write('ident: ', id:10);
         intconst:    write('int const: ', val.ival:1);
         realconst:   begin write('real const: ');
                            writev(output, val.valp^.rval, 9) end;
         stringconst: begin write('string const: ''');
                            writev(output, val.valp^.sval, val.valp^.slgth);
                            write('''') end;
         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');
         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

  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;
        with lcp^ do begin
          if strequvv(name, fcp^.name) then begin
            (*name conflict, follow right link*)
            if not ignore then begin
              error(101);
              ignore := true
            end;
            lcp := rlink;
            lleft := false
          end
        else if strltnvv(name, fcp^.name) then
        begin lcp := rlink; lleft := false end
        else begin lcp := llink; lleft := true end
        end; {with}
      until lcp = nil;
      if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
    end;
    fcp^.llink := nil; fcp^.rlink := nil
  end (*enterid*) ;


#if 1
procedure writeId( p : ctp );
var
   verbatim : boolean;
begin
   verbatim := false;
   if p = nil then
     write(prc, '>>> name not found')
   else
     with p^ do begin
       writev( prc, name, lenpv(name) );
       if (klass = func) or  (klass = proc) then
         if pfdeckind = declared then
            if pfkind = actual then
               verbatim := externl;        {so dont append _n }
       if not verbatim then
         write( prc, '_', lev:1 );
     end;
end;

#else
  procedure writeId( p : ctp );
var
   verbatim : boolean;
  c         : char;
begin
   verbatim := false;
   if p = nil then
     write(prc, '>>> name not found')
   else
     with p^ do begin
       if (klass = func) or  (klass = proc) then
         if pfdeckind = declared then
            if pfkind = actual then
               verbatim := externl;        {so dont lower case }
       if verbatim or (name = nil) then
         writev( prc, name, lenpv(name) )
       else begin
         c := name^.str[1];
         if c in ['a'..'z'] then
           {uppercase initial char to prevent clash with c keywords}
           name^.str[1] := chr(ord(c) + ord('A') - ord('a'));
         writev( prc, name, lenpv(name) );
         name^.str[1] := c;
       end;
     end;
end;
#endif

  procedure searchsection(fcp: ctp; var fcp1: ctp);
    (*to find record fields and forward declared procedure id's
     --> procedure proceduredeclaration
     --> procedure selector*)
     label 1;
  begin
    while fcp <> nil do
      with fcp^ do begin
        if strequvf(name, id) then begin
          if ignore then fcp := rlink
          else goto 1
        end
      else if strltnvf(name, id) then fcp := rlink
      else fcp := llink;
      end; {with}
1:  fcp1 := fcp
  end (*searchsection*) ;

  { search id, no error, named
    fidcls - want id in this set of classes
    fcp    - id if found in correct class, nil if no id found
    mm     - true if an id found, but wrong class
    NB: id of wrong class could be found which hides an id of the correct class
        in this case, both mm is set and fcp is non-nil
  }
  procedure searchidnenm(fidcls: setofids; var fcp: ctp; var mm: boolean);
    label 1;
    var lcp: ctp;
        disxl: disprange;
  begin
    mm := false;
    for disxl := top downto 0 do begin
      lcp := display[disxl].fname;
      while lcp <> nil do begin
        with lcp^ do begin
          if strequvf(name, id) then begin
            if ignore then
              lcp := rlink
            else if klass in fidcls then begin
              disx := disxl;
              goto 1
            end
            else begin
              mm := true;
              lcp := rlink
            end {if}
          end
          else if strltnvf(name, id) then
            lcp := rlink
          else lcp := llink
        end; {with}
      end; {while}
    end; {for}
    disx := 0;
    lcp := nil; { make sure this is not found }
1:  fcp := lcp
  end (*searchidnenm()*) ;

  procedure searchidne(fidcls: setofids; var fcp: ctp);
    var mm: boolean;
  begin
    searchidnenm(fidcls, fcp, mm);
    if mm then error(103)
  end (*searchidne*) ;

  procedure searchid(fidcls: setofids; var fcp: ctp);
    var lcp: ctp;
        mm: boolean;
  begin
    searchidnenm(fidcls, lcp, mm); { perform no error search }
    if lcp <> nil then begin
      lcp^.refer := true;  { found }
    end
    else begin
      (*search not successful
       --> procedure simpletype*)
      if mm then error(103) else 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;
  fcp := lcp
  end (*searchid*) ;


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


procedure checkbounds(fsp : stp; val: integer; n: integer);
var
  lo, hi        : integer;
begin
  getbounds( fsp, lo, hi );
  if (hi > lo) and ((val < lo) or (val > hi)) then
    error(n);
end; { checkbounds }


  procedure printtables(fb: boolean);
    (*print data structure and name table*)

  const intdig = 20;       { number of decimal digits in integer }

  var i, lim: disprange;

    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('S: ', stptoint(fp):intdig,' ');
              case form of
              scalar:   begin write(output,'scalar':intdig, ' ');
                          if scalkind = standard then
                            write(output,'standard':intdig)
                          else write(output,'declared':intdig,' ',ctptoint(fconst):intdig);
                          writeln(output)
                        end;
              subrange: begin
                          write(output,'subrange':intdig,' ',stptoint(rangetype):intdig, ' ');
                          if rangetype <> realptr then
                            write(output,smin:intdig, ' ', smax:intdig)
                          else
                            write(output, '<<real range type not supported>>' );
                          writeln(output); followstp(rangetype);
                        end;
              pointer:  writeln(output,'pointer':intdig,' ',stptoint(eltype):intdig);
              power:    begin writeln(output,'set':intdig,' ',stptoint(elset):intdig);
                          followstp(elset)
                        end;
              arrays:   begin
                          writeln(output,'array':intdig,' ',stptoint(aeltype):intdig,' ',
                            stptoint(inxtype):intdig);
                          followstp(aeltype); followstp(inxtype)
                        end;
              records:  begin
                          writeln(output,'record':intdig,' ',ctptoint(fstfld):intdig,' ',
                            stptoint(recvar):intdig); followctp(fstfld);
                          followstp(recvar)
                        end;
              files:    begin writeln(output,'file':intdig,' ',stptoint(filtype):intdig);
                          followstp(filtype)
                        end;
              tagfld:   begin writeln(output,'tagfld':intdig,' ',ctptoint(tagfieldp):intdig,
                            ' ',stptoint(fstvar):intdig);
                          followstp(fstvar)
                        end;
              variant:  begin writeln(output,'variant':intdig,' ',stptoint(nxtvar):intdig,
                            ' ',stptoint(subvar):intdig,varval);
                          followstp(nxtvar); followstp(subvar)
                        end
              end (*case*)
            end (*if marked*)
    end (*followstp*);

    procedure followctp;
    begin
      if fp <> nil then
        with fp^ do
          begin write('C: ', ctptoint(fp):intdig,' ');
                writev(output, name, intdig); write(' ', ctptoint(llink):intdig,
            ' ',ctptoint(rlink):intdig,' ',stptoint(idtype):intdig, ' ');
            case klass of
              types: write(output,'type':intdig);
              konst: begin write(output,'constant':intdig,' ',ctptoint(next):intdig, ' ');
                       if idtype <> nil then
                         if idtype = realptr then
                           begin
                             if values.valp <> nil then begin
                               writev(output, values.valp^.rval, 9)
                             end
                           end
                         else
                           if idtype^.form = arrays then  (*stringconst*)
                             begin
                               if values.valp <> nil then
                                 begin
                                   with values.valp^ do
                                     writev(output, sval, slgth)
                                 end
                             end
                           else write(output,values.ival:intdig)
                     end;
              vars:  begin write(output,'variable':intdig, ' ');
                       if vkind = actual then write(output,'actual':intdig)
                       else write(output,'formal':intdig);
                       write(output,' ',ctptoint(next):intdig,' ', vlev:intdig);
                     end;
              field: write(output,'field':intdig,' ',ctptoint(next):intdig);
              proc,
              func:  begin
                       if klass = proc then write(output,'procedure':intdig, ' ')
                       else write(output,'function':intdig, ' ');
                       if pfdeckind = standard then
                         write(output,'standard':intdig, '-', ord(key):intdig)
                       else
                         begin write(output,'declared':intdig,'-',ctptoint(next):intdig, '-');
                           write(output,pflev:intdig,' ',ord(pfname):intdig, ' ');
                           if pfkind = actual then
                             begin write(output,'actual':intdig, ' ');
                               if forwdecl then write(output,'forward':intdig, ' ')
                               else write(output,'notforward':intdig, ' ');
                               if externl then write(output,'extern':intdig)
                               else write(output,'not extern':intdig);
                             end
                           else write(output,'formal':intdig)
                         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);
    writeln('C: ', 'Entry #':intdig, ' ', 'Id':intdig, ' ', 'llink':intdig, ' ',
            'rlink':intdig, ' ', 'Typ':intdig, ' ', 'Class':intdig);
    writeln('S: ', 'Entry #':intdig, ' ', 'Size':intdig, ' ', 'Form ':intdig);
    writeln('===============================================================');
    marker;
    for i := top downto lim do
      followctp(display[i].fname);
    writeln(output);
    if not eol then write(output,' ':chcnt+16)
  end (*printtables*);

  procedure chkrefs(p: ctp; var w: boolean);
  begin
    if chkref then begin
      if p <> nil then begin
        with p^ do begin
          chkrefs(llink, w); { check left }
          chkrefs(rlink, w); { check right }
          if not refer and not ignore then begin
            if not w then writeln;
            writev(output, name, 10); writeln(' unreferenced'); w := true
          end
        end {with}
      end
    end
  end;


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

  procedure searchlabel(var llp: lbp; level: disprange);
  var fllp: lbp; { found label entry }
  begin
    fllp := nil; { set no label found }
    llp := display[level].flabel; { index top of label list }
    while llp <> nil do begin { traverse }
      if llp^.labval = val.ival then begin { found }
        fllp := llp; { set entry found }
        llp := nil { stop }
      end else llp := llp^.nextlab { next in list }
    end;
    llp := fllp { return found entry or nil }
  end;

  procedure newlabel(var llp: lbp);
  begin
    with display[top] do
      begin getlab(llp);
        with llp^ do
          begin labval := val.ival;
            defined := false; nextlab := flabel; genlabel(labname);
            vlevel := level; slevel := 0; ipcref := false; minlvl := maxint;
            bact := false; refer := false
          end;
        flabel := llp
      end
  end;

  procedure prtlabels;
  var llp: lbp; { found label entry }
  begin
    writeln;
    writeln('Labels: ');
    writeln;
    llp := display[level].flabel; { index top of label list }
    while llp <> nil do with llp^ do begin { traverse }
      writeln('label: ', labval:1, ' defined: ', defined,
              ' internal: ', labname:1, ' vlevel: ', vlevel:1,
              ' slevel: ', slevel:1, ' ipcref: ', ipcref:1,
              ' minlvl: ', minlvl:1);
      writeln('   bact: ', bact);
      llp := llp^.nextlab { next in list }
    end
  end;

  { for main program, fsy = period, fprocp = nil }
  procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
  type
    fileListItemPtr =  ^fileListItem;
    fileListItem  = record
                      next    : fileListItemPtr;
                      fileVar : ctp;
                    end;
    var stalvl: integer; { statement nesting level }
        lforwcnt: integer;
        fileList : fileListItemPtr;   { linked list of files in this block }

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


    procedure mkStrConst(var lsp : stp; len:integer);
    begin
      new(lsp,arrays); pshstc(lsp);
      with lsp^ do begin
        typeName := nil; hasFile := false;
        form:=arrays;
        aeltype := charptr;
        packing := true;
        confFlag := false;
        inxtype := nil; { index of string const is not allowed }
        slen := len
      end; {with}
    end; { mkStrConst }


    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
            mkStrConst(lsp, lgth);
          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; {with}
            if sign <> none then begin
              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); pshcst(lvp);
                  lvp^.cclass := reel;
                  lvp^.rval := nil;
                  if strchr(fvalu.valp^.rval, 1) = '-' then
                    strchrass(lvp^.rval, 1, '+')
                  else
                    strchrass(lvp^.rval, 1, '-');
                  for i := 2 to digmax do
                    strchrass(lvp^.rval, i, strchr(fvalu.valp^.rval, i));
                  fvalu.valp := lvp;
                end
              end
              else error(105);
            end; {if sign}
            insymbol;
          end {if ident}
          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 strchrass(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*) ;


    { check if type fsp is a string }
    function isString(fsp: stp) : boolean;
    begin
      isString := false;
      if fsp <> nil then
        if fsp^.form = arrays then
            isString := fsp^.slen>=0;
    end (*string*) ;


    { decide whether structures pointed at by fsp1 and fsp2 are compatible }
    { see standard, 6.4.5 }
    function comptypes(fsp1, fsp2: stp) : boolean;
    begin

      { Check same types or one of the types is in error.
        Aliases of the same type will also be equal. }
      if (fsp1 = fsp2) or (fsp1 = nil) or (fsp2 = nil) then
        comptypes := true
      else begin
        comptypes := false; { set default is false }
        if fsp1^.form = fsp2^.form then
          case fsp1^.form of
            scalar: ;  { different forms, so not compatible }

              { Subranges are compatible if either type is a subrange of the
                other, or if the base type is the same. }
            subrange: comptypes := (fsp1^.rangetype = fsp2) or
                                   (fsp2^.rangetype = fsp1) or
                                   (fsp1^.rangetype = fsp2^.rangetype);

              { Sets are compatible if they have the same base types and packed/
                unpacked status, or one of them is the empty set. The empty set
                is indicated by a nil base type, which is identical to a base
                type in error. Either way, we treat them as compatible.

                Set types created for set constants have a flag that disables
                packing matches. This is because set constants can be packed or
                unpacked by context. }
            power: comptypes := (comptypes(fsp1^.elset, fsp2^.elset) and
                                    ((fsp1^.packing = fsp2^.packing) or
                                     not fsp1^.matchpack or
                                     not fsp2^.matchpack)) or
                                  (fsp1^.elset = nil) or (fsp2^.elset = nil);

            { Arrays are compatible if they are string types and
              equal in size.
              NB strings are not conformant arrays }
            arrays: begin
                if isString(fsp1) and isString(fsp2) then begin
                  comptypes := fsp1^.slen = fsp2^.slen;
                end;
              end;

              { Pointers, must either be the same type or aliases of the same
                type, or one must be nil. The nil pointer is indicated by a nil
                base type, which is identical to a base type in error. Either
                way, we treat them as compatible. }
            pointer: comptypes := (fsp1^.eltype = nil) or (fsp2^.eltype = nil);

              { records and files must either be the same type or aliases of the
                same type }
            records: ;
            files:
          end (*case*)
        else if fsp1^.form = subrange then
          { subranges of a base type match the base type }
          comptypes := fsp1^.rangetype = fsp2
        else if fsp2^.form = subrange then
          comptypes := fsp1 = fsp2^.rangetype
        else comptypes := false;
      end;
    end (*comptypes*) ;


    { check structure is, or contains, a file }
    function filecomponent(fsp: stp): boolean;
    var f: boolean;
    begin
      f := false; { set not a file by default }
      if fsp <> nil then
        f := fsp^.hasFile;
      filecomponent := f
    end;


    { resolve all pointer references in the forward list }
    procedure resolvep;
    var ids: idstr; lcp1, lcp2: ctp; mm, fe: boolean;
    begin
      ids := id;
      fe := true;
      while fwptr <> nil do begin
        lcp1 := fwptr;
        fwptr := lcp1^.next;
        strassfv(id, lcp1^.name);
        searchidnenm([types], lcp2, mm);
        if lcp2 <> nil then begin
          lcp1^.idtype^.eltype := lcp2^.idtype;
          lcp2^.refer := true
        end else begin
          if fe then begin error(117); writeln(output) end;
          write('**** Error: undefined type-id forward reference: ');
          writev(output, lcp1^.name, prtlln); writeln;
          fe := false
        end;
        putnam(lcp1)
      end; {while}
      id := ids
    end; { resolvep }


{ emit a C type declaration for the type, variable or arg }
procedure genCType(idtype1 : stp; definingVar: boolean );

var
  lo, hi : integer;  { bounds of subrange or scalar }

procedure emitIntType( min, max: integer );
var
  n,l :  integer;
begin
  { separate into unsigned or signed,
    loop finds int size, beware of overflow }
  n := 8; l := 64;
  if min >= 0 then begin
    while l <=  max div 4 do begin
      n := 2*n;
      l := 4*sqr(l);
    end;
    write( prc, 'uint', n:1, '_t ' )
  end
  else begin
    while (min + l < -l) or (max div 2 >= l) do begin
      n := 2*n;
      l := 4*sqr(l);
    end;
    write( prc, 'int', n:1, '_t ' );
  end;
end;

{ attempt to write a record member as a bitfield
  this is possible iff the member's type is:
    - a non-standard ordinal, and
    - the record is packed
  return false if packed format is not possible }
function writeField( member: ctp; isPacked: boolean ): boolean;
var
  lo, hi : integer;  { bounds of subrange or scalar }
  t      : integer;
  v      : stp;
begin
  writeField := true;
  v := member^.idtype;
  if isPacked and (v^.form = scalar) and (v^.scalkind=declared)
  then begin
    write( prc, ' /* bitfield */ ' );
    getbounds(v, lo, hi);
    t := 1; lo := 1;  { t = 2**lo-1 }
    while t < hi do begin t := t+t+1; lo := lo+1; end;
    write( prc, 'unsigned ' );
    writeId( member );
    write( prc, ' : ', lo:1 );
  end
  else if isPacked and (v^.form = subrange) then begin
    write( prc, ' /* bitfield */ ' );
    getbounds(v, lo, hi);
    if lo >= 0 then begin
      t := 1; lo := 1;  { t = 2**lo-1 }
      write( prc, 'unsigned ' );
    end
    else begin
      if -lo > hi then hi := -lo;
      t := 1; lo := 2;  { extra bit for signed }
      write( prc, 'signed ' );
    end;
    writeId( member );
    while hi > t do begin t := t+t+1; lo := lo+1; end;
    write( prc, ' : ', lo:1 );
  end
  else
    writeField := false;
end; { writeField }

{ generate a C declaration for the fixed part of a pascal record type }
{ member is the head of list of members }
procedure genFixed( member: ctp; isPacked: boolean );
var
  v      : stp;
begin {genFixed}

  if member <> nil then begin
    if member^.klass <> field then begin
      writeln(prc, '//unexpected id klass (', ord(member^.klass):1, ') ' );
      writeId(member);
    end
    { generate the fixed part of the record }
    { skip if the head member is a tag field }
    else begin
      {loop for each member of the struct}
      while member <> nil do begin
        if not writeField(member, isPacked) then begin
          v := member^.idtype;
          genCType(v, false);
          writeId( member );
          while (member^.next <> nil) and ( member^.next^.idtype = v) do begin
            member := member^.next;
            write( prc, ', ' );
            if (v<>nil) and (v^.form = pointer)
              and (v^.typeName = nil)
              then
              write( prc, '*' ); { account for pointer }
            writeid( member );
          end; {while}
        end; {if}
        writeln(prc,';');
        member := member^.next;
      end; {while}
    end; {not field}
  end; {not nil}
end; { genFixed }

procedure genVariant( tag : stp; isPacked: boolean );
var
  v     : stp;
  member: ctp;

begin
  if tag <> nil then begin
    member := tag^.tagfieldp;
    if member <> nil then begin
      if member^.name <> nil then begin
        if not writeField( member, isPacked ) then begin
          genCType( member^.idtype, false );
          writeId( member );
        end;
        writeln(prc,'; // +tagfield' );
      end;
    end;

    writeln(prc, 'union {');

    {loop for each variant of the union}
    {L2504 similar code}
    v := tag^.fstvar;
    while v <> nil do begin
      with v^ do begin
        if not hasFile then begin
          writeln(prc,' /* +variant ', varval:1, '*/' );
          { the variant could be duplicated for different case constants
            choose only the one with the case constant list = nil }
          if caslst = nil then begin
            writeln(prc, 'struct {' );
            genFixed( vfstfld, isPacked );
            genVariant( subvar, isPacked );
            writeln(prc, '};' );
          end;
        end;
      end;
      v := v^.nxtvar;
    end;
    writeln(prc, '}; // union' );

    {put variants with files outside the union}
    {L2504 similar code}
    v := tag^.fstvar;
    while v <> nil do begin
      with v^ do begin
        if hasFile then begin
          writeln(prc,' /* +variant with file ', varval:1, '*/' );
          { the variant could be duplicated for different case constants
            choose only the one with the case constant list = nil }
          if caslst = nil then begin
            writeln(prc, 'struct {' );
            genFixed( vfstfld, isPacked );
            genVariant( subvar, isPacked );
            writeln(prc, '};' );
          end;
        end;
      end;
      v := v^.nxtvar;
    end;

  end; { if tag <> nil }
end; { genVariant }

begin { genCType }
  if idtype1 <> nil then begin
    { predefined scalars }
    if idtype1 = intptr then write( prc, 'int ' )
    else if idtype1 = charptr then write( prc, 'unsigned char ' )
    else if idtype1 = realptr then write( prc, 'double ' )
    else if idtype1 = boolptr then write( prc, 'bool ' ) { non standard scalar }
    else with idtype1^ do begin
      if not definingVar and (typeName <> nil) then begin
        if decState = voidDeclared then begin
          write( prc,' /* +pointer recursion-0 ' );
          writeId(idtype1^.typeName);
          write( prc, ' */ void *' );
        end
        else begin
          { use the already declared type name }
          if (form = records) or (form = arrays) then
            write( prc, 'struct ' );
          writeId(typeName);
          write( prc, ' ' );
        end;
      end
      else begin
        { we are defining a type, or there is no type name }
        case form of
          scalar:   begin
              if scalkind = standard then begin
                write( prc, '>>> error: unknown standard scalar ' );
              end
              else begin
                 if fconst = nil then
                    write( prc, 'int /* >>> error: scalar without max value */ ' )
                 else begin
                    getbounds( idtype1, lo, hi );
                    write( prc, '/* +declared scalar [ 0 ..', hi:3, ' ] */ ' );
                    emitIntType( 0, hi );
                 end;
              end;
            end;
          subrange: begin
              write( prc,'/* +subrange ' );
              if rangetype <> realptr then
                write( prc,' ', smin:1, ' .. ', smax:1, ' ' )
              else begin
                { returned constant could be real or string,
                  subrange requires integer
                  see error(399) in simpletype() }
                write( prc, ' >>> real subrange ' );
              end;
              write( prc, ' */ ' );
              emitIntType( smin, smax );
              write( prc, '/* +range type parsed */ ' );
            end;
          pointer: begin
              if eltype = nil then begin
                 write(prc, '>>> pointer to non existent type' );
              end
              else if isVoidPtr then begin
                 write( prc,' /* +pointer recursion-2 */ void *' );
              end
              else begin
                 write( prc, '/* +pointer */ ' );
                 genCType( eltype, false );
                 write( prc,'*');
              end;
            end;
          power: begin
              write( prc, '/* +set */ ' );
              { make an array of uint8_t s inside a struct }
              { use bounds of elset to find limits }
              getbounds( elset, lo, hi );
              write( prc, 'struct { uint8_t element',
                    '[(', hi:1, '>>3) - (', lo:1, '>>3)+1]; } ' );
            end;
          arrays: begin
              if packing then write( prc, '/* +packed array */ ' )
              else write( prc, '/* +array */ ' );

              if inxtype = nil then begin
                 write(prc, '>>> error: array without index ' );
              end
              else begin
                write( prc, ' struct ' );
                if typeName <> nil then
                  writeId( typeName );
                writeln(prc, ' {' );
                genCType( aeltype, false );
                if confFlag then begin
                  write( prc, ' component[(unsigned)(' );
                  writeId( highbound );
                  write( prc, '+1-' );
                  writeId( lowbound );
                  write( prc, ')]; } ' );
                end
                else begin
                  getbounds(inxtype, lo, hi);
                  {look for [0..maxint] etc}
                  if (lo <= 0) and (hi >= maxint+lo) then
                    write( prc, ' component[', hi:1, 'u + ', 1-lo:1, 'u]; } ' )
                  else
                  write( prc, ' component[', hi-lo+1:1, 'u]; } ' );
                end; { if }
              end; { if }
            end;

          records: begin
              write( prc,'/* +record */  struct ' );
              if packing then
                write( prc, '__attribute__ ((__packed__)) ' );
              if typeName <> nil then
                writeId( typeName );
              writeln(prc, ' {' );
              {ensure fstfld points to fixed part, if any}
              if (fstfld <> nil)
                and (fstfld^.varnt = nil)
                and not fstfld^.tagfield
              then
                genFixed( fstfld, packing );
              { now the variant part, if any }
              genVariant( recvar, packing );
              write( prc, '} ' ); { end of struct }
            end;

          files: begin
              if packing then write( prc, '/* +packed file */ ' )
              else write( prc,'/* +file */ ' );
              if idtype1 = textptr then begin
                write( prc, 'text ' );
              end
              else begin
                writeln(prc, 'struct {' );
                writeln(prc, 'FILE *f;' );
                writeln(prc, 'char *name;' );
                writeln(prc, 'int flags;' );
                genCType(filtype, false);
                writeln(prc, ' buffer;' );
                write( prc, '} ' );
              end;
            end;

        end (*case*)
      end {if}
    end; { with }
  end else begin
    { this is probably caused by a mis-spelled or undeclared identifier }
    write( prc, '>>> idtype is nil ' );
  end; { if }
end; { genCType }


    procedure typ( fsys: setofsys; var fsp: stp );
      var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
          fmin, fmax: integer;
          test: boolean; ispacked: boolean;

      { A simple type is a type identifier, subrange, or an enumeration }
      procedure simpletype(fsys:setofsys; var fsp:stp);
        var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
            lcnt: integer; lvalu: valu;
      begin
        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 top := top - 1;
            new(lsp,scalar,declared); pshstc(lsp);
            with lsp^ do begin
              typeName := nil;
              hasFile := false;
              form := scalar;
              scalkind := declared
            end;
            lcp1 := nil; lcnt := 0;
            repeat insymbol;
              if sy = ident then
              begin new(lcp,konst); ininam(lcp);
                with lcp^ do begin
                  strassvf(name, id); idtype := lsp; next := lcp1;
                  klass := konst; values.ival := lcnt
                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; top := ttop;
            if sy = rparent then insymbol else error(4)
          end
          else begin  { not type enumeration }
            if sy = ident then begin
              searchid([types,konst],lcp);
              insymbol;
              if lcp^.klass = konst then begin
                new(lsp,subrange); pshstc(lsp);
                with lsp^, lcp^ do begin
                  typeName := nil; hasFile := false;
                  form := subrange; rangetype := idtype;
                  if isString(rangetype) then
                    begin error(148); rangetype := nil end;
                  smin := values.ival;
                end;
                if sy = range then insymbol else error(21);
                constant(fsys,lsp1,lvalu);
                lsp^.smax := lvalu.ival;
                if (lsp1 <> nil) and (lsp^.rangetype <> lsp1) then error(107)
              end
              else begin lsp := lcp^.idtype;
              end
            end {sy = ident}
            else begin
              constant(fsys + [range],lsp1,lvalu);
              { strings and reals are valid constants, so check these separately }
              if isString(lsp1) then
              begin error(148); lsp1 := nil end;
              new(lsp,subrange); pshstc(lsp);
              with lsp^ do begin
                typeName := nil; hasFile := false;
                form := subrange;
                rangetype:=lsp1; smin:=lvalu.ival;
              end;
              if sy = range then insymbol else error(21);
              constant(fsys,lsp1,lvalu);
              lsp^.smax := lvalu.ival;
              if (lsp1 <> nil) and (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 smin > smax then begin
                        {leave as is to allow supressing follow on errors}
                        error(102)
                      end;
          end;  {not enumerated type}
          fsp := lsp;
          if not (sy in fsys) then
          begin error(6); skip(fsys) end
        end
        else fsp := nil; {not simpletype symbol}
      end (*simpletype*) ;


      { parse field list for records }
      { TODO: split this proc into fixed and variant parts - Pemberton, Ch 8
         Needs flag to separate var dec behaviour from type dec behaviour.  See Pemberton.
         var dec needs to emit individual fields to preserve declaration order.
      }
      {
       frecvar: return recvar or subvar type
       vartype: pointer to the variant type (or nil for fixed part)
       varlab:  pointer to the tag name     (or nil for fixed part)
       aFile:   field is a file or contains a file
       lvl:     tag level
      }
      procedure fieldlist(fsys: setofsys; var frecvar: stp; vartyp: stp;
                          varlab: ctp; var aFile: boolean; lvl: integer);
        var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
            lvalu: valu;
            done: boolean; mm: boolean;
      begin
        nxt1 := nil; lsp := nil;
        if not (sy in (fsys + [ident,casesy])) then
          begin error(19); skip(fsys + [ident,casesy]) end;

        { parse fixed part of the record }
        while sy = ident do begin
          nxt := nxt1;

          { loop to get a comma separated list of members }
          repeat
            if sy = ident then begin
              new(lcp, field); ininam(lcp);
              with lcp^ do begin
                strassvf(name, id); idtype := nil; next := nxt;
                klass := field; varnt := vartyp; varlb := varlab;
                tagfield := false;
              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;
            done := sy <> comma;
            if not done  then insymbol
          until done;

          { get the type }
          if sy = colon then insymbol else error(5);
          typ(fsys + [casesy,semicolon],lsp);
          if filecomponent(lsp) then
            aFile := true;
          while nxt <> nxt1 do
            with nxt^ do begin
              idtype := lsp;
              nxt := next;
            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*);

        { now reverse pointers }
        nxt := nil;
        while nxt1 <> nil do
          with nxt1^ do
            begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;

        if vartyp <> nil then begin
          { we are parsing a variant,
            variant must point to the list of fields }
          vartyp^.vfstfld := nxt;
          write( prc, '// vfstfld points to ' );
          writeId( vartyp^.vfstfld ); writeln(prc );
          { TODO: list whole chain ?? }
        end;

        { parse variant part of record }
        if sy = casesy then begin
          { parse tag:
                  lsp:  the tag field - this points to tag name & first member
                  lcp:  name of tag
                  lcp1: name of the type
          }
          new(lsp,tagfld); pshstc(lsp); { new type }
          with lsp^ do begin
            typeName := nil; hasFile := false;
            form:=tagfld; tagfieldp := nil; fstvar := nil;
            packing := false
          end;
          frecvar := lsp; { now parent record points to this tag }
          insymbol;
          if sy = ident then  begin { type only or tag name }
            { lcp is tag name, lcp1 is type name }
            searchidnenm([types],lcp1,mm);    { find possible type }
            new(lcp,field); ininam(lcp);      { or possible field id }
            with lcp^ do begin
              strassvf(name, id); idtype := nil; klass:=field;
              next := nil; varnt := vartyp;
              varlb := varlab; tagfield := true;
            end;
            insymbol;
            if sy = colon then begin
              { type of tag identifier, so lcp holds tag name }
              enterid(lcp); insymbol;
              if sy = ident then begin
                searchid([types],lcp1); { lcp1 is type of sy (from insymbol) }
                insymbol
              end
              else begin
                error(2); skip(fsys + [ofsy,lparent]); lcp1 := nil;
              end
            end else begin
              { if type only (undiscriminated variant), check & kill the id. }
              if lcp1 = nil then
                error(104)
              else if mm then error(103);
              putstrs(lcp^.name); { release name string }
              lcp^.name := nil { set no tagfield }
            end;
            if lcp1 <> nil then begin
              lsp1 := lcp1^.idtype;   {name of type of tag}
              if lsp1 <> nil then begin
                { tagfield must be a discrete type }
                { call to constant() below could find string or real constant
                  so eliminate them here }
                if (lsp1^.form <= subrange) or isString(lsp1) then begin
                  if comptypes(realptr,lsp1) then error(109)
                  else if isString(lsp1) then
                    error(399);
                  lcp^.idtype := lsp1;
                end
                else error(110);
              end
            end;
            lsp^.tagfieldp := lcp;   {!!! bug fix}
            write( prc, '// tagfield ' ); writeId( lcp ); writeln(prc );
          end
          else begin error(2); skip(fsys + [ofsy,lparent]) end;

          if sy = ofsy then insymbol else error(8);
          lsp1 := nil;

          { loop for each variant part }
          repeat
            { lsp1 is the most recent variant
                   it is used to build list of all variants in the record
              lsp2 is most recent variant in the current case list
                   it is used to build case list
              lsp3 is the current variant }
            lsp2 := nil;
            if not (sy in fsys + [semicolon]) then begin
              repeat
                { get a group of one or more constants }
                constant(fsys + [comma,colon,lparent],lsp3,lvalu);
                { error if constant type does not match tag }
                if lsp^.tagfieldp <> nil then
                  if not comptypes(lsp^.tagfieldp^.idtype, lsp3) then
                    error(111);
                new(lsp3,variant); pshstc(lsp3);
                with lsp3^ do begin
                  typeName := nil;
                  form := variant;
                  nxtvar := lsp1; { add to the list of variants }
                  varval := lvalu.ival;
                  vfstfld := nil;
                  caslst := lsp2; { make a list of case values }
                end;
                lsp4 := lsp1;
                { error if this variant has already been declared }
                while lsp4 <> nil do
                  with lsp4^ do begin
                    if varval = lvalu.ival then error(178);
                    lsp4 := nxtvar
                  end;
                lsp1 := lsp3; lsp2 := lsp3;
                done := sy <> comma;
                if not done then insymbol
              until done;

              { now get all the members }
              { lsp2 is now used for recvar, pointer to tag in child variants }
              if sy = colon then insymbol else error(5);
              if sy = lparent then insymbol else error(9);
              { recursive call to get all the components of the case }
              mm := false;
              fieldlist(fsys + [rparent,semicolon],
                        lsp2,  { get recvar, subvar }
                        lsp3,  { vartype }
                        lcp,   { varlab, tagname }
                        mm,
                        lvl+1);
              if mm then aFile := true;

              { make each variant in the group point to any subvariants, etc }
              lcp1 := lsp3^.vfstfld;
              while lsp3 <> nil do with lsp3^ do begin
                subvar := lsp2;
                vfstfld := lcp1;
                hasFile := mm;
                lsp3 := caslst;
             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;
            done := sy <> semicolon;
            if not done then insymbol
          until done;
          lsp^.fstvar := lsp1; { tagfield points to last(!) variant }
        end
        else
          frecvar := nil
      end (*fieldlist*) ;

    begin (*typ()*)
      lsp := nil;
      if not (sy in typebegsys) then
         begin error(10); skip(fsys + typebegsys) end;
      if sy in typebegsys then begin

        ispacked := false; { default is not packed }
        if sy = packedsy then begin
          insymbol;
          if sy in typedels then
            ispacked := true { packed }
          else begin
            error(10); skip(fsys + typebegsys - [packedsy])
          end;
        end;

        if sy in simptypebegsys then
          simpletype(fsys,lsp)
        else if sy = arrow then begin
          (*^*)                              { ------------  Pointers }
          new(lsp,pointer); pshstc(lsp);
          with lsp^ do begin
            typeName := nil;
            hasFile := false;
            isVoidPtr := false;
            form:=pointer; eltype := nil;
            packing := false
          end;
          insymbol;
          { Get the pointed to type identifier }
          { make all pointers forward declared,
            then resolve at the end of the type declaration
            so that local identifiers have priority over non-local ones.
          }
          if sy = ident then begin
            { forward reference everything, fix up later}
            new(lcp,types); ininam(lcp);
            with lcp^ do begin
              strassvf(name,id); idtype := lsp;
              next := fwptr; klass := types
            end;
            fwptr := lcp;
            insymbol;
          end
          else error(2);
        end
        else if sy = arraysy then begin           (* -------------------- array*)
          insymbol;
          if sy = lbrack then insymbol else error(11);
          lsp1 := nil;

          { loop to get each of a list of indexes.
          Each time round, this loop creates an array structure whose
          component type is either
          - the array structure created the next time round the loop, or
          -the type following the indexes.
          }
          repeat                           { loop thru the indices }
            new(lsp,arrays); pshstc(lsp);
            with lsp^ do begin
              typeName := nil;
              form:=arrays; aeltype := lsp1; inxtype := nil;
              confFlag := false; slen := -1;
              packing := ispacked
            end;
            lsp1 := lsp;
            simpletype(fsys + [comma,rbrack,ofsy],lsp2); { Get one index type }

            if lsp2 <> nil then
              if lsp2^.form <= subrange then begin  { index must be scalar }
                if lsp2 = realptr then
                begin error(112); lsp2 := nil end
              else if lsp2 = intptr then
              begin error(149); lsp2 := nil end;
                lsp^.inxtype := lsp2  { set the index type }
              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);          { component type }

          {lsp1 is the last component of array, lsp is the component type}
          {if it is a string, set the string length}
          if comptypes( lsp, charptr ) and isPacked then begin
            with lsp1^ do begin
              if inxtype = nil then
                { error in the index type, call it a string }
                slen := 1
              else if comptypes(inxtype, intptr) then begin
                getbounds(inxtype,fmin,fmax);
                if (fmin = 1) {and (fmax>1)} then begin
                  slen := fmax
                end;
              end {if}
            end; {with}
          end; {if}

          repeat               { for each index type }
            with lsp1^ do begin
              lsp2 := aeltype; aeltype := lsp;
              hasFile := filecomponent(aeltype);
            end; {with}
            lsp := lsp1; lsp1 := lsp2
          until lsp1 = nil;

        end { array symbol }

        else if sy = recordsy then begin (* -----------------   record*)
          insymbol;
          { Create a new element on top of the display }
          oldtop := top;
          if top < displimit then begin
            top := top + 1;
            with display[top] do begin
              fname := nil;
              flabel := nil;
              fconst := nil;
              fstruct := nil;
              packing := false;
              occur := rec
            end
          end
        else error(250); {scope nest limit exceeded}
          new(lsp,records);
          with lsp^ do begin             { Create record structure }
            typeName := nil;
            form := records;
            hasFile := false;
            fieldlist(fsys - [semicolon] + [endsy], recvar, nil,nil, hasFile, 1);
            fstfld := display[top].fname;
            display[top].fname := nil;
            packing := ispacked;
            recyc := display[top].fstruct;
            display[top].fstruct := nil
          end;
          putdsps(oldtop); top := oldtop;
          { register the record late because of the purge above }
          pshstc(lsp);
          if sy = endsy then insymbol else error(13)
        end { record symbol }

        else if sy = setsy then begin      (* ------------   set*)
          insymbol;
          if sy = ofsy then insymbol else error(8);
          simpletype(fsys,lsp1); { Get the element type }
          if lsp1 <> nil then
            { type must be scalar but not integer or real }
            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;
          new(lsp,power); { Create the set structure }
          pshstc(lsp);
          with lsp^ do begin
            typeName := nil;
            hasFile := false;
            packing := ispacked;
            form:=power; elset:=lsp1; matchpack := true
          end;
        end { set symbol }

        else if sy = filesy then begin    (* ------------   file *)
          insymbol;
          if sy = ofsy then insymbol else error(8);
          typ(fsys,lsp1);
          { a file must not contain another file }
          if filecomponent(lsp1) then error(191);
          new(lsp,files); pshstc(lsp);
          with lsp^ do begin
            typeName := nil;
            hasFile := true;
            form := files; filtype := lsp1;
            packing := ispacked
          end
        end { file symbol }

        else { error, shouldn't be here }
          lsp := nil;

        if not (sy in fsys) then
          begin error(6); skip(fsys) end
      end;
      fsp := lsp
    end (*typ*) ;

    procedure labeldeclaration;
      var llp: lbp;
          test: boolean;
    begin
      insymbol;
      repeat
        if sy = intconst then begin
          searchlabel(llp, top); { search preexisting label }
          if llp <> nil then error(166) { multideclared label }
          else begin
            newlabel(llp);
            if llp^.labval > 9999 then error(196);
            { gcc will optimise out the jmp_buf if it is unused }
            if level = 1 then write( prc, 'static ' );
            writeln(prc, 'jmp_buf _PJB', llp^.labname:1, ';' );
          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
      insymbol;
      if sy <> ident then
        begin error(2); skip(fsys + [ident]) end;
      while sy = ident do
        begin new(lcp,konst); ininam(lcp);
          with lcp^ do
            begin strassvf(name, id); idtype := nil; next := nil; klass:=konst;
              refer := false
            end;
          insymbol;
          if (sy = relop) and (op = eqop) then insymbol else error(16);
          constant(fsys + [semicolon],lsp,lvalu);
          enterid(lcp); { this needs to be here, (eg const i=i), see pemberton, Ch8 }
          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: ctp;  { ^identifier }
          lsp: stp;  {  ^type }
          head, lsp1: stp; { list of type declarations }

       {
       output pascal declarations:
       const: internal to compiler, no output necessary
       types need to be declared after all types parsed so pointers
       can be resolved.  processing has these layers:
        - declareType:  determines order of the declarations for valid c
                        handles circular type declarations
        - genCType: reverse pascal declaration to output valid C declaration
                    put pascal arrays & sets inside C structs
       vars:  output after each var declared.  Uses type conversion.
       }

       {  determine the C language order of the type definitions
          c and pascal pointers have different binding rules:
          - in Pascal recursive data structures are implemented by resolving
            pointers after all types are declared
          - in c, structs are forward declared, or
          - other recursive pointers are replaced with void * where necessary

          assumes all types are declared and pointer types resolved,
       `  build list of typ decs, sort so that they are declared before used,
          and after whatever they point to.
          Circular dependencies are avoided by forward declaring structs
          ie before generating a type dec, dig into dependencies,
          output all type definitions that are necessary, forward ref a
          struct if found undeclared,
          use void * if any other pointer is used recursively.
          so typedef *sometype p; -- p is pointer that is recursive
          refs to p inside sometype are replaced by void*
          mark type definitions as forwardDeclared or voidDeclared as necessary.
       }
       procedure declareType(t : stp );
       { TODO: recursion detection could be smarter.
               if a loop thru 2 or more declarations starts at a pointer,
               then a void* recursion will be produced,
               even if it's possible to start at a struct (or array)
               and produce a forward declared struct type recursion.
               ( eg, see tppp1 & this1 in tp5c.pas )
       }

         procedure wrMembers(member : ctp);
         begin
           { TODO: traverse left & right links instead of list  }
           while member <> nil do begin
             with member^ do begin
               write( prc, '/* ++ member ' );
               writev( prc, name, lenpv(name) );
               write( prc, ' type ' );
               if idtype = nil then
                 writeln(prc, '>>> field has no type' )
               else if idtype^.typeName <> nil then
                 writev( prc, idtype^.typeName^.name,
                        lenpv(idtype^.typeName^.name) )
               else
                 write( prc, '---' );
               writeln(prc, ' */' );
               declareType( idtype );
               member := next;
             end; { with }
           end; { while }
         end; { wrMembers }

       begin
         if t = nil then
            writeln(prc, '>>> non-existent type' )
         else
           with t^ do begin
             if typeName <> nil then begin
                if checkStruct  then begin
                   if decState = notDeclared then begin
                      writeln(prc, '/* ++recursive struct, state is ',
                              ord(decState):1, ' */' );
                      write( prc, 'struct ' );
                      writeId( typeName );
                      writeln(prc, ';');
                      decState := forwardDeclared;
                   end
                end
                else if checkPtr then begin
                   { recursive typedef found -
                     whatever points to here must be replaced by void* }
                   if decState = notDeclared then begin
                      decState := voidDeclared;
                      write( prc, '/* ++pointer recursion X ' );
                      writeId( typeName );
                      writeln(prc, ' */' );
                   end
                end
                else if decState <> isDeclared then begin
                   { check for a loop,
                     but forward declared struct overrules void * }
                   write( prc, '/* ++ ' );
                   writev( prc, typeName^.name, lenpv(typeName^.name) );
                   checkPtr := true;
                   if form = records then begin
                     checkPtr := false;
                     checkStruct := true;
                     writeln( prc, ' ++record' );
                     wrMembers(fstfld);
                     { now look at the variant part }
                     if recvar <> nil then begin
                       writeln(prc, '/* +* variant part */' );
                       declareType(recvar);
                     end;

                     checkStruct := false;
                   end
                   else if form = scalar then begin
                     writeln(prc, ' ++scalar type */' );
                   end
                   else if form = subrange then begin
                     writeln(prc, ' ++subrange type */' );
                     declareType( rangetype);
                   end
                   else if form = pointer then begin
                     { TODO: review interplay between struct & pointer loops }
                     if (eltype <> nil) and (eltype^.form = records)
                       and (eltype^.typeName <> nil) then
                       checkPtr := false;
                     writeln(prc, ' ++pointer type */' );
                     declareType( eltype );
                   end
                   else if form = power then begin
                     writeln(prc, ' ++power (set) type */' );
                     declareType( elset );
                   end
                   else if form = arrays then begin
                     checkPtr := false;
                     checkStruct := true;
                     writeln(prc, ' ++array component type */' );
                     declareType( aeltype );
                     checkStruct := false;
                   end
                   else if form = files then begin
                     writeln(prc, ' ++file type */' );
                     declareType( filtype );
                   end
                   else if form = tagfld then begin
                     writeln(prc, '>>> not expecting tagfield to define a type ');
                   end
                   else if form = variant then begin
                     writeln(prc, '>>> not expecting variant to define a type ');
                   end; { if }
                   checkPtr := false;
                   writeln(prc );
                   { the type might have become declared in
                     one of the recursive calls }
                   if decState <> isDeclared then begin
                      with typeName^ do begin
                         write( prc, '// type declaration ' );
                         writev( prc, name, lenpv(name) );
                        writeln(prc, ' state is ', ord(decState):1 );
                         write( prc, 'typedef ' );
                         write( prc, '/* type id ' );
                         writev( prc, name, lenpv(name) ); write( prc, ' */ ' );
                         { TODO: maybe definingVar code could be here }
                         genCType( t, true );
                         writeId( typeName ); writeln(prc,';');
                      end; { with }
                      isVoidPtr := decState = voidDeclared;
                      if isVoidPtr then
                        writeln(prc, '/* void*, form is ',
                                 ord(form), ' */' );
                      decState := isDeclared;
                   end; { if }
                end; { if }
             end
             else begin
                { no name, but components of file, pointer(?), array or record
                  might contain a name that needs to be declared
                }
                if form = arrays then begin
                  writeln(prc, '/* +*array component type */' );
                  declareType( aeltype );
                end
                else if form = records then begin
                  writeln( prc, '// +*record' );
                  wrMembers(fstfld);
                  { now look at the variant part }
                  if recvar <> nil then begin
                    writeln(prc, '/* +* variant part */' );
                    declareType(recvar);
                  end;
                end
                else if form = tagfld then begin
                  { TODO:  ?? should be int anyway }
                  if tagfieldp <> nil then begin
                    writeln(prc, '/* +*tagfield 2 */' );
                    if tagfieldp^.name <> nil then begin
                      declareType(tagfieldp^.idtype);
                    end;
                  end;
                  if fstvar <> nil then
                    declareType(fstvar);
                end
                else if form = variant then begin
                  { check each member of the variant }
                  writeln( prc, '// +*variant' );
                  wrMembers(vfstfld);
                  if (subvar <> nil) and (caslst = nil) then
                    declareType( subvar );
                  if nxtvar <> nil then
                    declareType( nxtvar );
                end
                else if form = pointer then begin
                   writeln(prc, '/* +*pointer type */' );
                   declareType( eltype );
                end
                else if form = files then begin
                   writeln(prc, '/* +*file type */' );
                   declareType( filtype );
                end; { if }
             end; { if }
          end; { with }
       end; { declareType}

       begin { typedeclaration() }
          head := nil; lsp1 := nil;
          insymbol;
          if sy <> ident then
            begin error(2); skip(fsys + [ident]) end;
          while sy = ident do begin
             new(lcp,types); ininam(lcp);
             with lcp^ do
             begin strassvf(name, id); idtype := nil; klass := types;
                refer := false
             end;
             insymbol;
             if (sy = relop) and (op = eqop) then insymbol else error(16);
             typ(fsys + [semicolon], lsp);
             enterid(lcp);
             lcp^.idtype := lsp;

             if lsp = nil then begin
               write( prc, '>>> nil type pointer ' );
               writeId(lcp);
               writeln(prc );
             end
             else if (lsp <> boolptr) and (lsp <> textptr) then
               with lsp^ do begin
                 { many names could point to the type, use only the first }
                 if (typeName = nil) and
                      ((form <> scalar) or (scalkind <> standard)) then begin
                   typeName := lcp;
                   decState := notDeclared;
                   checkStruct := false;
                   checkPtr := false;
                   decChain := nil;
                   {  make a chain of type names }
                   if lsp1 = nil then begin
                      head := lsp;
                   end
                   else begin
                      lsp1^.decChain := lsp;
                   end;
                   lsp1 := lsp;
                 end;
               end; {with}

             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; { while }

          resolvep;          {resolve forward declared record pointers}
          lsp1 := head;
          while lsp1 <> nil do begin
             with lsp1^ do begin
                if typeName = nil then begin
                   writeln( 'internal error: empty type name' );
                end
                else begin
                   declareType( lsp1 );
                end;
                lsp1 := lsp1^.decChain;
             end;
          end; {while}

       end (*typedeclaration*) ;


       procedure vardeclaration;
       var lcp,nxt: ctp; lsp: stp;
          haveComma : boolean;
          fileFlag : boolean; { declared var contains a file }
          t : fileListItemPtr;
       begin
         insymbol;
         nxt := nil;
         repeat
           repeat   { loop to get each identifier in a group (eg in x,y: real) }
             if sy = ident then begin
               new(lcp,vars); ininam(lcp);
                 with lcp^ do begin
                   strassvf(name, id); next := nxt; klass := vars;
                   idtype := nil; vkind := actual; vlev := level;
                   refer := false; threat := false; forcnt := 0
                 end; {with}
               enterid(lcp);
               { we don't know the indentifier's type yet, so
                 link the identifiers together and fill in type later.
                 nxt points to the last identifier processed.
               }
               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;
             haveComma := sy = comma;
             if haveComma then insymbol
           until not haveComma;
           if sy = colon then insymbol else error(5);

           typ(fsys + [semicolon] + typedels,lsp);   { no more vars, get type }
           {tbb:
             moved resolvp here from below to fix forward refs before
             var declaration emitted
             note: var decs cannot have forward referenced types
             TODO: maybe typ() should have a param to indicate called from
                   var dec to resolve all refs (see pemberton)
           }
           resolvep;

           {now write the c declaration for the variable(s)}
           if level = 1 then
             write( prc, 'static ' );
           genCType( lsp, false );
           write( prc, ' /* form ' );
           write( prc, '(' );
           if lsp <> nil then
             write( prc, ord(lsp^.form):1 )
           else
             write( prc, '?' );;
           write( prc, ') */ ' );

           fileFlag := filecomponent( lsp );
           if fileFlag then
             display[level].hasFile := true;
           while nxt <> nil do begin
             with nxt^ do begin
               idtype := lsp;
               { --- emit the declared var here --- }
               {note: vars emitted in reverse order.
                See Pemberton ch 8 about keeping order. }

               writeId( nxt );
               { file vars must be zeroed so we can know
                 if they have already been opened }
               if fileFlag then begin
                 write( prc, '={0}' );
                 {build list of files}
                 new( t );
                 t^.fileVar := nxt;
                 t^.next := fileList;
                 fileList := t;
               end;
               nxt := next;
             end; { with }
             if nxt <> nil then begin
               write( prc, ', ' );
               if (lsp<>nil) and (lsp^.form = pointer)
                 and (lsp^.typeName = nil)
               then
                 write( prc, '*' );
             end;
           end; {while}

           if sy = semicolon then begin
             insymbol;
             if not (sy in fsys + [ident]) then
               begin error(6); skip(fsys + [ident]) end
           end
           else error(14);
           writeln(prc, ';');
         until (sy <> ident) and not (sy in typedels);
         {resolvep;}  { fix or report undeclared pointer types }

       end; (*vardeclaration*)


    { build symbol table for procedure or function declaration }
    procedure procdeclaration;
      var oldlev: 0..maxlevel; lcp,lcp1,lcp2: ctp; lsp: stp;
          forw: boolean; oldtop: disprange;
          fsy: symbol;
          funcDebug:  boolean;

      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; fconst := nil; fstruct := nil; packing := false;
                occur := blck;
                hasFile := false; bname := lcp
              end
          end
        else error(250); {scope nest limit exceeded}
      end; { pushlvl }

      { build symbol table for parameter list,
        fpar is first parameter }
      procedure parameterlist(fsy: setofsys; var fpar: ctp);
        var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
          count: integer;
          oldlev: 0..maxlevel; oldtop: disprange;
          haveComma: boolean;

      { get formal parameter type for type id or conformant array,
        return pointer to type in fsp
        if idOnly is true then expect type id, not conformant array }
      procedure paramType(var fsp: stp; idOnly: boolean );
      var
        lsp, lsp1, lsp2: stp;
        lcp1, lcp2, lcp3: ctp;
        ispacked, haveSemi: boolean;

      procedure bounddeclaration(fsy: setofsys; var fcp: ctp);
      var lcp: ctp;
      begin
        if sy = ident then begin
          new(lcp, boundid); ininam(lcp);
          with lcp^ do begin
            klass := boundid;
            strassvf(name, id);
            idtype := nil; next := nil;
            keep := true;
            lev := level
          end;
          enterid(lcp);
          insymbol;
        end
        else begin
          error(222); skip(fsy);
          lcp := nil;
        end;
        fcp := lcp
      end { bounddeclaration };


      begin { paramType }

        if sy = ident then begin
          searchid([types],lcp);
          lsp := lcp^.idtype;
          insymbol;
        end
        else begin
          if idOnly then error(220); { must have a type id if parent is packed }
          if sy = packedsy then begin
            insymbol;
            ispacked := true;
          end
          else
            ispacked := false;
          if sy = arraysy then begin
            insymbol;
            if sy = lbrack then insymbol else error(11);

            { loop to get each of the comma separated index types }
            lsp1 := nil;
            repeat

              { get index bounds and type }
              bounddeclaration(fsys+[range,ident,colon,rbrack,ofsy], lcp1); { low bound }
              if sy = range then insymbol else error(21);
              bounddeclaration(fsys+[ident,colon,rbrack,ofsy], lcp2); { high bound }
              if sy=colon then insymbol else error(5);

              if sy = ident then begin
                searchid([types],lcp3);
                lsp2 := lcp3^.idtype; { index type }
                if lsp2 <> nil then
                  if lsp2^.form > subrange then   { index must be scalar }
                    begin lsp2 := nil; error(223) end
                  else if lsp2 = realptr then
                    begin error(109); lsp2 := nil end;
                insymbol;
              end
              else begin error(2); lsp2 := nil end;

              if lcp1 <> nil then lcp1^.idtype := lsp2;
              if lcp2 <> nil then lcp2^.idtype := lsp2;

              new(lsp,arrays);  pshstc(lsp);
              with lsp^ do begin
                form := arrays;
                typename := nil; decState := notDeclared;
                aeltype := lsp1;
                inxtype := lsp2; { this is the bounds type }
                packing := ispacked; slen := -1;
                lowbound := lcp1; highbound := lcp2; confFlag := true
              end; {with}
              lsp1 := lsp;  { make a chain of arrays }
              haveSemi := sy = semicolon;
              if sy = comma then begin error(14); haveSemi := true; end;
              if haveSemi then
              begin insymbol; if ispacked then error(220) end
            until not haveSemi;

            if sy=rbrack then insymbol else error(12);
            if sy=ofsy then insymbol else error(8);
            paramType(lsp, ispacked);   { array[...] of (ident or array[...]) }

            {reverse pointers}
            repeat
              with lsp1^ do begin
                lsp2 := aeltype; aeltype := lsp;
                hasFile := filecomponent(lsp);
              end; {with}
              lsp := lsp1; lsp1 := lsp2
            until lsp1 = nil
          end
          else
            lsp := nil;
        end;

        fsp := lsp;

      end { paramType };

      begin {parameterlist()}
        lcp1 := nil;
        if not (sy in fsy + [lparent]) then
          begin error(7); skip(fsys + fsy + [lparent]) end;
        if sy = lparent then begin
          { must not repeat parameter list if forward declared }

          { TODO: if forw, is it better to forget old function parameters,
                  and not skip parameters of the new function? }
          if forw then error(119);
          insymbol;
          if not (sy in [ident,varsy,procsy,funcsy]) then
            begin error(7); skip(fsys + [ident,rparent]) end;

          { TODO: func & proc handling could be combined into a separate proc }
          { if forward declared, skip over the parameters }
          while sy in [ident,varsy,procsy,funcsy] do begin
            if sy = procsy then begin           { ------- procedure parameter }
              insymbol; lcp := nil;
              if not forw then begin
                new(lcp,proc,declared,formal); ininam(lcp);
                with lcp^ do begin
                  if sy = ident then begin
                    strassvf(name, id);
                    insymbol;
                  end
                  else begin
                    error(2);
                    strassvf(name, '         ');
                  end;
                  idtype := nil; next := lcp1;
                  klass:=proc; pfdeckind:=declared;
                  pflev := level (*beware of parameter procedures*);
                  pfkind:=formal; keep := true
                end;
                enterid(lcp);
                lcp1 := lcp;
              end;
              oldlev := level; oldtop := top; pushlvl(false, lcp);
              parameterlist([semicolon,rparent],lcp2);
              if lcp <> nil then
                lcp^.pflist := lcp2;
              {NB: this test is redundant, since parameterlist() can only leave
                   with sy one of [fsys, semicolon, rparent] }
              if not (sy in fsys + [semicolon,rparent]) then
                begin error(7); skip(fsys + [semicolon,rparent]) end;
              level := oldlev; putdsps(oldtop); top := oldtop
            end
            else if sy = funcsy then begin         { ---------- function param }
              lcp := nil;
              insymbol;
              if not forw then begin
                new(lcp,func,declared,formal); ininam(lcp);
                with lcp^ do begin
                  if sy = ident then begin
                    strassvf(name, id);
                    insymbol;
                  end
                  else begin
                    error(2);
                    strassvf(name, '         ');
                  end;
                  idtype := nil; next := lcp1;
                  klass:=func;pfdeckind:=declared;
                  pflev := level (*beware param funcs*);
                  pfkind:=formal; keep := true
                end;
                enterid(lcp);
                lcp1 := lcp;
              end;
              oldlev := level; oldtop := top; pushlvl(false, lcp);
              parameterlist([colon,semicolon,rparent],lcp2);
              if lcp <> nil then
                lcp^.pflist := lcp2;
              if not (sy in fsys + [colon]) then
                begin error(7); skip(fsys + [colon,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                   { -------------- var or value param }
              if sy = varsy then begin
                lkind := formal;
                insymbol
              end
              else
                lkind := actual;
              lcp2 := nil; { for chaining a group of identifiers }
              count := 0;
              repeat { get each comma separated variable }
                if sy = ident then begin
                  if not forw then begin
                    new(lcp,vars); ininam(lcp);
                    with lcp^ do begin
                      strassvf(name,id); idtype:=nil; klass:=vars;
                      vkind := lkind; next := lcp2; vlev := level;
                      keep := true; refer := false; threat := false;
                      forcnt := 0
                    end;
                    enterid(lcp);
                    lcp2 := lcp; count := count+1;
                  end;
                  insymbol;
                end
                else error(2);
                if not (sy in [comma,colon] + fsys) then { TODO: fsys? }
                  begin error(7); skip(fsys + [comma,semicolon,rparent])
                end;
                haveComma := sy = comma;
                if haveComma then insymbol
              until not haveComma;

              { we have a group of params, now get their type }
              if sy = colon then begin
                insymbol;
                paramType(lsp, false);   { ident or conformant array }
                if lsp <> nil then begin
                  if lsp <> nil then
                    { prohibit file value params }
                    if lkind=actual then { if value param }
                      if lsp^.form > power then
                        if filecomponent(lsp) then error(121);
                  lcp3 := lcp2;
                  while lcp2 <> nil do begin
                    lcp := lcp2;
                    with lcp2^ do begin
                      idtype := lsp;
                    end;
                    lcp2 := lcp2^.next
                  end;
                  { add the just scanned group to the function's param list }
                  lcp^.next := lcp1; lcp1 := lcp3;
                end
                else begin
                  error(221);
                  { set any id list to tear down }
                  while lcp2 <> nil do
                  begin lcp2^.keep := false; lcp2 := lcp2^.next end
                end;
                if not (sy in fsys + [semicolon,rparent]) then
                  begin error(7); skip(fsys + [semicolon,rparent]) end
              end
              else begin { no ':' }
                error(5);
                { set any id list to tear down }
                while lcp2 <> nil do
                begin lcp2^.keep := false; lcp2 := lcp2^.next end
              end;
            end;

            {check for more params or end of param list}
            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 sy in [proc,func, ...] *) ;

          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;
          { the parameters are listed in reverse order so reverse pointers,
            reserve local cells for copies of multiple values}
          while lcp1 <> nil do
            with lcp1^ do begin
              lcp2 := next; next := lcp3;
              lcp3 := lcp1; lcp1 := lcp2
            end;
          fpar := lcp3
        end
        else fpar := nil
      end; {parameterlist}


      procedure genCParams( parList : ctp; withName : boolean );
      var
        lsp, lsp1 : stp;
      begin
        lsp := nil;
        write( prc, '(' );
        if parList = nil then
          write( prc, 'void' )
        else begin
          { fill in parameters }
          repeat
            with parList^ do begin
              if klass = vars then begin
                if isConfArray( idtype ) then begin
                  { add bounds, then conf array parameter(s) }
                  if idType <> lsp then begin
                    { start of a group of parameters, emit bounds }
                    write( prc, ' /* conf array */ ');
                    lsp := idType;
                    lsp1 := lsp;
                    repeat
                      with lsp1^ do begin
                        write( prc, 'const ' );
                        genCType( inxType, false );
                        writeId( lowbound);
                        write( prc, ', const ' );
                        genCType( inxType, false );
                        writeId( highbound);
                        write( prc, ', ' );
                        lsp1 := aelType;
                      end; { with }
                    until not isConfArray( lsp1 );
                  end;
                  write( prc, 'void *const ' );
                  writeId(parList);
                  write( prc, 'c');
                end
                else begin { not conformant array }
                  genCType( idtype, false );
                  if withName then
                    write( prc, ' ' );
                  if vkind = formal then
                    write( prc, '*const ' );
                  if withName then
                    writeId(parList);
                end
              end
              else if klass = proc then begin
                write( prc, ' /* proc */ void (*const ' );
                writeId(parList);
                write( prc, ')' );
                genCParams( pflist, false )
              end
              else if klass = func then begin
                write( prc, ' /* func */ ' );
                genCType( idType, false );
                write( prc, ' (*const ' );
                writeId(parList);
                write( prc, ')' );
                genCParams( pflist, false )
              end
              else
                error(10); { unexpected klass type }
              parList := next;
            end; { with }

            if parList <> nil then
              write( prc, ', ' );
          until parList = nil;
        end; { if }
        write( prc, ')' );
      end; { genCParams() }


    begin (*procdeclaration*)
      forw := false;
      fsy := sy;
      funcDebug := debug;  { get this at the point of the function keyword }
      insymbol; { get proc/func name }
      if sy = ident then begin
        searchsection(display[top].fname,lcp); (*decide whether forw.*)
        if lcp <> nil then begin
          with lcp^ do begin
            if klass in [proc, func] then begin
              { id was declared earlier, error if it was not forward declared }
              if klass = proc then
                forw := forwdecl and (fsy=procsy) and (pfkind=actual)
              else
                forw := forwdecl and (fsy=funcsy) and (pfkind=actual);
              if not forw then begin
                {invalidate old declaration, use new one now}
                ignore := true;
                error(160)
              end;
            end; {if}
          end; {with}
        end; {if lcp <> nil}
      end; {if sy = ident ...}

      if not forw then begin
        { not forward declared --> enter new func or proc }
        if fsy = procsy then begin
          new(lcp,proc,declared,actual);
          lcp^.klass := proc;
        end
        else begin
          new(lcp,func,declared,actual);
          lcp^.klass := func;
        end;
        ininam(lcp);
        with lcp^ do begin
          pfdeckind := declared;
          pfkind := actual;
          if sy = ident then begin
            strassvf(name, id);
            asgn := false;
            refer := false;
          end
          else begin
            error(2);
            strassvf(name, '        ');
            asgn := true;  {avoid follow on errors}
            refer := true;
          end;
          idtype := nil;
          pfdeckind := declared; pfkind := actual;
          externl := false; pflev := level;
          dbg := funcDebug;
        end; {with}
        enterid(lcp)
      end
      else begin
        { was forward declared }
        lcp1 := lcp^.pflist;
        while lcp1 <> nil do begin
          lcp1 := lcp1^.next
        end
      end;
      if sy = ident then
        insymbol;

      oldlev := level; oldtop := top; {TODO: these should be the same}
      pushlvl(forw, lcp);

      parameterlist([semicolon,colon],lcp1);
      if not forw then
        lcp^.pflist := lcp1;
      if sy = colon then begin
        { determine type of function result }
        if fsy = procsy then
          error(14);
        insymbol;
        if sy = ident then begin
          { must not repeat function type for forward declared funcs }
          if forw then
            error(122);
          top := top-1; { correct scope for return type }
          searchid([types],lcp1);
          top := top+1;
          lsp := lcp1^.idtype;
          lcp^.idtype := lsp;
          { error if not valid return type }
          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 { no colon }
        if (fsy = funcsy) and not forw then error(123);

      if sy = semicolon then insymbol else error(14);

      if (sy = ident) and strequri('forward  ', id) then begin
        { this is a forward declaration }
        if forw then error(161)
        else begin
          lcp^.forwdecl := true;
          lforwcnt := lforwcnt+1;
          { write auto for forward declared nested functions }
          if lcp^.lev > 1 then
            write( prc, 'auto ' )
          else
            write( prc, 'static ');

          if lcp^.klass = proc then
            write( prc, 'void' )
          else
            genCType( lcp^.idtype, false );
          write( prc, ' ' );
          writeId( lcp );
          genCParams( lcp^.pflist, false );
          writeln(prc, ';' );
        end;
        insymbol;
        if sy = semicolon then insymbol else error(14);
        if not (sy in fsys) then
          begin error(6); skip(fsys) end
      end
      else if (sy = ident) and strequri('external ', id) then begin
        if forw then begin
          error(252);
          lforwcnt := lforwcnt - 1;
          lcp^.forwdecl := false;
        end
        else begin
          lcp^.externl := true;
          lcp^.pfname := stdNfalse; { not predeclared }
          lcp^.forwdecl := false;

          write( prc, 'extern ' );
          if lcp^.klass = proc then
            write( prc, 'void' )
          else
            genCType( lcp^.idtype, false );
          write( prc, ' ' );
          writeId( lcp );
          genCParams( lcp^.pflist, false );
          writeln(prc, ';' );
        end;
        insymbol;
        if sy = semicolon then insymbol else error(14);
        if not (sy in fsys) then
        begin error(6); skip(fsys) end;
      end
      else begin
        { not forward or external directive }
        if forw then begin
          lforwcnt := lforwcnt - 1;
        end;
        lcp^.forwdecl := false;
        { write function header }
        if lcp^.pflev = 1 then write( prc, 'static ');
        if lcp^.klass = proc then
          write( prc, 'void' )
        else
          genCType( lcp^.idtype, false );
        write( prc, ' ' );
        writeId( lcp );
        genCParams( lcp^.pflist, true );
        writeln(prc, ' {' );
        if lcp^.klass = func then begin
          if funcDebug then begin
            write( prc, 'struct { bool valid; ' );
            genCType( lcp^.idtype, false );
            writeln(prc, ' value; } $result', lcp^.pflev:1, ' = {.valid=0};' );
          end
          else begin
            genCType( lcp^.idtype, false );
            writeln(prc, '$result', lcp^.pflev:1, ';' );
          end;
        end; { if }

        { now initialise conformant arrays }
        lcp1 := lcp^.pflist;
        lsp := nil;
        while lcp1 <> nil do begin
          with lcp1^ do begin
            lcp2 := next;
            if isConfArray(idtype) then begin
              if lsp <> idtype then begin
                { param is start of a group, emit type }
                lsp := idType;
                //struct aa_3 {double component[hi_3+1-lo_3];} aa_3;
                genCType( idType, false );
              end; {if}
              if lcp1^.vkind = formal then write( prc, '*' ); {var parameter}
              writeId(lcp1);
              if (lcp2 <> nil) and (lcp2^.idType = lsp) then
                write( prc, ', ' )
              else
                writeln(prc, ';' ); { no more params in group }
            end; {if}
          end; {with}
          lcp1 := lcp2;
        end; {while}

        lcp1 := lcp^.pflist;
        while lcp1 <> nil do begin
          with lcp1^ do begin
            if isConfArray(idtype) then begin
              writeId(lcp1);
              if lcp1^.vkind = formal then begin {var parameter}
              // aa_3 = (typeof(aa_3))aa_3c;
                write( prc, ' = (typeof(' );
                writeId(lcp1);
                write( prc, '))' );
              end
              else begin
              // aa_3 = *(typeof(aa_3)*)aa_3c;
                write( prc, ' = *(typeof(' ); {value parameter}
                writeId(lcp1);
                write( prc, ')*)' );
              end;

              writeId(lcp1);
              writeln(prc, 'c; /* initialise conf array */' );
            end; {if}
          end; {with}
          lcp1 := lcp1^.next;
        end; {while}

        repeat
          block(fsys,semicolon,lcp);
          if sy = semicolon then begin
            if prtables then printtables(false);
            { write end of function }
            if display[level].hasFile then begin
              writeln(prc, '_Pcleanup();' );
              writeln(prc, '_Phead=_Pcudat.link;' );
            end;
            if lcp^.klass = func then begin
              if lcp <> ufctptr then
                if not lcp^.asgn then error(193); { no function result assign }
              if funcDebug then begin
                write( prc, 'if(!$result', lcp^.pflev:1, '.valid)',
                      '_Pfatal("function ''' );
                writev( prc, lcp^.name, lenpv(lcp^.name) );
                writeln(prc, ''' has no result", ', linecount:1, ');' );
                writeln(prc, 'return $result', lcp^.pflev:1, '.value;' );
              end
              else
                writeln(prc, 'return $result', lcp^.pflev:1, ';' );
            end; { if }
            write( prc, '} /* ' );
            writeId( lcp );
            writeln(prc, '() */' );

            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(prd);
      end;
      level := oldlev; putdsps(oldtop); top := oldtop;
    end (*procdeclaration*) ;


    { hunt thru id tree for undeclared forward references }
    procedure checkforw(fcp: ctp);
    begin
      if fcp <> nil then
        with fcp^ do begin
          checkforw(llink);
          if klass in [proc,func] then
            if pfdeckind = declared then
              if pfkind = actual then
                if forwdecl then begin
                  write(output, '**** undeclared forward routine: ' );
                  writev(output, name, lenpv(name) ); writeln(output);
                end;
          checkforw(rlink);
        end; { with }
    end; { checkforw }


    procedure body(fsys: setofsys);
      var
          llcp:ctp; saveid:idstr;
          llp: lbp;
          fp: extfilep;
          test: boolean;
          printed: boolean;

      { add statement level }
      procedure addlvl;
      begin
        stalvl := stalvl+1;
      end;

      { remove statement level }
      procedure sublvl;
      var llp: lbp;
      begin
         stalvl := stalvl-1;
         { traverse label list for current block and remove any label from
           active status whose statement block has closed }
         llp := display[top].flabel;
         while llp <> nil do with llp^ do begin
           if slevel > stalvl then bact := false;
           if refer and (minlvl > stalvl) then
             minlvl := stalvl;
           llp := nextlab { link next }
         end
      end;


    {generate code to close all files in type fty
     prVar is supplied procedure to print the variable}
    procedure genCloseFiles(fty : stp; procedure prVar );
    type
      chainp =  ^chain;  {types for building c declarations of the files}
      chain  = record
                 next : chainp;
                 ty   :stp;
               end;
    var
      head       : chainp;
      arrayCount : integer;

    procedure buildTypeChain(x: chainp; procedure prParent );
    var
      t,t1   : chainp;
      lo, hi : integer;
      lsp    : stp;

    {output the file reference}
    procedure genFileRef(x: chainp );
    begin
      if x = nil then
        prParent
      else begin
        with x^ do begin
          genFileRef(next);  {the parent}
          if ty^.form = arrays then begin
            write( prc, '.component[$i', arrayCount:1, ']' );
            arrayCount := arrayCount+1;
          end
          else  if ty^.form = records then begin
            write( prc, '.' );
          end;
        end; {with}
      end; {if}
    end; { genFileRef }

    procedure bRec(n : ctp; x: chainp );
    var
      t : chainp;
      procedure prn;
      begin
        genFileRef(x); writeId(n); end;
    begin
      if n <> nil then begin
        new(t);
        t^.ty := n^.idtype; t^.next := nil;
        buildTypeChain(t, prn);
        dispose(t);
        bRec(n^.llink, x);
        bRec(n^.rlink, x);
      end;
    end; { bRec }

    begin {buildTypeChain}
      lsp := x^.ty;
      if lsp^.form = files then begin
        write( prc, '_Pclose_file((text*)&' );
        arrayCount := 0;
        genFileRef(x);
        writeln(prc, ');' );
      end
      else if filecomponent(lsp) then begin
        if lsp^.form = arrays then begin
          getbounds(lsp^.inxtype, lo, hi);
          writeln(prc, '{ int $i', arrayCount:1, '; for($i', arrayCount:1, '=0',
                  '; $i', arrayCount:1, '<=', hi-lo:1,
                  '; $i', arrayCount:1, '++) {' );
          arrayCount := arrayCount+1;
          new(t);
          t^.next := x;
          t^.ty := lsp^.aeltype;
          buildTypeChain(t, prparent);
          t1 := t;
          t := t^.next;
          dispose(t1);
          arrayCount := arrayCount-1;
          writeln(prc, '}} // for $i', arrayCount:1 );
        end
        else if lsp^.form = records then begin
          bRec( lsp^.fstfld, x );
        end;
      end;
    end; { buildTypeChain }

    begin {genCloseFiles}
      if toterr = 0 then begin
        arrayCount := 0;
        new(head); head^.next := nil;
        head^.ty := fty;
        buildTypeChain( head, prVar );
        dispose( head );
      end;
    end;{genCloseFiles}

      procedure statement(fsys: setofsys);
        var lcp: ctp; llp  : lbp;
            mergeFixedSets : boolean;
        { TODO: maybe attr could go here eventually }


        procedure genCExpr(t : exprTreePtr ); forward;

        procedure genSetPtr(se : exprTreePtr );
        begin
          if se^.n = tmpSetNode then begin
            write(prc, '$setTmp', se^.setNr:1);
          end
          else begin
            genCExpr(se);
            write(prc, '.element');
          end;
        end; { genSetPtr }

        {TODO: for gcc >= 4.9 use __auto_type? see __GNUC__ & __GNUC_MINOR__}
        procedure genTypeOf(t : exprTreePtr );
        var savChkVar, savMemDebug, savDebug : boolean;
        begin
          savChkVar := chkvar;
          savMemDebug := memDebug;
          savDebug := debug;
          chkvar := false;
          memDebug :=false;
          debug := false;
          write( prc, 'typeof(' );
          genCExpr( t );
          write( prc, ')' );
          chkvar := savChkVar;
          memDebug :=savMemDebug;
          debug := savDebug;
        end;

        { generate file pointer declaration }
        procedure genfp(fType : stp; fParent : exprTreePtr );
        begin
          if fType <> nil then begin
            if fType = textptr then
              write( prc, 'text ' )
            else if fType^.typeName = nil then begin
              genTypeOf(fParent);
            end
            else begin
              genCType( fType, false );
            end;
            write( prc, ' *const $fp = &' );
            genCExpr( fParent );
            writeln(prc, ';' );
          end;
        end; { genfp }

        { fatal error if file is not defined }
        procedure checkdefined;
        begin
          if debug then begin
            writeln(prc, 'if($fp->f == NULL) _Pfatal("file is undefined",',
                            linecount:1, ' );' );
          end;
        end; { checkdefined }


        { fatal error if file is not writable }
        procedure checkWritable;
        begin
          if debug then begin
            { assume fp has been generated }
            { opened for writing iff flags >= 0 }
            writeln(prc, 'if($fp->flags >= 0) _Pfatal( "writing to file opened for input", ', linecount:1, ' );' );
          end;
        end; { checkWritable }

        { fatal error if file is not readable }
        procedure checkReadable;
        begin
          if debug then begin
            { assume fp has been generated }
            { opened for reading iff flags < 0 }
            writeln(prc, 'if($fp->flags < 0) _Pfatal( "reading from file opened for output", ', linecount:1, ' );' );
          end;
        end; { checkReadable }

        function checkSet(t : exprTreePtr; a, b: integer): boolean; forward;


        {add lists in set at expression t^ to set $si}
        procedure addLists(t : exprTreePtr;
                           loBound, hiBound: integer;
                           i : integer );
        var
           v1          : varElementPtr;
           c1          : constElementPtr;
        begin
          if (t <> nil) and (t^.n = setNode) then begin
            with t^ do begin

              v1 := varList;
              { add the var part, one element at a time, checking the range  }
              while v1 <> nil do begin
                with v1^ do begin
                  writeln(prc, '{' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                  if isRange then begin
                    write( prc, 'int $l = ' );
                    genCExpr( elvalue );
                    writeln(prc, '; if( $l<', loBound:1, ' ) $l=', loBound:1, ';' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    write( prc, 'int $h = ' );
                    genCExpr( hiValue );
                    writeln(prc, '; if( $h>', hiBound:1, ' ) $h=', hiBound:1, ';' );
                    writeln(prc, 'const int $loPos = ($l>>3) - (', loBound:1, '>>3);' );
                    writeln(prc, 'const int $loMask = (~0<<($l&7));' );

                    writeln(prc, 'const int $hiPos = ($h>>3) - (', loBound:1, '>>3);' );
                    writeln(prc, 'const int $hiMask = ((uint8_t)~0)>>(7-($h&7));' );

                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, 'if( $hiPos==$loPos) $s', i:1, '[$hiPos] |= ($hiMask&$loMask);' );
                    writeln(prc, 'else if( $hiPos>$loPos) {' );
                    writeln(prc, 'int $i;' );
                    writeln(prc, '$s', i:1, '[$hiPos] |= $hiMask;' );
                    writeln(prc, '$s', i:1, '[$loPos] |= $loMask;' );
                    writeln(prc,
                            'for( $i=$loPos+1; $i<$hiPos; $i++ ) $s', i:1, '[$i] = (uint8_t)~0;}' );
                  end
                  else begin
                    write( prc, '({ const int $e = ' );
                    genCExpr( elvalue );
                    writeln(prc, ';' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    {insert element if it is in range}
                    writeln(prc, 'if( $e>=', loBound:1, ' && $e<=', hiBound:1,
                            ' ) $s', i:1, '[($e>>3) - (', loBound:1,
                            '>>3)] |= (1<<($e&7)); });' );
                  end;
                  writeln(prc, '}' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                end; { with }
                v1 := v1^.next;
              end;

              { add the const part }
              {TODO: sort the list into a binary tree, merge elements together}
              c1 := constList;
              while c1 <> nil do begin
                with c1^ do begin
                  if isRange then begin
                    { TODO: optimise this }
                    writeln(prc, '{' );
                    if elvalue < loBound then begin
                      writeln(prc, 'const int $loPos = 0;' );
                      writeln(prc,
                              'const int $loMask = (~0<<(', loBound:1, '&7));' );
                    end
                    else begin
                      writeln(prc, 'const int $loPos = (', elvalue:1, '>>3) - (',
                              loBound:1, '>>3);' );
                      writeln(prc,
                              'const int $loMask = (~0<<(', elvalue:1, '&7));' );
                    end;
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    if hiValue > hiBound then begin
                      writeln(prc, 'const int $hiPos = (', hiBound:1, '>>3) - (',
                              loBound:1, '>>3);' );
                      writeln(prc, 'const int $hiMask = ',
                              '((uint8_t)~0)>>(7-(', hiBound:1, '&7));' );
                    end
                    else begin
                      writeln(prc, 'const int $hiPos = (', hiValue:1, '>>3) - (',
                              loBound:1, '>>3);' );
                      writeln(prc, 'const int $hiMask = ',
                              '((uint8_t)~0)>>(7-(', hiValue:1, '&7));' );
                    end;
                    if lnflag then writeln(prc, '#line ', linecount:1);

                    writeln(prc,
                            'if( $hiPos==$loPos) $s', i:1,
                            '[$hiPos] |= ($hiMask&$loMask);' );
                    writeln(prc, 'else if( $hiPos>$loPos) {' );
                    writeln(prc, 'int $i;' );
                    writeln(prc, '$s', i:1, '[$hiPos] |= $hiMask;' );
                    writeln(prc, '$s', i:1, '[$loPos] |= $loMask;' );
                    writeln(prc,
                            'for( $i=$loPos+1; $i<$hiPos; $i++ ) $s', i:1,
                            '[$i] = (uint8_t)~0;}' );
                    writeln(prc, '}' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                  end
                  else begin
                    if (elvalue >= loBound) and  (elvalue <= hiBound) then begin
                      writeln(prc, '$s', i:1, '[(', elvalue:1, '>>3) - (',
                              loBound:1, '>>3)] |= (1<<(',
                              elvalue:1, '&7));' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                    end
                    else begin
                      { value lies outside dest range }
                    end;
                  end;
                end;
                c1 := c1^.next;
              end; {while}
            end; {with}
          end; {if t <> nil}
        end; { addLists }


        { construct a set into destination, si, i = 0, 1, 2, ...
          loBound, hiBound : destination set bounds
          extression tree, t, is the source. It is a :
            - setNode   : a pascal set variable, or
            - setOpNode : an operator with expression subtrees
          caller supplies destination, uint8_t *$si }

        procedure constructSet(t : exprTreePtr;
                                 loBound, hiBound: integer;
                                 i : integer );
         var
           lo0, hi0    : integer;   { bounds of the copy }
           lo1, hi1    : integer;   { bounds of the source }
           savLo,savHi : integer;   { save res bounds }
         begin

           { note: we use >>3 to divide by 8 because it gives the correct
             answer when the numbers are -ve }

           writeln(prc, '/* dest bounds are ', loBound:1, ' .. ', hiBound:1, ' */' );
           if lnflag then writeln(prc, '#line ', linecount:1);
           with t^ do begin
             if n = setNode then begin
               if sparent <> nil then begin
                 { copy the set part to the destination, checking size & range }
                 { check: set is not empty set or set of integer }
                 getbounds( seltype, lo1, hi1 );
                 writeln(prc, '/* src bounds are ', lo1:1, '..', hi1:1, ' */' );

                 { if the src is smaller than the dest, clear dst first }
                 if ( hi1 < hiBound ) or ( lo1 > loBound ) then
                   writeln(prc, 'memset($s', i:1,
                           ', 0, (', hiBound:1, '>>3)-(', loBound:1, '>>3)+1 );' );
                 if lnflag then writeln(prc, '#line ', linecount:1);
                 if hiBound < hi1 then
                   hi0 := hiBound
                 else
                   hi0 := hi1;
                 if loBound > lo1  then
                   lo0 := loBound
                 else
                   lo0 := lo1;

                 if lo0 <= hi0 then begin
                   { copy the set part.
                   Note that sets cannot overlap, but, we could copy a set onto
                   itself - eg in the generated code for a := a + [1,2,3].
                   So use memmove rather than memcpy.}
                   write( prc, 'memmove($s', i:1,
                         '+(', lo0:1, '>>3)-(', loBound:1, '>>3), ' ); { dest }

                   genSetPtr(sparent);        { src }
                   writeln(prc, '+(', lo0:1, '>>3)-(', lo1:1, '>>3), (', hi0:1, '>>3)-(', lo0:1, '>>3)+1);' ); { len }

                   if lnflag then writeln(prc, '#line ', linecount:1);
                   { the bytes have been copied, but clear the the dest
                     if it doesn't extend to the byte boudaries }
                   writeln(prc, '$s', i:1, '[0]&=(~0<<(', loBound:1, '&7));' );
                   writeln(prc, '$s', i:1, '[(', hiBound:1, '>>3)-(', loBound:1,
                           '>>3)]&=((uint8_t)~0)>>(7-(', hiBound:1, '&7));' );
                 end
               end
               else begin
                 { no set part, just lists }
                 writeln(prc, 'memset($s', i:1, ', 0, (',
                              hiBound:1, '>>3)-(', loBound:1, '>>3)+1 );' );
               end;
               if lnflag then writeln(prc, '#line ', linecount:1);

               addLists(t, loBound, hiBound, i);

             end {if n = setnode}

             else if n = setOpNode then begin
               resNr := i;
               savHi := resHi;
               savLo := resLo;
               resHi := hiBound;
               resLo := loBound;
               genCExpr( t );
               resHi := savHi;
               resLo := savLo;
             end
             else
               writeln(prc, '>>> ConstructSet: unexpected node kind(', ord(n):1, ')' );
           end; { with }

         end; { constructSet }


        { determine set size of set op, given setOpNode
        result is determined by the op and size of children }
         procedure findResBounds( t: exprTreePtr );
         var
           resHiLeft, resHiRight : integer;
           resLoLeft, resLoRight : integer;
         begin
           with t^ do begin
             if n <> setOpNode then begin
               writeln(prc, '>>> setOpNode expected' );
             end
             else begin
               if setLeft^.n = setopNode then begin
                 resHiLeft := setLeft^.resHi;
                 resLoLeft := setLeft^.resLo;
               end
               else begin
                 with setLeft^ do begin
                   resHiLeft := -maxintTarget;
                   resLoLeft := maxintTarget;
                   if n = setNode then begin
                     if selType = nil then begin
                       write( prc, ' /* >>> left set empty */ ' );
                     end
                     else begin
                       getbounds( selType, resLoLeft, resHiLeft );
                       if constList <> nil then begin
                         if sparent = nil then begin
                           resLoLeft := listLo;
                           resHiLeft := listHi;
                         end
                         else begin
                           if resLoLeft > listLo then
                             resLoLeft := listLo;
                           if resHiLeft < listHi then
                             resHiLeft := listHi;
                         end;
                       end; {if constlist}
                       if varlist <> nil then begin
                         if seltype^.form = subrange then
                           getbounds(seltype^.rangeType, resLoLeft, resHiLeft)
                         else
                           getbounds(seltype, resLoLeft, resHiLeft);
                       end;
                     end;
                   end; {if setNode}
                 end; {with}
               end; {set left}

               if setRight^.n = setopNode then begin
                 resHiRight := setRight^.resHi;
                 resLoRight := setRight^.resLo;
               end
               else begin
                 with setRight^ do begin
                   resHiRight := -maxintTarget;
                   resLoRight := maxintTarget;
                   if n = setNode then begin
                     if selType = nil then begin
                       write( prc, ' /* >>> right set empty */ ' );
                     end
                     else begin
                       getbounds( selType, resLoRight, resHiRight );
                       if constList <> nil then begin
                         if sparent = nil then begin
                           resLoRight := listLo;
                           resHiRight := listHi;
                         end
                         else begin
                           if resLoRight > listLo then
                             resLoRight := listLo;
                           if resHiRight < listHi then
                             resHiRight := listHi;
                         end;
                       end; {if constlist}
                       if varlist <> nil then begin
                         if seltype^.form = subrange then
                           getbounds(seltype^.rangeType, resLoRight, resHiRight)
                         else
                           getbounds(seltype, resLoRight, resHiRight);
                       end;
                     end;
                   end; {if setNode}
                 end; {with}
               end; {setRight}

               { new bounds depend on setOpKind }
               if setOpKind = minus then begin
                 { set difference, keep left bounds }
                 resHi := resHiLeft;
                 resLo := resLoLeft;
               end
               else if setOpKind = mul then begin
                 { set intersection, keep common range }
                 if resHiRight < resHiLeft then
                   resHi := resHiRight
                 else
                   resHi := resHiLeft;
                 if resLoRight > resLoLeft then
                   resLo := resLoRight
                 else
                   resLo := resLoLeft;
               end
               else if setOpKind = leop then begin
                 { compare only inside left bounds }
                 resHi := resHiLeft;
                 resLo := resLoLeft;
               end
               else if setOpKind = geop then begin
                 { compare only inside right bounds }
                 resHi := resHiRight;
                 resLo := resLoRight;
               end
               else begin
                 { plus, eq, ne compare across combined range }
                 if resHiRight > resHiLeft then
                   resHi := resHiRight
                 else
                   resHi := resHiLeft;
                 if resLoRight < resLoLeft then
                   resLo := resLoRight
                 else
                   resLo := resLoLeft;
               end;

               if (resHi = maxintTarget)
                 and (resLo = -maxintTarget) then
                 write( prc, ' /* >>> indeterminate set */' )
               else
                 write( prc, ' /* [', resLo:1, '..', resHi:1, '] 0 */ ' );
             end; { if setOpNode }

           end; { with }

         end; { findResBounds }


         procedure freeTree(t : exprTreePtr); forward;

         procedure genCExpr;
         var
           lo, hi          : integer;
           savLo,savHi     : integer;   { save res bounds }
           t1              : exprTreePtr;
           parPtr          : pfParamPtr;
           lsp, lsp1, lsp2 : stp;
           test            : boolean;
           sav             : boolean;
           first, second   : exprTreePtr;

         { check if element e is member of a set
           integer var e has been generated,
           t is the expr tree of sets to check. It is either
             - a variable (leaf), or
             - an operator with 2 subtrees
           generate an expression which is either 0 or 1
           check each part of an expression individually.
           This avoids not only the cost of evaluating the result set,
           but also needing to know the size of the result set
         }
         procedure isMember(t : exprTreePtr );
         var
           lo, hi        : integer;
           v1            : varElementPtr;
           c1            : constElementPtr;
         begin
           write( prc, '(0 ' );
           if t <> nil then with t^ do begin

             if n = setOpNode then begin
               { this node is a set op }

               {
                 x is in (u+v) iff it is in u or in v;
                 x is in u-v iff it is in u and not in v;
                 x is in u*v iff it is in u and in v.
               }

               if setOpKind = plus then begin
                 write( prc, '/*@ (in) set->+ node*/');
                 write( prc, ' || ' );
                 isMember( setLeft );
                 write( prc, ' || ' );
                 isMember( setRight );
               end
               else if setOpKind = minus then begin
                 write( prc, '/*@ (in) set->- node*/');
                 write( prc, ' || ((' );
                 isMember( setLeft );
                 write( prc, ') && !(' );
                 isMember( setRight );
                 write( prc, '))' );
               end
               else if setOpKind = mul then begin
                 write( prc, '/*@ (in) set->* node*/');
                 write( prc, ' || ((' );
                 isMember( setLeft );
                 write( prc, ') && (' );
                 isMember( setRight );
                 write( prc, '))' );
               end
               else begin
                 writeln(prc, '>>> unknown set operator: ', ord(setOpKind):1);
               end;
             end
             else if n = setNode then begin { it's a setNode }

               { first check the set variable }
               write( prc, '/*@ (in) set test set node */');
               if sparent <> nil then begin
                 { s =  address of the set }
                 { TODO: check set is not empty set or set of integer }
                 getbounds( seltype, lo, hi );
                 write( prc, ' || (($e>=', lo:1, ') && ($e<=', hi:1, ') && ((' );
                 genSetPtr( sparent );
                 writeln(prc, '[($e>>3) - (',
                         lo:1, '>>3)] & (1<<($e&7))) != 0 ))' );
                 if lnflag then writeln(prc, '#line ', linecount:1);

               end;

               { now check the lists }
               v1 := varList;


               while v1 <> nil do begin
                 with v1^ do begin
                   if isRange then begin
                     write( prc, ' || (( $e >= ' );
                     genCExpr( elvalue );
                     write( prc, ' &&  $e <= ' );
                     genCExpr( hiValue );
                     write( prc, ' ))' );
                   end
                   else begin
                     write( prc, ' || $e == ' );
                     genCExpr(elvalue);
                   end;
                 end;
                 v1 := v1^.next;
               end;

               { TODO: only for fewer than say, 4 elements }
               { more than 4 constants }
               { construct a set, get size from range of lhs}
               { TODO: would a switch statement be better here? }
               c1 := constList;
               while c1 <> nil do begin
                 with c1^ do begin
                   if isRange then begin
                     write( prc, ' || ( $e >= ', elvalue:1, ' &&   $e <= ', hivalue:1, ' )' );
                   end
                   else begin
                     write( prc, ' || $e == ', elvalue:1 );
                   end;
                 end;
                 c1 := c1^.next;
               end; { while }
             end

             else begin
               writeln(prc, '>>> set expression expected (3), node is ',
                                  ord(n):1 )
             end;

           end; { with }
           write( prc, ')' );
         end; { isMember }

         { is the node a standard maths function - sin, cos, exp, etc }
         function isStdMaFun(node : ctp; fn: tStdNames): boolean;
         begin
           with node^ do begin
             isStdMaFun := (pfkind = actual) and externl and (pfname = fn);
           end;
         end; { isStdMaFun }

         begin { genCExpr() }
            { generate code for the expression tree }

           if t <> nil then begin
             with t^ do begin
               { write( prc, '/* wr code ', ord(n):1, ' ... */' ); }
               case n of
                 binOpNode : begin
                     { TODO: optimise parens }
                     write( prc, '(' );

                     if binOpKind = imod then begin
                       write( prc, '{ const int $d = ' );
                       genCExpr(right);
                       writeln(prc, ';');
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       if debug then
                         writeln(prc, 'if($d==0) _Pfatal("zero divisor in mod", ',
                                 linecount:1, ');' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       write( prc, 'const int $a = ');
                       genCExpr(left);
                       writeln(prc, ' % $d;');
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       write( prc, '($d>0)? (($a>=0)? $a: $a+$d): ($a>0? $a+$d: $a);' );
                       writeln(prc, '}' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end
                     else if debug and (binOpType=intptr)
                       and (binOpKind in [plus,minus,mul])
                     then begin
                       write( prc, '{const int $a=' );
                       genCExpr(left);
                       write( prc, ', $b=' );
                       genCExpr(right);
                       case binopkind of
                         plus : begin
                            {overflow if the two integers have the same sign,
                             and the result has the opposite sign}
                             writeln(prc, '; const int $res=$a+$b;' );
                             writeln(prc,
                               'if(((~($a^$b))&($a^$res)) < 0)',
                               ' _Pfatal("integer overflow on add", ',
                                linecount:1, ')' );
                           end;
                         minus : begin
                             {overflow when the signs are opposite and
                              the result has the opposite sign of a}
                             writeln(prc, '; const int $res=$a-$b;' );
                             writeln(prc,
                               'if((($a^$b)&($a^$res)) < 0)',
                               ' _Pfatal("integer overflow on subtract", ',
                                linecount:1, ')' );
                           end;
                         mul : begin
                                 {Signed multiplication overflow check:
                                   (a > 1 && (b > MAX/a || b < MIN/a)) ||
                                   (a < -1 && (b > MIN/a || b < MAX/a)) ||
                                   (a == -1 && b == MIN)}
                             writeln(prc, '; const int $res=$a*$b;' );
                             writeln(prc,
                               'if(($b>1 && ($a>INT_MAX/$b || $a<INT_MIN/$b)) ||',
                                 '($b<-1 && ($a>INT_MIN/$b || $a<INT_MAX/$b)) ||',
                                 '($b==-1 && $a==INT_MIN) )',
                                 ' _Pfatal("integer overflow on multiply", ',
                                linecount:1, ')' );
                           end;
                       end; {case}
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       write( prc, '; $res;}' );
                     end
                     else begin
                       genCExpr(left);
                       case binOpKind of
                         mul   : write( prc, ' * ' );
                         rdiv  : write( prc, ' / (double)' );
                         idiv  : write( prc, ' / (int)' );
                         andop : write( prc, ' && ' );
                         plus  : write( prc, ' + ' );
                         minus : write( prc, ' - ' );
                         orop  : write( prc, ' || ' );

                         ltop : write( prc, ' < ' );
                         leop : write( prc, ' <= ' );
                         gtop : write( prc, ' > ' );
                         geop : write( prc, ' >= ' );
                         neop : write( prc, ' != ' );
                         eqop : write( prc, ' == ' );
                       end; { case }
                       if debug and (binOpKind = idiv) then begin
                         { check for error if divide by zero }
                         write( prc, '({ int $d = ' );
                         genCExpr(right);
                         writeln(prc, ';');
                         if lnflag then writeln(prc, '#line ', linecount:1);
                         writeln(prc,
                                 'if($d==0) _Pfatal("integer division by zero",',
                                 linecount:1, ');');
                         writeln(prc, ' $d;})' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                       end
                       else if debug and (binOpKind = rdiv) then begin
                         { check for error if divide by zero }
                         write( prc, '({ double $d = ' );
                         genCExpr(right);
                         writeln(prc, ';');
                         writeln(prc, 'if(fabs($d)<=0) _Pfatal("real division by zero",',
                                         linecount:1, ');');
                         writeln(prc, ' $d;})' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                       end
                       else begin
                         write(prc, '(');
                         genCExpr(right);
                         write(prc, ')');
                       end;
                     end;
                     write( prc, ')' );
                   end;

                 strOpNode: begin
                     { string compare }
                     write( prc, '(strncmp(' );
                     genCExpr( strLeft );
                     if lvar then
                       write( prc, '.component' );
                     write( prc, ', ' );
                     genCExpr( strRight );
                     if rvar then
                       write( prc, '.component' );
                     write( prc, ', ', slen, ') ' );

                     case strOpKind of
                       ltop : write( prc, '< 0' );
                       leop : write( prc, '<= 0' );
                       gtop : write( prc, '> 0' );
                       geop : write( prc, '>= 0' );
                       neop : write( prc, '!= 0' );
                       eqop : write( prc, '== 0' );
                     end; { case }
                     write( prc, ')' );
                   end;

                 setOpNode: begin

                   {  set operator: =, -, *, =, <>, <=, >=
                      a set temp var called si should already exist,
                         where i = resNr
                      a node, leaf, set should have been dealt with
                      by the caller, so genCExpr() does not deal with them
                   }

                   if setOpKind = inop then begin
                     write( prc, '({ const int $e = ' );
                     genCExpr( setLeft );
                     writeln(prc, ';' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                     isMember( setRight );
                     writeln(prc, ';})' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                   end {inop}

                   else if {false and} (setOpKind = plus) then begin
                     { s1 + s2 -> s1 or s2 }
                     { left & right children can be setNode leaves
                       or operators
                       each can have set data and/or lists
                     }

                     {if one side is just lists, do the other one first,
                     then add only lists to first set.
                     This avoids creating an empty set}
                     with setLeft^ do begin
                       if (n = setNode) and (sparent = nil)
                         then begin
                           write( prc, '/* @+swapped left & right*/ ');
                           first := t^.setRight;
                           second := t^.setLeft;
                         end
                         else begin
                           first := t^.setLeft;
                           second := t^.setRight;
                         end;
                     end;

                     if first^.n = setOpNode then begin
                       savHi := first^.resHi;
                       savLo := first^.resLo;
                       first^.resNr := resNr;
                       first^.resHi := resHi;
                       first^.resLo := resLo;
                       write( prc, '/*@+set->left op node*/');
                       genCExpr( first );
                       first^.resHi := savHi;
                       first^.resLo := savLo;
                     end
                     else if first^.n = setNode then begin
                       write( prc, '/*@+set construct left set*/');
                       constructSet( first, resLo, resHi, resNr );
                     end;

                     {check if this set has just lists}
                     if (second^.n = setNode) and (second^.sparent=nil)
                     then begin
                         addLists( second, resLo, resHi, resNr )
                     end
                     else begin
                       writeln(prc, '({uint8_t $s', resNr+1:1,
                               '[(', resHi:1, '>>3)-(', resLo:1, '>>3)+1]; ' );

                       if lnflag then writeln(prc, '#line ', linecount:1);
                       if second^.n = setNode then begin
                         write( prc, '/*@+set construct right set*/');
                         constructSet( second, resLo, resHi, resNr+1 );
                       end
                       else if second^.n = setOpNode then begin
                         savHi := second^.resHi;
                         savLo := second^.resLo;
                         second^.resNr := resNr+1;
                         second^.resHi := resHi;
                         second^.resLo := resLo;
                         write(prc, '/*@+set-> right op node*/ ');
                         genCExpr( second );
                         second^.resHi := savHi;
                         second^.resLo := savLo;
                       end;

                       { add the sets together }
                       writeln(prc, '({ int $i;' );
                       writeln(prc,  'for($i=0; $i<=(', resHi:1, '>>3)-(', resLo:1,
                               '>>3); ++$i)' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       writeln(prc, '$s', resNr:1, '[$i] |= $s',
                                    resNr+1:1, '[$i];});' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       writeln(prc, '}); // $s' , resNr+1:1 );

                     end; {if not just lists}

                   end { if plus }

                   else if setOpKind in [plus,minus,mul] then begin
                     constructSet( setLeft, resLo, resHi, resNr );
                     writeln(prc, '({uint8_t $s', ResNr+1:1,
                             ' [(', resHi:1, '>>3)-(', resLo:1, '>>3)+1]; ' );

                     writeln(prc, 'int $i;' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                     constructSet( setRight, resLo, resHi, resNr+1 );
                     writeln(prc,  'for($i=0; $i<=(', resHi:1, '>>3)-(',
                             resLo:1, '>>3); ++$i)' );
                     if lnflag then writeln(prc, '#line ', linecount:1);

                     if setOpKind = minus then begin
                       { s1 - s2 -> s1 and not s2 }
                       writeln(prc, '$s', resNr:1, '[$i] &= ~$s', resNr+1:1, '[$i];' );
                     end
                     else if setOpKind = mul then begin
                       { s1 * s2 -> s1 and s2 }
                       writeln(prc, '$s', resNr:1, '[$i] &= $s', resNr+1:1, '[$i];' );
                     end
                     else if setOpKind = plus then begin
                       writeln(prc, '$s', resNr:1, '[$i] |= $s', resNr+1:1, '[$i];' );
                     end;

                     writeln(prc, '});' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                   end

                   else begin
                     { set compare }

                     if resLo > resHi then begin
                       {compare empty sets}
                       if setOpKind = neop then
                         write( prc, ' 0 ')
                       else
                         write( prc, ' 1 ');
                       writeln(prc, ' // comparing empty sets!' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end

                     else if algSet and
                       (((resLO<0) and (resHi>=maxint+resLo)) or {avoid overflow}
                        (resHi - resLo >= 2*setmax+1))
                     then begin
                       { $Z+ option selected, and unknown or large set
                         ==> analytic compare }
                       error(-3);

                       {analytic set compare can generate huge amounts
                       of code for large set expressions.
                       merging can reduce this considerably, but then
                       we must restore it, otherwise
                       set range detection at compile time is degraded.}
                       sav := mergeFixedSets;
                       mergeFixedSets := true;
                       write(prc, '({ bool $r=0;');

                       if setOpKind in [geop, leop] then begin
                         {change a <= b to checkset(a-b,-M,M) }
                         {change a >= b to checkset(b-a,-M,M) }
                         write(prc, '/*== replacing ' );
                         if setOpKind = geop then write(prc, '>')
                         else write(prc, '<');
                         write(prc, '= with set ''-'' */');
                         if setOpKind = geop then begin
                           t1 := setleft;
                           setLeft := setRight;
                           setRight := t1;
                         end;
                         setOpKind := minus;
                         if checkSet(t, maxinttarget, -maxinttarget) then
                           write(prc, '0')
                         else begin
                           write(prc, '!$r');
                         end;
                       end
                       else begin
                         {change a <> b  to not checkset(a-b + b-a,-M,M) }
                         {change a = b  to checkset(a-b + b-a,-M,M) }
                         write( prc,' /* indeterminate compare eq/ne */ ' );
                         new(t1, setOpnode);
                         with t1^ do begin
                           n := setOpNode;
                           setOpKind := plus;
                           locked := true; {xxx hack}
                           resLo := -maxintTarget;
                           resHi := maxintTarget;
                           new(setLeft, setOpNode);
                           with setleft^ do begin
                             n := setOpNode;
                             setOpKind := minus;
                             locked := true;
                             setleft := t^.setLeft;
                             setRight := t^.setRight;
                           end; {with}
                           findResBounds(setLeft);
                           new(setRight, setOpNode);
                           with setRight^ do begin
                             n := setOpNode;
                             setOpKind := minus;
                             locked := true;
                             setleft := t^.setRight;
                             setRight := t^.setLeft
                           end; {with}
                           {xxx contradict res bounds for other branch
                           ==> move them to where they are used?
                           resBounds used only to construct sets for compare?}
                           findResBounds(setRight);
                         end; {with}
                         if checkSet(t1, maxinttarget, -maxinttarget) then begin
                           if setOpkind = eqOp then write(prc, '0')
                           else write(prc, '1')
                         end
                         else begin
                           if setOpkind = eqOp then write(prc, '!');
                           write(prc, '$r');
                         end;

                         {done, now tidy up}
                         with t1^ do begin
                           if setleft^.n = setNode then begin
                             freeTree(setleft)
                           end
                           else
                             dispose(setLeft);
                           if setright^.n = setNode then begin
                             freeTree(setright);
                           end
                           else
                             dispose(setRight);
                         end; {with}
                         dispose(t1);
                       end; {eqOp, neOp}

                       mergeFixedSets := sav;
                       writeln(prc, ';}) // analytic set compare' );
                     end {analytic set compare}

                     else begin
                       lo := resLo; hi := resHi;
                       if (hi = maxintTarget) and (lo = -maxintTarget)
                       then begin
                         hi := setmax;
                         lo := -setMax;
                         error(-2); {unknown set size}
                         write(prc,' /* >>> integer set bounds limited to ',
                                 lo:1, '..', hi:1, ' */ ' );
                       end;

                       writeln(prc, '({uint8_t $s0[(', hi:1, '>>3)-(',
                               lo:1, '>>3)+1]; ' );
                       writeln(prc, 'uint8_t $s1[(', hi:1, '>>3)-(',
                                 lo:1, '>>3)+1]; ' );
                       writeln(prc, 'int $i; bool $r=1;' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       constructSet( setLeft, lo, hi, 0 );
                       constructSet( setRight, lo, hi, 1 );
                       writeln(prc, 'for($i=0; $i<=(', hi:1, '>>3)-(',
                                 lo:1, '>>3); ++$i)' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       case setOpKind of
                         ltop, gtop :
                             writeln(prc, '> & < not implemented' );
                         leop : begin
                             writeln(prc,
                                 'if(($s0[$i] & ~$s1[$i]) != 0) { $r=0; break; }; $r' );
                           end;
                         geop : begin
                             writeln(prc,
                                    'if((~$s0[$i] & $s1[$i]) != 0) { $r=0; break; }; $r' );
                           end;
                         neop : begin
                             writeln(prc,
                                   'if($s0[$i] != $s1[$i]) { $r=0; break; }; !$r' );
                           end;
                         eqop : begin
                            writeln(prc,
                               'if($s0[$i] != $s1[$i]) { $r=0; break; }; $r' );
                           end;
                       end; { case }
                       writeln(prc, ';})' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end; {determinate sets}
                   end; {set compare}
                 end; { setopNode }

                 unopNode  : begin
                     if debug and (unOpKind = minusOpi) then begin
                       {error for negate -(maxint+1)}
                       write(prc, '({ const int $a = ' );
                       genCExpr( operand );
                       writeln(prc, ';' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       writeln(prc, 'if($a<', -maxintTarget:1,
                                    ') _Pfatal("-(-maxint-1) overflows", ',
                                    linecount:1, ');' );
                       writeln(prc, '-$a;})' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end
                     else begin
                       if unOpKind = parenOp then
                         write( prc, '(' )
                       else if unOpKind in [minusOp, minusOpi] then
                         write( prc, '-(' )
                       else if unOpKind = notOp then
                         write( prc, '!(' );
                       genCExpr( operand );
                       write( prc, ')' )
                     end;
                   end;

                 constNode : begin               { ---------- constant }
                     if constType <> nil then
                       if constType = realptr then begin
                         if nodeCval.valp <> nil then begin
                           writev( prc, nodeCval.valp^.rval,
                                  lenpv(nodeCval.valp^.rval) )
                         end
                       end
                       else if constType^.form = arrays then begin
                         (*stringconst*)
                         write( prc, '"' );
                         if constType^.slen = 1 then begin
                           write( prc, chr(nodeCval.ival) );
                         end
                         else if nodeCval.valp <> nil then begin
                           with nodeCval.valp^ do begin
                             writeve( prc, sval, slgth);
                           end;
                         end;
                         write( prc, '"' );
                       end
                       else if constType = nilptr then begin
                         write( prc, 'NULL' );
                       end
                       else write( prc, nodeCval.ival:1 )
                   end;

                 varNode   : begin
                   if isVar then begin
                       write( prc, '(*' );
                       writeId( nodeVar );
                       write( prc, ')' )
                     end
                     else
                       writeId( nodeVar );
                   end;

                 fBufNode  : begin
                   if lvalue then begin
                     { assignment to f^ => create an lvalue }
                     genCExpr( fbParent );
                     write( prc, '.buffer ' );
                   end
                   else if fBufType = textptr then begin
                     write( prc, '(*({ ' );
                     genfp( fBufType, fbParent );
                     writeln(prc, 'if( $fp->flags == 0 ) { int $c = getc($fp->f);' );
                     writeln(prc, 'if($c == EOF) {' );
                     if debug then
                       writeln(prc, 'if($fp->buffer==2) _Pfatal("attempt to use file buffer variable when eof is true",', linecount:1, ' );' );
                     writeln(prc, '$c=''\n'';}' );
                     { replace cr with space whenever text file^ is accessed }
                     writeln(prc, 'if($c==''\n'') {$fp->buffer='' ''; $fp->flags=2;}' );
                     writeln(prc, 'else {$fp->buffer=$c; $fp->flags=1;}');
                     if lnflag then writeln(prc, '#line ', linecount:1);
                     write( prc, '} &$fp->buffer;})) ' );
                   end
                   else begin {binary file}
                     write( prc, '(*({ ' );
                     genfp( fBufType, fbParent );
                     writeln(prc, 'if($fp->flags == 0) {' );
                     writeln(prc, '  ( $fp->flags = fread(&$fp->buffer, sizeof($fp->buffer), 1, $fp->f));' );
                     if debug then begin
                       writeln(prc,
                                 '  if( $fp->flags == 0 ) _Pfatal("file buffer variable failed",',
                                 linecount:1, ');' );
                     end;
                     writeln(prc, '};  &$fp->buffer;' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                     write( prc, '})) ' );
                   end;
                 end;

                 arrayNode : begin
                     with arrayType^ do begin
                       if aelType^.isVoidPtr then begin
                         { TODO: beware lhs of assignment }
                         { cast void * to correct pointer type }
                         write( prc, '*( /*isVoid*/ ' );
                         genCType( aelType, false );
                         write( prc, '*const)&' );
                       end;
                       genCExpr(aparent);
                       write( prc, '.component[(unsigned)(' );
                       if not confFlag then begin
                         getbounds( inxType, lo, hi );
                       end;
                       { if debug check bounds before access }
                       if debug then begin
                         write( prc, '({ int $i = ' );
                         genCExpr(index);
                         writeln(prc, ';' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                         write( prc, 'if( $i<' );
                         if confFlag then begin
                           writeId(lowBound);
                           write( prc, ' || $i>' );
                           writeId(highBound);
                         end
                         else begin
                           write( prc, lo:1, ' || $i>', hi:1 );
                         end;
                         writeln(prc,  ') _Pfatal("array index out of range", ',
                                        linecount:1, ');' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                         write( prc, '$i;})' );
                       end
                       else begin
                         genCExpr(index);
                       end;

                       write( prc, ' - ' );
                       if confFlag then begin
                         writeId(lowBound);
                       end
                       else
                         write( prc, lo:1 );
                       write( prc, ') ]' );
                     end; {with}
                   end;

                 setNode   : write( prc, '>>> unexpected use of sets' );

                 fieldNode : begin
                     test := true;
                     if chkvar and (fieldName <> nil) then begin
                       with fieldName^ do begin
                         if varlb <> nil then begin
                           if varlb^.name <> nil then begin
                             write( prc, '/* tag is ' );
                             writeId(varlb);
                             write( prc, ', variant nrs are ' );
                             lsp := varnt;
                             while lsp <> nil do begin
                               write( prc, lsp^.varval:1);
                               lsp := lsp^.caslst;
                               if lsp <> nil then
                                 write( prc, ', ' );
                             end; {while}
                             writeln(prc, ' */' );
                             if lnflag then writeln(prc, '#line ', linecount:1);

                             write( prc, '({ ' );
                             genTypeOf( fParent );
                             write( prc, ' *$p = &' );
                             genCExpr( fParent);       { recursively check parent tags }
                             writeln(prc, ';' );
                             if lnflag then writeln(prc, '#line ', linecount:1);
                             write( prc, 'switch((int)$p->' );
                             writeId(varlb);
                             write( prc, '){ default: _Pfatal("variant does not match tag", ', linecount:1, ');' );
                             lsp := varnt;
                             while lsp <> nil do begin
                               write( prc, ' case ', lsp^.varval:1, ':');
                               lsp := lsp^.caslst;
                             end; {while}
                             write( prc, ';}; $p;})->' );
                             writeId( fieldName );
                             test := false;
                           end; {if}
                         end; {if varlb<>nil }
                       end; {with}
                     end; {chkvar}

                     if test then begin
                       genCExpr( fParent);
                       write( prc, '.' );
                       writeId( fieldName );
                     end;
                   end;

                 wfieldNode : begin
                     test := true;
                     if chkvar and (wfieldName <> nil) then begin
                       with wfieldName^ do begin
                         if varlb <> nil then begin
                           if varlb^.name <> nil then begin
                             write( prc, '/* tag is ' );
                             writeId(varlb);
                             write( prc, ', variant nrs are ' );
                             lsp := varnt;
                             while lsp <> nil do begin
                               write( prc, lsp^.varval:1);
                               lsp := lsp^.caslst;
                               if lsp <> nil then
                                 write( prc, ', ' );
                             end; {while}
                             writeln(prc, ' */' );
                             if lnflag then writeln(prc, '#line ', linecount:1);

                             write( prc, '({ switch((int)$tw', fLevel:1, '->' );
                             writeId(varlb);
                             write( prc, '){ default: _Pfatal("variant does not match tag", ', linecount:1, ');' );
                             lsp := varnt;
                             while lsp <> nil do begin
                               write( prc, ' case ', lsp^.varval:1, ':');
                               lsp := lsp^.caslst;
                             end; {while}
                             write( prc, ';}; ' );
                             write( prc, '$tw', fLevel:1 );
                             write( prc, ';})->' );
                             writeId( wfieldName );
                             test := false;
                           end; {if}
                         end; {if varlb<>nil }
                       end; {with}
                     end; {chkvar}

                     if test then begin
                       write( prc, '$tw', fLevel:1, '->' );
                       writeId( wfieldName );
                     end;
                   end;

                 pointerNode : begin
                     write( prc, ' /* &pointer Node */ (*' );
                     if ptrType = nil then begin
                       write(prc, ' >>> nil type ');
                     end
                     else begin
                       if ptrType^.isVoidPtr then begin
                         { cast void * to correct pointer type }
                         write( prc, '( /*isVoid*/ ' );
                         genCType( ptrType, false );
                         write( prc, '*)' );
                       end;
                       if memDebug or debug then begin
                         write( prc, '({ ' );
                         genTypeOf( pparent );
                         write( prc, ' $p = ' );
                         genCExpr( pparent );
                         writeln(prc, ';' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                         writeln(prc, 'if($p==NULL) ',
                                 '_Pfatal( "attempt to use nil pointer", ',
                                 linecount:1, ');' );
                         if lnflag then writeln(prc, '#line ', linecount:1);

                         if memDebug then
                           write( prc, '_Puse_mem(_Proot, $p, ', linecount:1, ');' );
                         writeln(prc, '$p; })' );
                         if lnflag then writeln(prc, '#line ', linecount:1);

                       end
                       else
                         genCExpr( pparent );
                     end;
                     write( prc, ')' );
                   end;

                 stdNode    : begin
                     {write( prc, '/*wr sfn', ord(key):1, '*/' ); }

                     { debug-  need to check for overflow, etc }

                     case key of
                       stdNabs : begin { abs() }
                           if debug and (argType = intptr) then begin
                             write(prc, '({ const int $a = abs(' );
                             genCExpr( arg );
                             writeln(prc, ');' );
                             writeln(prc, 'if($a<0) _Pfatal("abs(-maxint-1) overflows", ',
                                          linecount:1, ');' );
                             writeln(prc, '$a;})' );
                             if lnflag then writeln(prc, '#line ', linecount:1);
                           end
                           else begin
                             if argType = realptr then
                               write( prc, 'fabs(' )
                             else
                               write( prc, 'abs(' );
                             genCExpr( arg );
                             write( prc, ')' );
                           end;
                         end;

                        stdNsqr : begin { sqr() }
                           if argType = intptr then begin
                             write( prc, '({ const int $e = (' );
                             genCExpr( arg );
                             write( prc, ');' );
                             if debug then begin
                               writeln(prc, ' if( abs($e) >',
                                       trunc(sqrt(maxintTarget)):1,
                                       ') _Pfatal("sqr overflows", ',
                                       linecount:1, ');' );
                               if lnflag then writeln(prc, '#line ', linecount:1);
                             end;
                           end
                           else begin
                             write( prc, '({ const double $e = (' );
                             genCExpr( arg );
                             write( prc, '); ' );
                             if debug then begin
                               writeln(prc, ' if( fabs($e) > sqrt(DBL_MAX)) _Pfatal("sqr overflows", ',
                                       linecount:1, ');' );
                               if lnflag then writeln(prc, '#line ', linecount:1);
                             end;
                           end;
                           write( prc, ' $e*$e; })' );
                          end;

                        stdNtrunc : begin { trunc() }
                            if debug then begin
                              write( prc, '({ const double $x = trunc(' );
                              genCExpr( arg );
                              writeln(prc, ');' );
                              writeln(prc, 'if(fabs($x)>', maxintTarget:1,
                                      ') _Pfatal("trunc overflows", ',
                                      linecount:1, '); (int)$x;})' );
                              if lnflag then writeln(prc, '#line ', linecount:1);
                            end
                            else begin
                              write( prc, '(int)trunc(' );
                              genCExpr( arg );
                              write( prc, ')' );
                            end;
                        end;

                        stdNodd : begin { odd() }
                          write( prc, '(' );
                          genCExpr( arg );
                          write( prc, ' & 1)' );
                        end;

                        stdNord :  begin
                            { ord() - just cast to int }
                            write( prc, '(int)' );
                            genCExpr( arg );
                          end;

                        stdNchr :  begin { chr() }
                          write( prc, '(unsigned char)(' );
                          if debug then begin
                            write( prc, '({ const unsigned int $c = ');
                            genCExpr( arg );
                            writeln(prc, ';');
                            if lnflag then writeln(prc, '#line ', linecount:1);
                            getbounds( charptr, lo, hi);
                            writeln(prc, 'if($c>', hi:1,
                                  ') _Pfatal("chr() range error", ',
                                   lineCount:1, ');');
                            if lnflag then writeln(prc, '#line ', linecount:1);
                            write( prc, '$c;})');
                          end
                          else
                            genCExpr( arg );
                          write( prc, ')' );
                        end;

                        stdNround : begin { round() }
                            if debug then begin
                              write( prc, '({ const double $x = round(' );
                              genCExpr( arg );
                              writeln(prc, ');' );
                              writeln(prc, 'if(fabs($x)>', maxintTarget:1,
                                      ') _Pfatal("round overflows", ',
                                      linecount:1, '); (int)$x;})' );
                              if lnflag then writeln(prc, '#line ', linecount:1);
                            end
                            else begin
                              write( prc, '(int)round(' );
                              genCExpr( arg );
                              write( prc, ')' );
                            end;
                        end;

                        stdNpred : begin { pred() }
                          if debug then begin
                            getbounds( argType, lo, hi );
                            write(prc, '({ const int $e = ' );
                            genCExpr( arg );
                            writeln(prc, ';' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                            writeln(prc, 'if($e<=', lo:1,
                                    ') _Pfatal("pred range error",',
                                    linecount:1, ' );' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                            writeln(prc, ' $e-1; })');
                            if lnflag then writeln(prc, '#line ', linecount:1);
                          end
                          else begin
                            write( prc, '(' );
                            genCExpr( arg );
                            write( prc, ' - 1)' );
                          end;
                        end;

                        stdNsucc : begin { succ() }
                          if debug then begin
                            getbounds( argType, lo, hi );
                            write(prc, '({ const int $e = ' );
                            genCExpr( arg );
                            writeln(prc, ';' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                            writeln(prc, 'if($e>=', hi:1,
                                    ') _Pfatal("succ range error",',
                                    linecount:1, ' );' );
                            writeln(prc, ' $e+1; })');
                            if lnflag then writeln(prc, '#line ', linecount:1);
                          end
                          else begin
                            write( prc, '(' );
                            genCExpr( arg );
                            write( prc, ' + 1)' );
                          end;
                        end;

                        stdNeof : begin { eof() }
                          write( prc, '({ ' );
                          genfp( argType, arg );
                          checkdefined;

                          { NOTE: use flags for binary files and text files }
                          { if text file set flags to 1, buffer :=c;
                            else binary file so unget(c)}
                          if argType = textptr then begin
                            write( prc,
                                  '$fp->flags<0 || ($fp->flags==0 && !isatty(fileno($fp->f)) && ({const int $c = fgetc($fp->f); int $r = 0;' );
                            write(prc, 'if($c==EOF) {' );
                            write(prc, '  if($fp->buffer==2) $r=1; else {$fp->buffer='' ''; $fp->flags=2;}}' );
                            write(prc, ' else { $fp->flags=($c==''\n''?2:1); $fp->buffer=($c==''\n''?'' '':$c); }; $r;}));' );
                          end
                          else begin
                            write( prc, '$fp->flags<0 || ($fp->flags==0 && !($fp->flags = fread(&$fp->buffer, sizeof($fp->buffer), 1, $fp->f)));' );
                          end;
                          writeln(prc, ' })' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                        end;

                        stdNeoln : begin { eoln() }
                          { Check if at end of line (or end of entire file) }
                          write( prc, '({ ' );
                          genfp( argType, arg );
                          checkdefined;
                          checkReadable;
                          {eoln should be error if eof is true,
                           but we need to pretend there's a newline at the end of
                           an unterminated file.
                          }
                          write( prc, 'if($fp->flags == 0) {' );
                          write(prc, 'int $c = fgetc($fp->f);' );
                          write(prc, 'if($c == EOF) {' );
                          if debug then begin
                            writeln(prc, 'if($fp->buffer==2) _Pfatal("attempt to use eoln when eof is true",', linecount:1, ' );' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                          end;
                          write(prc, '$c = ''\n'';}' );
                          write(prc, '$fp->flags=1; if( $c== ''\n'' ) { $c = '' ''; $fp->flags = 2;} $fp->buffer=$c;} $fp->flags == 2; })' );

                        end;
                      end; { case }
                    end;

                 callNode   : begin

                     {special case: exp(lx(x)*y) is not accurate,
                      test for it and generate more accurate pow(x,y) code}
                     if isStdMaFun(nodeFunc, stdNexp) and
                       (firstPar^.parExpr^.n = binOpnode) and
                        (firstPar^.parExpr^.binOpKind = mul) and
                        (firstPar^.parExpr^.left <> nil) and
                        (firstPar^.parExpr^.left^.n = callNode) and
                        isStdMaFun(firstPar^.parExpr^.left^.nodeFunc, stdNln)
                     then begin
                       { exp(ln(x)*y) ==> pow(x,y) }
                       write( prc, '({ const double $x = ' );
                       genCExpr(firstPar^.parExpr^.left^.firstPar^.parExpr);
                       write( prc, ', $y = ');
                       genCExpr(firstPar^.parExpr^.right);
                       writeln(prc, ';');
                       if lnflag then writeln(prc, '#line ', linecount:1);
                       if debug then begin
                         writeln(prc,
                                 'if($x<=0) _Pfatal("arg of ln must be >0",',
                                 linecount:1, ');');
                         writeln(prc,
                                 'if( (($x>1.0 && $y>1.0) || ($x<1.0 && $y<-1.0)) && ln($x)*$y>=ln(DBL_MAX) ) _Pfatal("exp() overflows",',
                                 linecount:1, ');' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                       end;
                       writeln(prc, 'pow($x,$y);})' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end
                     else if isStdMaFun(nodeFunc, stdNexp) and
                        (firstPar^.parExpr^.n = binOpnode) and
                        (firstPar^.parExpr^.binOpKind = mul) and
                        (firstPar^.parExpr^.right <> nil) and
                        (firstPar^.parExpr^.right^.n = callNode) and
                        isStdMaFun(firstPar^.parExpr^.right^.nodeFunc, stdNln)
                     then begin
                       { exp(y*ln(x)) ==> pow(x,y) }
                       write( prc, '({ const double $x = ' );
                       genCExpr(firstPar^.parExpr^.right^.firstPar^.parExpr);
                       write( prc, ', $y = ');
                       genCExpr(firstPar^.parExpr^.left);
                       writeln(prc, ';');
                       if debug then begin
                         writeln(prc,
                                 'if($x<=0) _Pfatal("arg of ln must be >0",',
                                 linecount:1, ');');
                         writeln(prc,
                                 'if( (($x>1.0 && $y>1.0) || ($x<1.0 && $y<-1.0)) && ln($x)*$y>=ln(DBL_MAX) ) _Pfatal("exp() overflows",',
                                 linecount:1, ');' );
                         if lnflag then writeln(prc, '#line ', linecount:1);
                       end;
                       writeln(prc, 'pow($x,$y);})' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end
                     else begin
                       if nodeFunc^.pfkind = actual then
                         writeId( nodeFunc )
                       else begin
                         { it's a function parameter }
                         write( prc, '(*' );
                         writeId( nodeFunc );
                         write( prc, ')' );
                       end;
                       write( prc, '( ' );
                       parPtr := firstPar;
                       lsp2 := nil;
                       while parPtr <> nil do begin
                         with parPtr^ do begin
                           if isConfArray(parType) then begin
                             { the formal parameter is conformant }
                             lsp1 := parType;
                             { if type is same as previous parameter, then
                             the parameters are part of the same group, and
                             the bounds have already been emitted }
                             if lsp1 <> lsp2 then begin
                               lsp2 := lsp1; { remember type }

                               { get limits of actual array arg }
                               with parExpr^ do begin
                                 lsp := nil;
                                 case n of
                                   constNode   : lsp := constType;
                                   varNode     : lsp := nodeVar^.idtype;
                                   fBufNode    : lsp := fBufType^.filtype;
                                   arrayNode   : lsp := arrayType^.aelType;
                                   pointerNode : lsp := ptrType;
                                   fieldNode   : lsp := fieldname^.idtype;
                                   wfieldNode  : lsp := wfieldname^.idtype;
                                 end; {case}
                               end; {with}
                               if lsp = nil then
                                 write( prc, '>>> no bounds for array' )
                               else begin
                                 { lsp is actual parameter, lsp1 is formal parameter }
                                 write( prc, '/* bounds: */ ' );
                                 { is the parameter itself a conformant array? }
                                 { TODO: can lsp and/or lsp1 be nil? }
                                 { TODO: no need to check if
                                 lsp type bounds lie inside lsp1 type bounds }
                                 while isConfArray(lsp) and
                                   isConfArray(lsp1)
                                 do begin
                                   with lsp^ do begin
                                     getbounds( lsp1^.inxType, lo, hi);
                                     if debug then begin
                                       write( prc, '({if(');
                                       writeId( lowBound );
                                       write( prc, '<', lo:1,
                                             ') _Pfatal("low parameter bounds mismatch", ',
                                             linecount:1, ');' );
                                       writeId( lowBound );
                                       write( prc, ';})');
                                     end
                                     else
                                       writeId( lowBound );
                                     write( prc, ', ');
                                     if debug then begin
                                       write( prc, '({if(');
                                       writeId( highBound );
                                       write( prc, '>', hi:1,
                                             ') _Pfatal("high parameter bounds mismatch", ',
                                             linecount:1, ');' );
                                       writeId( highBound );
                                       write( prc, ';})');
                                     end
                                     else
                                       writeId( highBound );
                                     write( prc, ', ');
                                     lsp := aeltype;
                                   end; {with}
                                   lsp1 := lsp1^.aelType;
                                 end; {while}


                                 { generate bounds for the fixed part of the param }
                                 if isString(lsp) and (lsp^.inxType = nil) then begin
                                   write( prc, '1, ', lsp^.slen:1, ', ' );
                                 end
                                 else begin
                                   while isConfArray(lsp1) do begin
                                     if lsp^.form <> arrays then
                                       writeln(prc, '>>> not an array (',
                                               ord(lsp^.form):1, ')' )
                                     else begin
                                       { NB: bounds checked at compile time }
                                       getbounds( lsp^.inxType, lo, hi);
                                       write( prc, lo:1, ', ', hi:1, ', ' );
                                       lsp := lsp^.aeltype;
                                     end; {if}
                                     lsp1 := lsp1^.aelType;
                                   end; {while}
                                 end; {if}
                               end; {if}
                             end; {if lsp1 <> lsp2 }
                             write( prc, '&' ); {TODO: shouldn't write this if actual param is a string constant }
                             genCExpr(parExpr);
                           end
                           else {not conf array}

                             case parAccess of
                               valueParam : begin
                                 if parType^.form = power then begin
                                   {writeln(prc, '// arg is a set' );}
                                   write( prc, '({' );
                                   writeId( parType^.typeName );
                                   writeln(prc, ' $set0;' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                   writeln(prc,
                                           'uint8_t *const $s0 =  $set0.element;' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                   getbounds( parType^.elset, lo, hi );
                                   if debug then begin
                                     writeln(prc, 'bool $r=0;');
                                     if checkSet(parExpr, lo, hi) then
                                       error(304);
                                     writeln(prc, 'if($r) _Pfatal("assigning element outside set bounds",',
                                             linecount:1, ');');
                                     if lnflag then writeln(prc, '#line ', linecount:1);
                                   end;
                                   constructSet( parExpr, lo, hi, 0 );
                                   writeln(prc, '$set0; })' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                 end
                                 else if isString( parType ) then begin
                                   if parExpr^.n = constNode then begin
                                     write( prc, '({' );
                                     writeId( parType^.typeName );
                                     write( prc, ' $str = {{' );
                                     genCExpr( parExpr );
                                     write( prc, '}}; $str; })' );
                                   end
                                   else begin
                                     write( prc, '*(' );
                                     writeId( parType^.typeName );
                                     write( prc, ' *)&' );
                                     genCExpr( parExpr );
                                   end
                                 end
                                 else if debug and
                                     (parType <> intptr) and
                                     (parType <> realptr) and
                                     (parType^.form <= subrange)
                                 then begin
                                   getbounds( parType, lo, hi );
                                   write( prc, '({const int $i = ' );
                                   genCExpr( parExpr );
                                   writeln(prc, '; if($i>', hi:1, '|| $i<', lo:1,
                                           ') _Pfatal("bounds error in parameter",',
                                           linecount:1, '); $i;})' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                 end
                                 else if debug and isStdMaFun(nodeFunc, stdNsqrt) {sqrt}
                                 then begin
                                   write( prc, '({ const double $x = ' );
                                   genCExpr( parExpr );
                                   writeln(prc, ';');
                                   writeln(prc,
                                         'if($x<0) _Pfatal("arg of sqrt must be >=0",',
                                         linecount:1, '); $x;})' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                 end
                                 else if debug and isStdMaFun(nodeFunc, stdNln) {ln}
                                 then begin
                                   write( prc, '({ const double $x = ' );
                                   genCExpr( parExpr );
                                   writeln(prc, ';');
                                   writeln(prc,
                                           'if($x<=0) _Pfatal("arg of ln must be >0",',
                                           linecount:1, ');');
                                   writeln(prc, '$x;})' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                 end
                                 else if debug and isStdMaFun(nodeFunc, stdNexp) {exp}
                                 then begin
                                   write( prc, '({ const double $x = ' );
                                   genCExpr( parExpr );
                                   writeln(prc, ';');
                                   writeln(prc,
                                           'if($x>ln(DBL_MAX)) _Pfatal("exp() overflows",',
                                           linecount:1, '); $x;})' );
                                   if lnflag then writeln(prc, '#line ', linecount:1);
                                 end
                                 else begin
                                   genCExpr( parExpr );
                                 end;
                               end;

                               varParam   : begin
                                 write( prc, '&' );
                                 if parExpr^.n = setNode then begin
                                   {writeln(prc, '// var arg is a set' );}
                                   genCExpr( parExpr^.sparent );
                                 end
                                 else
                                   genCExpr( parExpr );
                               end;

                               funcParam  : genCExpr( parExpr );
                             end; { case parAccess ... }
                           parPtr := next;
                         end; { with }
                         if parPtr <> nil then
                           write( prc, ', ' );
                       end; {while}
                       write( prc, ' )' );

                     end;

                   end; {callNode}

                 fParNode   : writeId( fPar );

                 funcNode   : begin
                     if fdbg then begin
                       write( prc, '*({$result', lev:1, '.valid = 1;' );
                       write( prc, '&$result', lev:1, '.value;})' );
                     end
                     else
                       write( prc, '$result', lev:1 );
                   end;

                 tmpValNode   : begin
                       write( prc, '$tmp', regNr:1 );
                   end;

                 tmpSetNode   : begin
                       write( prc, '>>> unexpected tmpSetNode' );
                   end;

               end; { case }
             end; { with }
           end
           else begin
             writeln(prc, '>>> expression sub tree is nil' );
           end;
         end; { genCExpr() }


          procedure freeTree{(t : exprTreePtr)};
         var
           v1, v2 : varElementPtr;
           c1, c2 : constElementPtr;
           parPtr, parPtr1 :pfParamPtr;

         begin
           if t <> nil then begin
             { free the tree }
             with t^ do begin
               {writeln( 'free node ', ord(n):1 );}
               case n of
                 binopNode  : begin
                      freeTree(left);
                      freeTree(right);
                    end;
                 strOpNode  : begin
                      freeTree(strLeft);
                      freeTree(strRight);
                    end;
                 setOpNode  : begin
                      freeTree(setLeft);
                      freeTree(setRight);
                    end;
                 unopNode   : freeTree(operand);
                 constNode  : begin { do nothing } end;
                 varNode    : begin { do nothing } end;
                 fBufNode   : begin
                                   freeTree(fbParent);
                                 end;
                 arrayNode  : begin
                                    freeTree( index );
                                    freeTree( aparent );
                                 end;
                 setNode  : begin
                                 if sparent <> nil then begin
                                   if sparent^.n = tmpSetNode then begin
                                     if sparent^.pSelFlag then
                                       dispose(selType);
                                   end;
                                   freeTree( sparent );
                                 end;
                                 v1 := varList;
                                 while v1 <> nil do begin
                                   with v1^ do begin
                                     freeTree(elvalue);
                                     if isRange then
                                       freeTree(hiValue);
                                     v2 := next;
                                   end; {with}
                                   dispose(v1);
                                   v1 := v2;
                                 end;
                                 c1 := constList;
                                 while c1 <> nil do begin
                                   c2 := c1^.next;
                                   dispose(c1);
                                   c1 := c2;
                                 end;
                               end;

                 pointerNode : begin
                      freeTree( pparent );
                                end;
                 fieldNode : begin
                      freeTree( fparent );
                                end;
                 wfieldNode : begin { do nothing } end;
                 callNode   : begin
                      { free list of args }
                      parPtr := firstPar;
                      while parPtr <> nil do begin
                        parPtr1 := parPtr;
                        parPtr := parPtr^.next;
                        freeTree( parPtr1^.parExpr );
                        dispose( parPtr1 );
                      end;
                   end;
                 stdNode    : begin
                     freeTree( arg )
                   end;
                 fParNode   : begin { do nothing } end;
                 funcNode   : begin { do nothing } end;
                 tmpValNode : begin { do nothing } end;
                 tmpSetNode : begin { do nothing } end;
               end; { case }
             end; { with }
             dispose(t);
           end
           else begin
             writeln(prc, '// >>> free expression sub tree is nil' );
             if lnflag then writeln(prc, '#line ', linecount:1);
           end;
         end; { freeTree }


        {test set for empty regions, exclusive or inclusive
         if a <= b,  exclusive test, ie
                    test -MaxInt .. lo-1 & hi+1 .. MaxInt
         if a > b, inclusive test, ie
                    test b..a
         return true if region/s determined to be non-empty at compile time
         otherwise return false, and
         set previously declared variable $r if run time test is needed
            $r := 1 iff not empty
            $r := 0 iff empty

        the expression tree, t, is analysed, but remains unchanged,
        except subexpressions are pre calculated and replaced in the
        tree.
        Note that the same subtree could appear more than once in t
        (eg, see set = operator)
       }
       { function checkSet(t : exprTreePtr; a, b: integer): boolean; forward;}
        function checkSet;
        var
          tmpcount : integer;
          tCheck   : exprTreePtr;
          np       : integer;

          {scan set expression tree, save subexpressions in $tmp[] array
           since the subexpressions could be evaluated many times,
           this avoids side effects and improves efficiency
           ns is the number of stars (ie mul or minus operators) above
              in the expression tree
           np returns the nr of plus ops here or below
          }
          procedure rmSide(t : exprTreePtr; ns: integer; var np: integer);

          var
            v     : varElementPtr;
            c     : constElementPtr;
            lo,hi : integer;
            t1    : exprTreePtr;
            p1,p2 : integer;
            ns1   : integer;
            fixed : boolean; {xxx}

            procedure genTmp(var val: exprTreePtr);
            begin
              if (val^.n <> varNode) and (val^.n <> constNode) and (val^.n <> tmpValNode) then begin
                write(prc, 'const int $tmp', tmpCount:1, '=');
                genCExpr(val);
                freeTree(val);
                writeln(prc, ';');
                if lnflag then writeln(prc, '#line ', linecount:1);
                new(val);
                val^.n := tmpValNode;
                val^.regNr := tmpCount;
                tmpCount := tmpCount+1;
              end; {if}
            end; { genTmp }

          begin {rmSide}
            if t <> nil then begin
              with t^ do begin

                if n = setNode then begin
                  if sparent = nil then np := -1 else np := 0;
                  if (sparent <> nil)
                    and (sparent^.n <> varNode)
                    and (sparent^.n <> tmpSetNode)
                  then begin
                    write(prc, 'uint8_t *const $setTmp', tmpCount:1, '=');
                    genSetPtr(sparent);
                    writeln(prc, ';');
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    freeTree( sparent );
                    new(sparent);
                    sparent^.n := tmpSetNode;
                    sparent^.setNr := tmpCount;
                    sparent^.pSelFlag := false;
                    tmpCount := tmpCount+1;
                  end; {sparent <> nil}

                  v := varlist;
                  while v <> nil do begin
                    np := np+1;
                    with v^ do begin
                      genTmp(elValue);
                      if isRange then begin
                        genTmp(hiValue);
                      end;
                    end; {with}
                    v := v^.next;
                  end; {while}

                  c := constlist;
                  while c <> nil do begin
                    np := np+1;
                    with c^ do begin
                      {TODO: combine consecutive values}
                      if isRange then begin

                      end;
                    end; {with}
                    c := c^.next;
                  end; {while}
                end
                else if n = setOpnode then begin

                  {evaluating set expressions analytically can cause
                   code bloat for compilcated expressions, but can be
                   efficient for simple expressions.
                   we can look for a sub expression of known size, and
                   if it is simple enough, evaluate it now to reduce the nr
                   of terms in the expression.

                   To decide, we use a heuristic based on nr mul ops in
                   parents, nr plus ops in children
                   (the idea is that code bloat is caused by moving the
                    plus ops above the mul ops in the expression tree)
                  }

                  {do we know the size of the subexpression,
                   and is it not too big?}
                  lo := reslo; hi := resHi;
                  fixed := mergeFixedSets and  (hi>=lo)
                    and ((lo>=0) or (hi <= maxint+lo)) {catch overflow!}
                    and (hi - lo <= 2*setmax+1);

                  {remove side effects first}
                  {the children could build their own fixed subexpressions
                   choose to do the fixed work here for efficiency
                   and miss possible common sub expression elimination
                   but make an exception for minus ops
                  }
                  if (ns>=0) and (setOpKind in [mul, minus]) then ns := ns+1;
                  ns1 := ns;
                  if fixed and (setOpKind <> minus) then begin
                    ns1 := -1; {prevent children merging subexpressions}
                  end;
                  rmSide(setLeft, ns1, p1);
                  rmSide(setRight, ns1, p2);

                  np := p1 + p2;
                  if setOpKind in [plus,minus] then np := np+1;

                  if fixed and (np > 0) and (ns > 0) and (ns+np > 2)
                  then begin
                    write(prc, ' /* found fixed subex [', lo:1, '..', hi:1, '] at line ', linecount:1, ', ns is ', ns:1, ', np is ', np:1, ' */ ');
                    np := 0;
                    writeln(prc, 'uint8_t $setTmp', tmpCount:1, '[(',
                                  hi:1, '>>3)-(', lo:1, '>>3)+1];');
                    if lnflag then writeln(prc, '#line ', linecount:1);

                    writeln(prc, '({uint8_t *const $s0 = $setTmp', tmpCount:1, ';');
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    constructSet(t, lo, hi, 0);
                    writeln(prc, ';}); // $s0');
                    if not locked then begin
                      {keep this node but free the children and lists}
                      new(t1);
                      t1^ := t^;
                      freeTree(t1);
                    end;
                    n := setNode;
                    varList := nil;
                    constList := nil;
                    newList := false;
                    new(sparent);
                    with sparent^ do begin
                      n := tmpSetNode;
                      setNr := tmpCount;
                      pSelFlag := true; {needs private seltype}
                    end;
                    new(selType); {xxx1}
                    with selType^ do begin
                      form := subrange;
                      rangeType := intptr;
                      smin := lo; smax := hi;
                    end;
                    tmpCount := tmpCount+1;
                  end {if fixed}
                end
                else begin
                  writeln(prc, '>>> rmSide: unexpected node kind(', ord(n):1, ')' );
                end; {if}
              end; {with}
            end; {if}
          end; { rmSide }


        { copy a set expression tree
          t is original, it remains unchanged
          t1 is the new expression
          - transfor minus ops to mul & invert, so a-b --> a*~b
          - expand all lists, so [1,2,3] --> [1] + [2] + [3]

        set expression tree:
          - only setNode & setOpNode used,
            only these fields used:
              n, invert, sparent, seltype, varlist & constList
              n, setOpKind, setleft & setRight
          - setOpNode may have nil child
          - set node has only one list element or a set
          - in varlist range when invert,
            if elvalue = nil, then elvalue := -M, hivalue needs one subtracted
            if hivalue = nil, then hivalue := +M, lovalue needs one added
        }
        procedure sxcopy(    t    : exprTreePtr;
                         var t1   : exprTreePtr;
                         invFlag  : boolean );
        var
          p, p0    : exprTreePtr;
          pl, ph   : exprTreePtr;
          rInv     : boolean;
          v1       : varElementPtr;
          c1       : constElementPtr;
          xlo, xhi : integer;

        {add two set expressions if both not nil
         nil is an implied empty set,
         if one of the inputs is nil, return the the other one,
         if both nil, return nil}
        function sxadd(plo, phi : exprTreePtr ): exprTreePtr;
        var
          pr :  exprTreePtr;
        begin
          if plo = nil then
            pr := phi
          else if phi = nil then
          pr := plo
          else begin
            new(pr, setOpNode);
            with pr^ do begin
              n := setOpNode;
              setOpKind := plus;
              setleft := plo;
              setRight := phi;
              locked := false;
            end; {with}
          end; {if}

          sxadd := pr;
        end; { sxadd }

        {multiply 2 set expressions
         nil is an implied full set,
         pa is main expression tree,
         pb is new subexpression to put on it
        }
        function sxmul(pa, pb : exprTreePtr ): exprTreePtr;
        var
          pr :  exprTreePtr;
        begin
          if pa = nil then
            pr := pb {nothing on the tree yet}
          else if pb = nil then begin
            pr := pa
          end
          else begin
            new(pr, setOpNode);
            with pr^ do begin
              n := setOpNode;
              setOpkind := mul;
              setLeft := pa;
              setRight := pb;
              locked := false;
            end; {with}
          end; {if}
          sxmul := pr;
        end; { sxmul }


          function emptySet: exprTreePtr;
          var
            p : exprTreePtr;
          begin
            new( p, setNode );
            with p^ do begin
              n := setNode;
              sparent := nil;
              seltype := nil;
              varlist := nil;
              newList := true;
              new( constList );
              with constList^ do begin
                isRange := true;
                elValue := maxIntTarget;
                hiValue := -maxIntTarget;
              end; {with}
            end; {with}
            emptySet := p;
          end; { emptySet }


        begin {sxcopy}
          p := nil;
          if t <> nil then case t^.n of
            setNode : begin
                if invFlag then begin

                  if t^.seltype = nil then begin
                    {invert empty set}
                    new( p, setNode );
                    with p^ do begin
                      n := setNode;
                      sparent := nil;
                      varlist := nil;
                      selType := intptr;
                      newList := true;
                      new( constList );
                      with constList^ do begin
                        isRange := true;
                        elValue := -maxIntTarget;
                        hiValue := maxIntTarget;
                      end; {with}
                    end; {with}
                  end
                  else begin
                    if t^.sparent <> nil then begin

                      { make [-M..xlo-1] + ~S + [xhi+1..M] }
                      getbounds( t^.seltype, xlo, xhi );

                      { pl is lo range}
                      if xlo > -maxIntTarget then begin
                        new( pl, setNode );
                        with pl^ do begin
                          n := setNode;
                          sparent := nil;
                          seltype := t^.seltype;
                          varlist := nil;
                          newList := true;
                          new( constList );
                          with constList^ do begin
                            isRange := true;
                            elValue := -maxIntTarget;
                            hiValue := xlo-1;
                          end; {with}
                        end; {with}
                      end
                      else begin
                        pl := nil;
                      end; {if}

                      { ph is hi range}
                      if xhi < maxIntTarget then begin
                        new( ph, setNode );
                        with ph^ do begin
                          n := setNode;
                          varlist := nil;
                          sparent := nil;
                          seltype := t^.seltype;
                          newList := true;
                          new( constList );
                          with constList^ do begin
                            isRange := true;
                            elValue := xhi+1;
                            hiValue := maxIntTarget;
                          end; {with}
                        end; {with}
                      end
                      else begin
                        ph := nil;
                      end; {if}

                      {p0 := the set}
                      new(p0, setNode);
                      with p0^ do begin
                        n := setNode;
                        newList := false;
                        sparent := t^.sparent;
                        seltype := t^.seltype;
                        varlist := nil;
                        constList := nil;
                        invert := true;
                      end; {with}
                      p := sxadd( p0, sxadd( pl, ph ));
                    end; {if sparent <> nil}

                    { expand var list,
                    inverting so plus -> mul and complement the range}
                    v1 := t^.varlist;
                    while v1 <> nil do begin
                      new( pl, setNode );  {lo range}
                      with pl^ do begin
                        n := setNode;
                        sparent := nil;
                        seltype := t^.seltype;
                        constList := nil;
                        invert := true;
                        newList := true;
                        new(varlist);
                        with varlist^ do begin
                          next := nil;
                          isRange := true;
                          elvalue := nil;
                          hiValue := v1^.elValue;
                        end; {with}
                      end; {with}

                      new( ph, setNode );  {hi range}
                      with ph^ do begin
                        n := setNode;
                        sparent := nil;
                        seltype := t^.seltype;
                        constList := nil;
                        invert := true;
                        newList := true;
                        new(varlist);
                        with varlist^ do begin
                          next := nil;
                          isRange := true;
                          if v1^.isRange then
                            elvalue := v1^.hiValue
                          else
                            elvalue := v1^.elvalue;
                          hiValue := nil;
                        end; {with}
                      end; {with}

                      p := sxmul( p, sxadd( pl, ph ));

                      v1 := v1^.next;
                    end; {while}

                    { expand const list, with invert}
                    c1 := t^.constlist;
                    while c1 <> nil do begin
                      if c1^.elvalue > -maxIntTarget then begin
                        new(pl, setNode);
                        with pl^ do begin
                          n := setNode;
                          invert := true;
                          varList := nil;
                          sparent := nil;
                          seltype := t^.seltype;
                          newList := true;
                          new(constlist);
                          with constList^ do begin
                            isRange := true;
                            elvalue := -maxIntTarget;
                            hiValue := c1^.elvalue - 1;
                          end; {with}
                        end; {with}

                      end
                      else begin
                        pl := nil;
                      end; {if}

                      if c1^.isRange then
                        xhi := c1^.hiValue
                      else
                        xhi := c1^.elValue;

                      if xhi < maxIntTarget then begin
                        new(ph, setNode);
                        with ph^ do begin
                          n := setNode;
                          invert := true;
                          varList := nil;
                          sparent := nil;
                          seltype := t^.seltype;
                          newList := true;
                          new(constlist);
                          with constList^ do begin
                            isRange := true;
                            elValue := xhi+1;
                            hiValue := maxIntTarget;
                          end; {with}
                        end; {with}
                      end
                      else begin
                        ph := nil;
                      end; {if}

                      p0 := sxadd( pl, ph );
                      if p0 = nil then begin
                        {inverting [-maxint..maxint]}
                        p0 := emptySet;
                      end;
                      p := sxmul( p, p0 );
                      c1 := c1^.next;
                    end; {while}
                    if p = nil then writeln(prc,
                                    ' >>> unexpected nil expression tree ');
                  end; {if t^.seltype}
                end
                else begin {no inversion}
                  if t^.seltype = nil then begin
                    {empty set}
                    p := emptySet;
                  end
                  else begin
                    if t^.sparent <> nil then begin
                      new(p, setNode);
                      with p^ do begin
                        n := setNode;
                        newList := false;
                        sparent := t^.sparent;
                        seltype := t^.seltype;
                        invert := false;
                        varlist := nil;
                        constList := nil;
                      end; {with}
                    end; {if}

                    { expand var list & const list}
                    v1 := t^.varlist;
                    while v1 <> nil do begin
                      new(p0, setNode);
                      with p0^ do begin
                        n := setNode;
                        newList := false;
                        varlist := v1;
                        constList := nil;
                        sparent := nil;
                        seltype := t^.seltype;
                      end; {with}
                      p := sxadd( p, p0 );
                      v1 := v1^.next;
                    end; {while}

                    c1 := t^.constlist;
                    while c1 <> nil do begin
                      new(p0, setNode);
                      with p0^ do begin
                        n := setNode;
                        newList := false;
                        constlist := c1;
                        varList := nil;
                        sparent := nil;
                        seltype := t^.seltype;
                      end; {with}
                      p := sxadd( p, p0 );
                      c1 := c1^.next;
                    end; {while}
                  end; {if not empty set}
                end; {if no inversion}
              end; {case setNode}

            setOpNode: begin
                new(p, setOpNode);
                with p^ do begin
                  n := setOpNode;
                  setOpKind := t^.setOpKind;
                  if setOpKind = minus then begin
                    setOpKind := mul;
                    rInv := not invFlag;
                  end
                  else begin
                    rInv := invFlag;
                  end;
                  if invFlag then begin
                    if setOpKind = plus then setOpKind := mul
                    else if setOpKind = mul then setOpKind := plus;
                  end;
                  sxcopy(t^.setLeft, setLeft, invFlag);
                  sxcopy(t^.setRight, setRight, rInv);
                  locked := false;
                end; { with}
              end; {case setOpNode}
          end; {case}
          t1 := p;
        end; { sxcopy }


        {free a set expression tree}
        procedure sxfree(t : exprTreePtr);
        begin
          if t <> nil then begin
            with t^ do begin
              if n = setOpNode then begin
                sxfree(setLeft);
                sxfree(setRight);
              end
              else if n = setNode then begin
                if newList then begin {there is only one of them}
                  if varlist <> nil then dispose( varlist );
                  if constlist <> nil then dispose( constlist );
                end; {if}
              end
              else
                writeln('>>> sxfree: unexpected node type');
            end; {with}
            dispose(t);
          end; {if}
        end; { sxfree }


        { transform an arbitrary set expression into a union of terms (UOT)
          so new expr is () + () + ... + (), and
          only mul ops are inside the parens
           - move plus up and minus ops down, so (a+b)*c --> a*c + b*c
          needs to guarantee all plus ops are at the top,
          all mul ops at the bottom
          all minus ops must have been removed previously
        }
        procedure sxuot(t : exprTreePtr);
        var
          p1, p2    : exprTreePtr;

        procedure dup(t : exprTreePtr; var t1 : exprTreePtr );
        begin

          if t = nil then t1 := nil
          else with t^ do begin
            if n = setOpNode then begin
              new( t1, setOpNode );
              t1^ := t^;
              dup(t^.setLeft, t1^.setLeft);
              dup(t^.setRight, t1^.setRight);
              locked := false;
            end
            else if n = setNode then begin
              new( t1, setNode );
              t1^ := t^;
              t1^.newList := false; { for shared vlist, etc }
            end
            else
              writeln('>>> unexpected node type');
          end; {with}
        end; { dup }

        begin

          if t <> nil  then begin
            with t^ do begin
              if n = setOpNode then begin
                sxuot(setleft); {plus ops up, mul ops down}
                sxuot(setRight);
                if setOpKind = mul then begin
                  if setLeft <> nil then begin
                    if setLeft^.n = setOpNode then begin
                      if setleft^.setOpKind = plus then begin
                        {found (a+b)*c, make a*c + b*c}
                        setOpKind := plus;
                        setleft^.setOpKind := mul;
                        p1 := setRight;
                        p2 := setleft^.setRight;
                        dup(p1, setleft^.setRight);
                        new( setRight, setOpNode);
                        with setRight^ do begin
                          n := setOpNode;
                          setOpKind := mul;
                          setLeft := p2;
                          setRight := p1;
                          locked := false;
                        end; { with}
                        sxuot(setLeft);
                        sxuot(setRight);
                      end; {if}
                    end;
                  end;
                end; {if setOpKind = mul}

                if setOpKind = mul then begin
                  if setRight <> nil then begin
                    if setRight^.n = setOpNode then begin
                      if setRight^.setOpKind = plus then begin
                        {found a*(b+c), make a*b + a*c}
                        setOpKind := plus;
                        setRight^.setOpKind := mul;
                        p1 := setLeft;
                        p2 := setRight^.setLeft;
                        dup(p1, setRight^.setleft);
                        new(setLeft, setOpNode);
                        with setLeft^ do begin
                          n := setOpNode;
                          setOpKind := mul;
                          setLeft := p1;
                          setRight := p2;
                          locked := false;
                        end; { with}
                        sxuot(setLeft);
                        sxuot(setRight);
                      end; {if}
                    end; {if}
                  end; {if setRight <> nil}
                end; {if setOpKind = mul}
              end; {if}
            end; {with}
          end; {if}
        end; { sxuot }

        {examine set expression given by t,
         return true if t range zlo..zhi inclusive is occupied
         otherwise return false and
               generate code to set $r = 1 if term is non zero
        }
        function isNonEmpty(t: exprTreePtr;
                            zlo, zhi : integer ): boolean;
        var
          result   : boolean;

        { print a set expression tree}
          procedure sxpr(var f : text;  t : exprTreePtr);
        var
          count : integer;
        begin
          if t = nil then
            write(f, ' [] ' )
          else with t^ do begin
            if n = setNode then begin
              count := 0;
              if sparent <> nil then begin
                count := count+1;
                if invert then
                  write(f, ' ~S ')
                else
                  write(f, ' S ');
              end;
              if varlist <> nil then begin
                count := count+1;
                with varlist^ do begin
                 if isRange then begin
                   if elvalue = nil then
                     write(f, ' [-M .. v-1] ')
                   else if hiValue = nil then
                     write(f, ' [v+1 .. M] ')
                   else
                     write(f, ' [vlo .. vhi] ');
                 end
                 else
                   write(f, ' [v] ');
               end; {with}
              end; {if}

              if constlist <> nil then begin
                count := count+1;
                with constlist^ do begin
                  write(f, ' [');
                  if not isRange or (elvalue <= hivalue) then begin
                    if elValue = -maxintTarget then
                      write(f, '-maxint')
                    else if elValue = maxintTarget then
                      write(f, 'maxint')
                    else
                      write(f, elValue:1);
                    if isRange then begin
                      write(f, ' .. ');
                      if hiValue = -maxintTarget then
                        write(f, '-maxint')
                      else if hiValue = maxintTarget then
                        write(f, 'maxint')
                      else
                        write(f, hiValue: 1);
                    end;
                  end;
                  write(f, '] ');
               end; {with}
              end; {if}
              if count = 0 then begin
                write(f, ' <?> ' )
              end
              else if count > 1 then begin
                write(f, '>>> too many components in a single set');
              end;
            end
            else if n = setOpNode then begin
              if setopkind = plus then begin
                sxpr(f, SetLeft );
                write(f, '+');
                sxpr(f, setRight );
              end
              else if setopkind = mul then begin
                if setLeft = nil then begin
                  write(f, ' [] ' );
                end
                else if (setleft^.n = setOpnode)
                  and (setLeft^.setOpKind = plus)
                then begin
                  write(f, ' (' );
                  sxpr(f, SetLeft );
                  write(f, ') ' );
                end
                else begin
                  sxpr(f, SetLeft );
                end;

                write(f, '*');

                if setRight = nil then begin
                  write(f, ' [] ' );
                end
                else if (setRight^.n = setOpnode)
                  and (setRight^.setOpKind = plus)
                then begin
                  write(f, ' (' );
                  sxpr(f, SetRight );
                  write(f, ') ' );
                end
                else begin
                  sxpr(f, SetRight );
                end;
              end
              else
                writeln('>>> unexpected set operation');
            end
            else
              writeln('>>> unexpected node in set expression');
          end; {with}
        end; { sxpr }


        {scheck the term
         return
           true if term can be determined to be non empty at compile time
           otherwise return false and
               generate code to set $r = 1 if term is non zero
        }
        function sxChTerm(t :  exprTreePtr) : boolean;
        var
          result   : boolean;
          elo, ehi : integer;
          nvars    : integer;
          nsets    : integer;

        {get lo & hi limits of set expression
         we know all ops are muls, so lo limit is max(each node)
         and hi limit is min(each node)
         us & uv count varlists and sets
        }
        procedure getLimC( t: exprTreePtr; var l, h, us, uv : integer );
        var
          ll, hh : integer;
        begin
          if t = nil then begin
            write(prc, '>>> getLimC: unexpected nil expression tree');
          end
          else with t^ do begin
            if n = setOpNode then begin
              getLimC(setLeft, l, h, us, uv);
              getLimC(setRight, l, h, us, uv);
            end
            else if n = setNode then begin
              if sparent <> nil then begin
                us := us+1;
                getbounds(seltype, ll, hh)
              end
              else if varlist <> nil then begin
                uv := uv+1;
                ll := l; hh :=h;
              end
              else if constlist <> nil then begin
                with constlist^ do begin
                  ll := elvalue;
                  if isRange then
                    hh := hiValue
                  else
                    hh := elvalue;
                end; {with}
              end
              else if seltype = nil then begin
                {all empty sets should have ben given a const list,
                 so this should not happen, but deal with it anyway}
                ll := maxintTarget;
                hh := -maxintTarget;
              end; {if}
              if ll > l then l := ll;
              if hh < h then h := hh;
            end; {if setNode}
          end;
        end; { getLimC }

        {generate run time code to find bounds of term
         since all ops are muls,
            lo bound := max(all lo limits)
            hi bound := min(all hi limits) }
        procedure getLimV( t : exprTreePtr );
        begin
          if t <> nil then with t^ do begin
            if n = setOpNode then begin
              if setLeft <> nil then getLimV(setLeft);
              if setRight <> nil then getLimV(setRight);
            end
            else if n = setNode then begin
              if varlist <> nil then begin
                with varlist^ do begin
                  {note invert shortcut from sxcopy()}
                  write(prc, '{const intmax_t $lv = ' );
                  if elvalue = nil then write(prc, -maxintTarget:1)
                  else begin
                    genCexpr( elvalue );
                    if isRange and (hivalue = nil)
                    then write(prc, ' + (intmax_t)1');
                  end;

                  if isRange then begin
                    write(prc, ', $hv = ' );
                    if hiValue = nil then write(prc, maxintTarget:1)
                    else begin
                      genCexpr( hivalue );
                      if elvalue = nil then write(prc, ' - (intmax_t)1');
                    end;
                    writeln(prc, ';' );
                  end
                  else begin
                    writeln(prc, ', $hv = $lv;' );
                  end; {if}
                  writeln(prc, 'if( $l<$lv ) $l=$lv; if( $h>$hv ) $h=$hv;}' )
                end; {with}
              end; {if}
            end;
          end;
        end; { getLimV }

        procedure mulSets(t : exprTreePtr );
        var
          slo, shi : integer;
        begin
          if t <> nil then with t^ do begin
            if n = setNode then begin
              if sparent <> nil then begin
                getbounds( seltype, slo, shi );
                write(prc, '  $t &= ' );
                if invert then write(prc, '~');
                genSetPtr(sparent);
                writeln(prc, '[($i - (', slo:1, '>>3))];');
              end
              else begin
                write(prc, '/* no sparent in set */' );
              end; {if}
            end
            else if n = setOpNode then begin
              if setOpKind = mul then begin
                mulSets(setLeft);
                mulSets(setRight);
              end; {if}
            end; {if}
          end; {with}
        end; { mulSets }

        begin {sxChTerm}
          result := false;

          write(prc, '/* checking set term <');
          sxpr(prc, t);
          writeln(prc, '> */');

          {compile time check}
          elo := zlo; ehi := zhi; nsets := 0; nvars := 0;
          getLimC( t, elo, ehi, nsets, nvars);
          if elo <= ehi then begin
            if nsets + nvars = 0 then begin
              {no variable sets or var lists in subtree
               => found occupied region}
              {write(prc, ' /* [', elo:1, '..', ehi:1, '] is Occupied */ ' );}
              result := true
            end
            else begin
              {now do run-time check}
              if nvars > 0 then begin
                  {use long arithmetic because $l & $h  might be
                   +/-(maxint), then incremented/decremented }
                writeln(prc, 'if(!$r){ intmax_t $l=', elo: 1, ', $h=', ehi:1, ';');
                getLimV(t);
              end
              else begin
                write(prc, 'if(!$r){const int $l=', elo: 1,
                                      ', $h=', ehi:1, ';');
              end; {if}
              if nsets = 0 then begin
                write( prc, 'if($l<=$h) $r=1;');
              end
              else begin
                {check sets}
                writeln(prc, ' int $i=($l>>3);');
                writeln(prc, 'for(; $i<=($h>>3); $i++) { uint8_t $t=~0;');
                mulSets(t);
                writeln(prc, '  if($i==($l>>3)) $t &= ((~0)<<($l&7));' );
                writeln(prc, '  if($i==($h>>3)) $t &= (1<<(($h&7)+1))-1;');
                writeln(prc, '  if($t!=0) {$r=1; break;}} // for');
              end;
              writeln(prc, '}');
            end; {nvars > 0}
          end; {if elo < ehi}
          sxChTerm := result;
        end; { sxChTerm }

        begin {isNonEmpty}
          result := true;
          with t^ do begin
            if n = setNode then begin
              result := sxChTerm(t);
            end
            else if n = setOpNode then begin
              if setOpKind = plus then begin
                result := isNonEmpty(setleft, zlo, zhi )
                       or isNonEmpty(setRight, zlo, zhi);
              end
              else if setOpKind = mul then begin
                result := sxChTerm(t);
              end
              else begin
                writeln(prc, '>>> isNonEmpty:  unexpected setOp node' );
              end;
            end
            else begin
              writeln(prc, '>>> isNonEmpty: unexpected node kind(', ord(n):1, ')' );
            end; {if }
          end; {with}

          isNonEmpty := result;
        end; { isNonEmpty }

        begin {checkSet}
          tmpcount := 0;

          rmSide(t, 0, np);
          sxcopy(t, tCheck, false);
          sxuot(tCheck);

          if a <= b then begin
            checkSet := (a > -maxintTarget) and
                        isNonEmpty(tCheck, -maxintTarget, a-1 )
                     or (b < maxintTarget) and
                        isNonEmpty(tCheck, b+1, maxintTarget );
          end
          else begin
            checkSet := isNonEmpty(tCheck, b, a);
          end;
          sxfree(tCheck);

        end; { checkSet }


        procedure expression(fsys: setofsys); forward;


        { called from factor, assign statement,
                      with statement, & function assign
          it's approximately a get lvalue function
        parse array index, record member, pointer, file buffer }
        procedure selector(fsys: setofsys;
                           fcp: ctp;         { identifier details }
                           isAssign: boolean { read or write to item? }
                           );
        var lattr: attr; lcp: ctp; lmin,lmax: integer;
            lexpr: exprTreePtr;
            lsp  : stp;

        { selector check block,
          is fcp the name of an outer block }
        function schblk(fcp: ctp): boolean;
        var i: disprange; f: boolean;
        begin
           f := false;
           for i := level downto 2 do if display[i].bname = fcp then f := true;
           schblk := f
        end; { schblk }

        begin { selector }
          with fcp^, gattr do begin
            typtr := idtype; kind := varbl; packing := false;
            packcom := false; tagfieldg := false; ptrref := false;
            codeTree := nil;
            if klass in [vars, field, func] then
              case klass of
                vars: begin
                        if typtr <> nil then packing := typtr^.packing;
                        new( codeTree, varNode );
                        codeTree^.n := varNode;
                        codeTree^.nodeVar := fcp;
                        if vkind = actual then begin
                          { value parameter }
                          codeTree^.isVar := false;
                          access := drct;
                          vlevel := vlev;
                        end
                        else begin
                          { var parameter }
                          codeTree^.isVar := true;
                          access := indrct;
                        end;
                      end;
                field: { result of a with statement }
                       { need to put field name & level (disx) in exprtree }
                       with display[disx] do begin { disx set by searchid() }
                         new( codeTree, wfieldNode );
                         codeTree^.n := wfieldNode;
                         codeTree^.wfieldName := fcp;
                         codeTree^.fLevel := disx;
                         gattr.packcom := display[disx].packing;
                         if typtr <> nil then
                           gattr.packing := display[disx].packing or typtr^.packing;
                         gattr.ptrref := display[disx].ptrref;
                         gattr.tagfieldg := fcp^.tagfield;
                         if occur = crec then begin
                           { field is directly accessible }
                           access := drct; vlevel := clev;
                         end
                         else begin { vrec }
                           { indirect, ie via a pointer, var parameter (I think) }
                           access := indrct;
                         end
                       end;
                func: { assigning a function result }
                      { assignment to a standard function is not allowed }
                      if pfdeckind = standard then begin
                        error(150); typtr := nil
                      end
                      else begin
                        { assignment to a formal function is not allowed }
                        if pfkind = formal then error(151)
                        else
                          { assignment from inner proc not allowed either }
                          if not schblk(fcp) then error(192);
                      begin
                        new( codeTree, funcNode );
                        codeTree^.n := funcNode;
                        codeTree^.lev := pflev;
                        codeTree^.fdbg := dbg;
                        access := drct; vlevel := pflev + 1;
                      end
                      end
              end; (*case*)
          end (*with*);

          { now we have the variable,
            see if it's followed by an array, record, pointer or file symbol }
          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             { -------------- '['  array }
              repeat
                lattr := gattr;    { for each array index }
                new( lexpr, arrayNode );
                lexpr^.n := arrayNode;
                with lattr do begin
                  lexpr^.aparent := codeTree;
                  lexpr^.arrayType := typtr;
                  if typtr <> nil then begin
                    if typtr^.form <> arrays then
                      begin error(138); typtr := nil end
                  end
                  else begin
                    writeln(prc, '>>> no array type' );
                  end;
                end;
                insymbol;
                expression(fsys + [comma,rbrack]); { get the index }
                lexpr^.index := gattr.codeTree;
                { see L8163, form can't be subrange }
                if gattr.typtr <> nil then
                  if gattr.typtr^.form <> scalar then error(113);
                if lattr.typtr <> nil then
                  with lattr.typtr^ do begin
                    { still OK for conformant array }
                    lsp := inxtype;
                    { check that index type is OK }
                    if comptypes(lsp, gattr.typtr) then begin
                      {if constant, check bounds}
                      if (gattr.kind = cst) and (inxtype <> nil) then
                        checkbounds(lsp, gattr.cval.iVal, 302);
                    end
                    else error(139);
                    with gattr do begin
                      typtr := aeltype; kind := varbl;
                      codeTree := lexpr;
                      access := indrct; packing := false;
                      packcom := false; tagfieldg := false; ptrref := false;
                    end;
                    if gattr.typtr <> nil then begin
                      gattr.packcom := lattr.packing;
                      gattr.packing := lattr.packing or gattr.typtr^.packing;
                    end
                  end {with}
                else begin
                  freeTree(lexpr^.index);
                  dispose(lexpr);
                  gattr.codeTree := lattr.codeTree;
                  gattr.kind := expr;
                end;
              until sy <> comma; { until last index }
              if sy = rbrack then insymbol else error(12)
            end (*if sy = lbrack*)

            else if sy = period then begin    { ------------ '.' record.field }
              with gattr do begin
                if typtr <> nil then begin
                  { error if not a record }
                  if typtr^.form <> records then
                  begin error(140); typtr := nil end
                end;
                insymbol;
                if sy = ident then begin { expect record member }
                  if typtr <> nil then begin
                    { get member }
                    searchsection(typtr^.fstfld,lcp);
                    if lcp = nil then
                      begin error(152); typtr := nil end
                    else
                      with lcp^ do begin
                        { add member lcp to code tree }
                        new( lexpr, fieldNode );
                        lexpr^.n := fieldNode;
                        lexpr^.fieldName := lcp;
                        lexpr^.fparent := gattr.codeTree;
                        gattr.codeTree := lexpr;
                        typtr := idtype;
                        gattr.packcom := gattr.packing;
                        if typtr <> nil then
                          gattr.packing := gattr.packing or typtr^.packing;
                        gattr.tagfieldg := lcp^.tagfield;
                      end
                  end;
                  insymbol
                end (*sy = ident*)
                else error(2)
              end (*with gattr*)
            end (*if sy = period*)
            else begin                 { -------------- '^' pointer^ or file^ }
              if gattr.typtr <> nil then
                with gattr,typtr^ do
                  if form = pointer then begin
                    { add pointer to code tree }
                    new( lexpr, pointerNode );
                    lexpr^.n := pointerNode;
                    lexpr^.pparent := gattr.codeTree;
                    lexpr^.ptrType := eltype;
                    gattr.codeTree := lexpr;
                    typtr := eltype;
                    with gattr do begin
                      kind := varbl; access := indrct; packing := false;
                      packcom := false; tagfieldg := false;
                      ptrref := true;
                    end;
                  end
                  else if form = files then begin
                    new( lexpr, fBufNode );
                    lexpr^.n := fBufNode;
                    lexpr^.nodefBuf := fcp;
                    lexpr^.fBufType := typtr;
                    lexpr^.fbParent := codeTree;
                    lexpr^.lvalue := isAssign;
                    codeTree := lexpr;
                    { index buffer }
                    typtr := filtype;
                  end
                  else error(141);
              insymbol
            end;
            if not (sy in fsys + selectsys) then
              begin error(6); skip(fsys + selectsys) end
          end; (*while*)


          if gattr.typtr <> nil then
            if gattr.typtr^.form = power then begin
              new( lexpr, setNode );
              with lexpr^ do begin
                n := setNode;
                varList := nil;
                constList := nil;
                listLo := maxintTarget;
                listHi := -maxintTarget;
                sparent := gattr.codeTree;
                invert := false;
                seltype := gattr.typtr^.elset;
                gattr.codeTree := lexpr;
                getbounds( seltype, lmin, lmax );
                write( prc, ' /* [', lmin:1, '..', lmax:1, '] 3 */ ' );
              end;
            end;
        end (*selector*) ;


        procedure call(fsys: setofsys; fcp: ctp);
          var lkey: tStdNames;
              lexpr: exprTreePtr;

          procedure variable(fsys: setofsys; threaten: boolean);
            var lcp: ctp;
          begin
            if sy = ident then begin
              searchid([vars,field],lcp);
              insymbol;
              if threaten and (lcp^.klass = vars) then
                with lcp^ do begin
                  if vlev < level then threat := true;
                  if forcnt > 0 then error(195);
                end;
            end
            else begin error(2); lcp := uvarptr end;
            selector(fsys,lcp,false);
          end (*variable*) ;


          procedure getputresetrewriteprocedure;
          var modeStr : packed array[1..4] of char;
          begin
            write( prc, '({ ' );
            variable(fsys + [rparent], false);
            if gattr.typtr <> nil then
              if gattr.typtr^.form = files then
                genfp( gattr.typtr, gattr.codeTree )
              else
                error(116);
            freeTree( gattr.codeTree );
            case lkey of
              stdNget : begin { get }
                    checkdefined;
                    checkReadable;
                    write( prc, 'if($fp->flags==0) {' );
                    if gattr.typtr = textptr then begin
                      { skip unused char, check end of file }
                      writeln(prc, 'const int $c = fgetc($fp->f);' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                      writeln(prc, 'if($c == EOF) {' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                      { eof - if previous char was not eoln, file is incorrectly terminated
                        and we need to pretend that we did see an eoln
                        buffer==2 iff previous char was eoln}
                      if debug then
                        writeln(prc, 'if($fp->buffer==2) _Pfatal("get attempted when at eof",',
                                     linecount:1, ' );' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                      writeln(prc, '$fp->buffer=2;}' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                      {skipped unused char, flags already 0, buffer records eoln}
                      writeln(prc, 'else { $fp->buffer=($c==''\n''?2:1); } }' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                     {flags != 0}
                      writeln(prc, 'else { $fp->buffer=$fp->flags; $fp->flags = 0; } // get' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                    end
                    else begin {binary file}
                      if debug then begin
                        writeln(prc, 'if( fread( &$fp->buffer, sizeof($fp->buffer), 1, $fp->f)== 0 ) _Pfatal( "get failed", ',
                                      linecount:1, ');' );
                        if lnflag then writeln(prc, '#line ', linecount:1);
                      end
                      else begin
                        write( prc,'fread( &$fp->buffer, sizeof($fp->buffer), 1, $fp->f);' );
                      end;
                      {flags != 0}
                      writeln(prc, '} else {$fp->flags = 0;} // get' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                    end;
                  end;

              stdNput : begin { put }
                    checkdefined;
                    checkWritable;
                    if debug then begin
                      { TODO: error if buffer undefined }
                    end;
                    write( prc,
                          'fwrite( &$fp->buffer, sizeof($fp->buffer), 1, $fp->f); $fp->flags = ' );
                    if gattr.typtr = textptr then
                      writeln(prc, '$fp->buffer==''\n''?-1:-2; // put' )
                    else
                      writeln(prc, '-1; // put' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                  end;
              stdNreset : begin { reset }
                    if gattr.typtr = textptr then begin
                      writeln(prc, 'if($fp->flags==-2) putc(''\n'',$fp->f);' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                      modeStr := ' "r"';
                    end
                    else
                      modeStr := '"rb"';
                    writeln(prc, 'if( $fp->name != NULL ) { // reset' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, 'if( $fp->f != NULL )' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, '$fp->f = freopen($fp->name, ',
                          modeStr, ', $fp->f);' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, 'else' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, '$fp->f = fopen($fp->name, ',
                                modeStr, ');' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, '} else {' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    checkdefined;
                    writeln(prc, 'rewind($fp->f);}' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    write( prc, 'if( $fp->f == NULL )' );
                    writeln(prc, '_Pfatal("file not found or reset error", ',
                                  linecount:1, ');' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    if gattr.typtr = textptr then begin
                      write( prc, '$fp->buffer=2;' );
                    end;
                    writeln(prc, '$fp->flags=0;' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                  end;

              stdNrewrite : begin { rewrite }
                    if gattr.typtr = textptr then
                      modeStr := ' "w"'
                    else
                      modeStr := '"wb"';
                    writeln(prc, 'if( $fp->name != NULL ) { // rewrite' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, 'if( $fp->f != NULL )' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, '$fp->f = freopen($fp->name, ',
                                modeStr, ', $fp->f);' );
                    writeln(prc, 'else' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, '$fp->f = fopen($fp->name, ',
                                modeStr, ');' );
                    writeln(prc, '} else {' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, 'if( $fp->f != NULL ) fclose($fp->f);' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, '$fp->f = tmpfile();' );
                    writeln(prc, '}' );
                    if debug then begin
                      write( prc, 'if( $fp->f == NULL )' );
                      writeln(prc, '_Pfatal("file rewrite error", ',
                                     linecount:1, ');//FileNotFound' );
                    end;
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    writeln(prc, ' $fp->flags = -1;' );
                  end;
            end; { case }
            write( prc, '})' );
          end (*getputresetrewrite*) ;

          procedure pageprocedure;
          begin
            if sy = lparent then
            begin insymbol;
              variable(fsys + [rparent], false);
              if gattr.typtr <> nil then
                if gattr.typtr <> textptr then
                  error(116)
                else begin
                  write( prc, '({ text *const $fp = &' );
                  genCExpr( gattr.codeTree );
                end;
              freeTree( gattr.codeTree );
              if sy = rparent then insymbol else error(4)
            end
            else if outputhdf then begin {no parens}
              write( prc, '({ text *const $fp = &' );
              writeId( outputptr );
              outputPtr^.refer := true;
            end
            else error(176); {no output}
            writeln(prc, ';' );
            if lnflag then writeln(prc, '#line ', linecount:1);
            checkdefined;
            checkWritable;
            writeln(prc, 'if($fp->flags == -2) fputc( ''\n'', $fp->f );' );
            if lnflag then writeln(prc, '#line ', linecount:1);
            writeln(prc, 'if($fp->flags < 0) {fputc( ''\f'', $fp->f ); $fp->flags = -1;} });' );
            if lnflag then writeln(prc, '#line ', linecount:1);
          end (*page*) ;

          procedure readprocedure;
            var lsp       : stp;
                txt       : boolean; { is a text file }
                test      : boolean;
                chkflags  : boolean; { check if flags are zero}
                lmin,lmax : integer;
                iexpr     : exprTreePtr; { input expression }
          begin
            txt := true;
            chkflags := true;
            writeln(prc, '({' );
            if lnflag then writeln(prc, '#line ', linecount:1);
            if sy = lparent then begin
              insymbol;
              variable(fsys + [comma,rparent], true);
              lsp := gattr.typtr; test := false;
              if lsp <> nil then
                if lsp^.form = files then
                  with gattr do begin
                    genfp( typtr, codeTree );
                    freeTree(codeTree);
                    checkdefined;
                    checkReadable;
                    txt := lsp = textptr;

                    { read(f,v) <=> v:=f^; get(f)
                      if flags == 0 then pascal read is equivalent to c readchar
                    }

                    { readln is valid only for text }
                    if not txt and (lkey = stdNreadln) then error(116);

                    if sy = rparent then begin
                      if lkey = stdNread then error(116);
                      test := true
                    end
                    else
                      if sy <> comma then
                      begin error(116); skip(fsys + [comma,rparent]) end;
                    if sy = comma then begin
                      insymbol;
                      variable(fsys + [comma,rparent], true)
                    end
                    else test := true
                  end {with}
                else if inputhdf then begin {param is not a file}
                  write(prc, 'text *const $fp = &' );
                  writeId( inputPtr );
                  writeln(prc, ';');
                  if lnflag then writeln(prc, '#line ', linecount:1);
                  inputPtr^.refer := true;
                end
                else error(175);

              if not test then
                repeat
                  iexpr := gattr.codeTree;
                  if txt then begin
                    if gattr.typtr <> nil then
                      if gattr.typtr^.form <= subrange then begin
                        if comptypes(intptr, gattr.typtr) then begin
                          if chkflags then begin
                            chkflags := false;
                            writeln(prc, 'if( $fp->flags>0 ) ungetc(($fp->flags==2? ''\n'': $fp->buffer), $fp->f);' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                          end;

                          writeln(prc, '$fp->buffer=1;' );  {it will become 2 iff read char == \n}
                          if lnflag then writeln(prc, '#line ', linecount:1);

                          writeln(prc, '({ intmax_t $i;' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                          {TODO: to better catch overflow, read into a string
                                 then convert to integer
                          }
                          writeln( prc, 'const int $r = fscanf( $fp->f, "%"SCNdMAX, &$i);' );
                          if debug then begin
                            writeln(prc,
                                    'if($r!=1) _Pfatal("read integer failed",',
                                    linecount:1, ');' );
                            getbounds(gattr.typtr, lmin, lmax);
                            writeln(prc, 'if( $i>', lmax:1,
                                          '|| $i<', lmin:1, ')' );
                            writeln(prc, '_Pfatal("value read is out of range",',
                                           linecount:1, ');' );
                          end;
                          if lnflag then writeln(prc, '#line ', linecount:1);
                          genCExpr( iexpr );
                          writeln(prc, ' = $i;});' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                        end
                        else if comptypes(realptr,gattr.typtr) then begin
                          if chkflags then begin
                            chkflags := false;
                            writeln(prc, 'if( $fp->flags>0 ) ungetc(($fp->flags==2? ''\n'': $fp->buffer), $fp->f);' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                          end;


                          writeln(prc, '$fp->buffer=1;' );  {it will become 2 iff read char == \n}
                          if lnflag then writeln(prc, '#line ', linecount:1);

                          if debug then
                            write( prc, 'if(' );
                          write( prc, 'fscanf( $fp->f, " %lf", &' );
                          genCExpr( iexpr );
                          if debug then
                            write( prc, ')!=1) _Pfatal("read real failed",',
                                         linecount:1 );
                          writeln(prc, ' );' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                        end
                        else if comptypes(charptr,gattr.typtr) then begin
                          { read char, convert \n to space, check end of file }
                          genCExpr( iexpr );
                          write( prc, ' = ' );
                          if chkflags then begin
                            chkflags := false;
                            {if char already fetched, use it}
                            writeln(prc, '$fp->flags>0 ? ({char $c = $fp->buffer; $fp->buffer=$fp->flags; $c;}) : ' );
                            if lnflag then writeln(prc, '#line ', linecount:1);
                          end;
                          { read char, convert \n to space }
                          writeln(prc, '({int $c = fgetc($fp->f);' );
                          if debug then
                            writeln(prc, 'if($c==EOF && $fp->buffer==2) _Pfatal("attempted read char at eof",', linecount:1, ');' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                          write( prc, 'if( $c==''\n'' || $c==EOF) { ' );
                          writeln(prc, '$c = '' ''; $fp->buffer=2;} else $fp->buffer=1;' );
                          if debug then begin
                            getbounds(gattr.typtr, lmin, lmax);
                            write(prc, 'if( $c>', lmax:1,
                                          '|| $c<', lmin:1, ')' );
                            writeln(prc, '_Pfatal("value read is out of range",',
                                           linecount:1, ');' );
                          end;
                          if lnflag then writeln(prc, '#line ', linecount:1);
                          writeln(prc, ' $c;});' );
                          if lnflag then writeln(prc, '#line ', linecount:1);

                        end
                        else error(399);
                      end
                    else error(116);
                  end
                  else begin { binary file }
                    if not comptypes(gattr.typtr,lsp^.filtype) then error(129);
                    { only first item to be read }
                    if chkflags then begin
                      chkflags := false;
                      writeln(prc, 'if( $fp->flags>0)' );
                      if lnflag then writeln(prc, '#line ', linecount:1);

                      genCExpr( iexpr );
                      writeln(prc, ' = $fp->buffer;' );
                      writeln(prc, 'else');
                      if lnflag then writeln(prc, '#line ', linecount:1);
                    end;

                    { TODO: debug is it necessary to check value read is
                            within bounds of var?? }
                    if gattr.packcom then begin
                      { read into packed record variable }
                      writeln(prc, '{ int $n = fread(&$fp->buffer, ',
                                    'sizeof($fp->buffer), 1, $fp->f);' );
                      if debug then begin
                        writeln(prc, 'if($n != 1)',
                              '_Pfatal("read failed", ', linecount:1, ');' );
                      end;
                      if lnflag then writeln(prc, '#line ', linecount:1);
                      genCExpr( iexpr );
                      writeln(prc, ' = $fp->buffer;}' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                    end
                    else if debug then begin
                      write( prc, 'if(fread(&' );
                      genCExpr( iexpr );
                      writeln(prc, ', sizeof($fp->buffer), 1, $fp->f) != 1)',
                              '_Pfatal("read failed", ', linecount:1, ');' );
                    end
                    else begin
                      write( prc, 'fread(&' );
                      genCExpr( iexpr );
                      writeln(prc, ', sizeof($fp->buffer), 1, $fp->f);' );
                    end;
                    if lnflag then writeln(prc, '#line ', linecount:1);
                  end;
                  test := sy <> comma;
                  freeTree(iexpr);
                  if not test then begin
                    insymbol;
                    variable(fsys + [comma,rparent], true)
                  end;
                until test;
              if sy = rparent then insymbol else error(4);

            end
            else begin { no parens }
              if inputhdf then begin
                write(prc, 'text *const $fp = &' );
                writeId( inputPtr );
                writeln(prc, ';');
                if lnflag then writeln(prc, '#line ', linecount:1);
                inputPtr^.refer := true;
              end
              else error(175);
              if lkey <> stdNreadln then error(116);    { only readln can have no params }
            end;


            if lkey = stdNreadln then begin
              { skip to newline.
                optimisation: if flags == 2 then already done }
              if chkflags then begin
                write( prc, 'if($fp->flags!=2) ' );
              end;

              writeln(prc, '{ int $c=fgetc($fp->f);' );
              if debug then begin
                write(prc, 'if($c==EOF && ' );
                if chkflags then begin
                  chkflags := false;
                  write( prc, '$fp->flags==0 &&  ' );
                end;
                writeln(prc, '$fp->buffer==2)', '_Pfatal("attempted read char at eof",',
                             linecount:1, ');' );
              end;
              if lnflag then writeln(prc, '#line ', linecount:1);
              writeln(prc, 'while(($c != EOF) && ($c != ''\n'')) $c=fgetc($fp->f);} //readln' );
              write( prc, '$fp->buffer = 2; ' );
            end;

            writeln(prc, '$fp->flags = 0;' );
            writeln(prc, '})' );
            if lnflag then writeln(prc, '#line ', linecount:1);
          end (*readprocedure*) ;


          procedure writeprocedure;
          var
            lsp,lsp1         : stp;
            isTotWid, isPrec : boolean;   { field width present }
            isvWid, isvPrec  : boolean;   { field width, precision is an expression }
            cWid, cWid1      : integer;   { field width, precision if constant}
            len              : integer;
            emax, ewid       : integer;
            txt              : boolean;   { is a text file }
            vattr            : attr;      { attributes of value to write }
            test             : boolean;   { true iff no more params }
            oexpr            : exprTreePtr; { output expression }
            wexpr            : exprTreePtr; { width expression }
            pexpr            : exprTreePtr; { precision expression }
            testFlags        : boolean;

              { TODO: concatenate separate segments into one printf,
                      not forgetting \n at the end }
          begin
           txt := true;
           testFlags := true;
           writeln(prc, '({' );
           if lnflag then writeln(prc, '#line ', linecount:1);
           if sy = lparent then begin
             insymbol;
             expression(fsys + [comma,colon,rparent]);
             lsp := gattr.typtr; test := false;
             if lsp <> nil then begin
               if lsp^.form = files then begin
                 { the first param is a file }
                 with gattr do begin
                   genfp( typtr, codeTree );
                   freeTree( codeTree );
                   checkdefined;
                   checkWritable;
                   lsp1 := lsp;
                   txt := lsp = textptr;
                   { writeln allowed for text files only }
                   if not txt and (lkey = stdNwriteln) then error(116);

                   if sy = rparent then begin
                     { write must have parameters }
                     if lkey = stdNwrite then error(116);
                     test := true
                   end
                   else if sy <> comma then
                   begin error(116); skip(fsys + [comma,rparent]) end;
                   if sy = comma then begin
                     insymbol;
                     expression(fsys + [comma,colon,rparent]);
                   end
                   else test := true
                 end { with }
               end
               else if outputhdf then begin {param is not a file}
                 write(prc, 'text *const $fp = &' );
                 writeId( outputPtr );
                 writeln(prc, ';');
                 if lnflag then writeln(prc, '#line ', linecount:1);
                 outputPtr^.refer := true;
               end
               else error(176); { output not present in header }
             end
             else if outputhdf then begin
               {assume writing to output}
               outputPtr^.refer := true;
             end;

            if not test then
            repeat
              { loop for each parameter to write }
              oexpr := gattr.codeTree;
              vattr := gattr;
              lsp := gattr.typtr;
              if txt then begin
                 isvWid := false; isvPrec := false;
                 if sy = colon then begin
                    { get field width }
                    insymbol;
                    expression(fsys + [comma,colon,rparent]);
                    wexpr := gattr.codeTree;
                    if gattr.typtr <> nil then begin
                      if gattr.typtr <> intptr then
                         error(116);
                       if gattr.kind = cst then begin
                          cWid := gattr.cval.ival; { field width }
                       end
                       else begin
                          isvWid := true;
                       end;
                    end;
                    isTotWid := true
                end
                else isTotWid := false;
                if sy = colon then begin
                    { get decimal places width }
                    insymbol;
                    expression(fsys + [comma,rparent]);
                    pexpr := gattr.codeTree;
                    if gattr.typtr <> nil then begin
                      if gattr.typtr <> intptr then
                         error(116);
                      if gattr.kind = cst then begin
                        cWid1 := gattr.cval.ival; { precision }
                        if cwid1 < 0 then error(209);
                      end
                      else begin
                        isvPrec := true;
                      end;
                    end;
                    { legal ony when writing a real nr }
                    if lsp <> realptr then error(208);
                    isPrec := true
                end else isPrec := false;

                if lsp = intptr then begin                   { ----- integer }
                   if isvWid then begin
                      write( prc, 'fprintf( $fp->f, "%*i", (int)' );
                      genCExpr( wexpr );
                      write( prc, ', (int)' );
                   end
                   else if isTotWid then begin
                      write( prc, 'fprintf( $fp->f, "%', cWid:1, 'i", (int)' );
                   end
                   else
                      write( prc, 'fprintf( $fp->f, "%i", (int)' );
                   genCExpr(oexpr);
                   writeln(prc,  ' );' );
                   if lnflag then writeln(prc, '#line ', linecount:1);
                end

                else if lsp = realptr then begin             { ----- real }
                  { use temp var to avoid  re-evaluating wexpr }
                  write( prc, '({' );
                  if isvWid then begin
                    write( prc, 'const int $w = ' );
                    genCExpr( wexpr );
                    writeln(prc, ';' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                  end;
                  write( prc, 'const double $o = ' );
                  genCExpr( oexpr );
                  writeln(prc, ';' );
                  if lnflag then writeln(prc, '#line ', linecount:1);

                  if isPrec then
                    write( prc, 'fprintf( $fp->f, "%#' )
                  else
                    write( prc, 'fprintf( $fp->f, "% #' ); { force leading space or sign }
                  if isvWid then
                    write( prc, '*' )
                  else if isTotWid then
                    write( prc, cWid:1 );

                  if isvPrec then
                    write( prc, '.*f"' )
                  else if isPrec then
                    write( prc, '.', cWid1:1, 'f"' )
                  else begin
                    if isTotWid then begin
                       { totalWid is specified, but precision isn't
                         totalWid = leading ' d.' + precision + 'e+00'
                         so precision needs to be fw - 7 (assuming 2 digit exponents)
                         but sometimes we need 3 digits for the exponent
                       }
                      write( prc, '.*')
                    end;
                    write( prc, 'e"' );
                  end;

                  if isvWid then begin
                    write( prc, ', $w' );
                  end;
                  if isvPrec then begin
                    if debug then begin
                      write( prc, ', ({const int $p=' );
                      genCExpr( pexpr );
                      write( prc,
                            '; if($p<=0) _Pfatal("real format precision must be > 0",',
                             linecount:1, '); $p;})' );
                    end
                    else begin
                      write( prc, ', (int)' );
                      genCExpr( pexpr );
                    end;
                  end;
                  if not isPrec and isTotWid then begin

                    write( prc, ', ({const int $extra = ' );
                    emax := 100; ewid := 7;
                    if REAL_MAX_EXP >= emax then begin
                      write( prc, 'fabs($o)<=0.0 ||' );
                      repeat
                        write( prc, ' (fabs($o)<1.0e', emax:1,
                              ' && fabs($o)>1.0e-', emax:1, ')? ', ewid:1, ' : ' );
                        emax := emax*10; ewid := ewid+1;
                      until REAL_MAX_EXP < emax;
                    end;
                    writeln( prc, ewid:1, ';' );

                    if isVwid then
                      writeln(prc, 'const int $precision = $w - $extra;' )
                    else
                      writeln(prc, 'const int $precision = ', cwid:1, ' - $extra;' );
                    writeln(prc, '($precision > 0)? $precision: 1; })' );
                  end;
                  writeln( prc, ', $o ); });' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                end


                else if lsp = charptr then begin             { ----- char }
                   if isvWid then begin
                      write( prc, 'fprintf( $fp->f, "%*c", (int)' );
                      genCExpr( wexpr );
                      write( prc, ', (char)' )
                   end
                   else if isTotWid then
                      write( prc, 'fprintf( $fp->f, "%', cWid:1, 'c", (char)' )
                   else
                      write( prc, 'fprintf( $fp->f, "%c", (char)' );
                   genCExpr( oexpr );
                   writeln(prc, ' );' );
                   if lnflag then writeln(prc, '#line ', linecount:1);
                end

                else if lsp = boolptr then begin             { ----- boolean }
                   if isvWid then begin
                     write( prc, '({ const int $w = ' );
                     genCExpr( wexpr );
                     writeln(prc, ';' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                     write( prc, 'if(' );
                     genCExpr( oexpr );
                     writeln(prc, ') ', 'fprintf( $fp->f, "%*.*s", $w, (abs($w)<4?abs($w):4), "true" );' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                     writeln(prc, 'else ', 'fprintf( $fp->f, "%*.*s", $w, (abs($w)<5?abs($w):5), "false" ); });' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                   end
                   else if isTotWid then begin
                     if abs(cWid) <= 4 then begin
                       write( prc, 'fprintf( $fp->f, "%', cWid:1, '.', abs(cWid):1, 's", (' );
                       genCExpr( oexpr );
                       writeln(prc, ')? "true" : "false" );' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end
                     else begin
                       write( prc, 'if(' );
                       genCExpr( oexpr );
                       write( prc, ') fprintf( $fp->f, "%', cWid:1 );
                       write( prc, '.4s", "true");' );
                       writeln( prc, 'else fprintf( $fp->f, "%', cWid:1, '.5s", "false" );' );
                       if lnflag then writeln(prc, '#line ', linecount:1);
                     end
                   end
                   else begin
                     write( prc, 'fprintf( $fp->f, "%s", (' );
                     genCExpr( oexpr );
                     writeln(prc, ')? "true" : "false" );' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                   end;
                end
                else if lsp <> nil then begin
                   if lsp^.form = scalar then error(399)
                   else if lsp^.form = pointer then begin    { ----- pointer }
                     if isvWid then begin
                       write( prc, 'fprintf( $fp->f, "%*p", (int)' );
                       genCExpr( wexpr );
                     end
                     else if isTotWid then begin
                       write( prc, 'fprintf( $fp->f, "%', cWid:1, 'p"' );
                     end
                     else
                       write( prc, 'fprintf( $fp->f, "%p"' );
                     write( prc, ', (void*)' );
                     genCExpr(oexpr);
                     writeln(prc,  ' );' );
                     if lnflag then writeln(prc, '#line ', linecount:1);
                   end
                   else if isString(lsp) then begin            { ----- string }

                      { for pascal, make precision min(w,len) }
                      if vattr.kind = cst then begin
                        len := vattr.cval.valp^.slgth;
                        { const str OK as is }
                        writeln(prc, '/* const string, len is ', len:1, ' */' );
                        if lnflag then writeln(prc, '#line ', linecount:1);
                        if isvWid then begin
                          writeln(prc, '{' );
                          write( prc, '  const int $w1 = (int)' );
                          genCExpr( wexpr );
                          writeln(prc, ';  const int $w2 = (abs($w1)<', len:1,
                                   ')? abs($w1): ', len:1, ';' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                            write( prc, 'fprintf( $fp->f, "%*.*s", $w1, $w2, ' );
                            genCExpr(oexpr);
                            writeln(prc, ' );}' );
                        end
                        else if isTotWid then begin
                            if abs(cWid) < len then
                               len := abs(cWid);
                            write( prc,
                                  'fprintf( $fp->f, "%', cWid:1, '.', len:1, 's", ' );
                            genCExpr( oexpr );
                            writeln(prc, ' );' );
                         end
                         else begin
                            write( prc, 'fprintf( $fp->f, "%s", ');
                            genCExpr( oexpr );
                            writeln(prc, ' );' );
                         end;
                         if lnflag then writeln(prc, '#line ', linecount:1);
                      end
                      else begin
                        len := lsp^.inxtype^.smax;
                        writeln(prc, '/* string var, len is ', len:1, ' */' );
                        if lnflag then writeln(prc, '#line ', linecount:1);
                        if isvWid then begin
                          writeln(prc, '{' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                          write( prc, '  const int $t1 = (int)' );
                          genCExpr( wexpr );
                          writeln(prc, ';  const int $t2 = (abs($t1)<', len,
                                          ')? abs($t1): ', len:1, ';' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                          write( prc, 'fprintf( $fp->f, "%*.*s", $t1, $t2, ' );
                          genCExpr( oexpr );
                          writeln(prc, '.component );}' );
                          if lnflag then writeln(prc, '#line ', linecount:1);
                         end
                         else if isTotWid then begin
                            if abs(cWid) < len then
                               len := abs(cWid);
                            write( prc, 'fprintf( $fp->f, "%', cWid:1, '.',
                                  len:1, 's", ' );
                            genCExpr( oexpr );
                            writeln(prc, '.component );' );
                           if lnflag then writeln(prc, '#line ', linecount:1);
                         end
                         else begin
                            write( prc, 'fprintf( $fp->f, "%.',
                                    len:1, 's", ' );
                            genCExpr( oexpr );
                            writeln(prc, '.component );' );
                           if lnflag then writeln(prc, '#line ', linecount:1);
                         end;
                      end;
                   end
                   else error(116);
                end
                else begin {writeln('>>> lsp is nil')} end;
                if testFlags then begin { line not yet terminated }
                  writeln(prc, '$fp->flags = -2;' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                  testFlags := false;
                end;
                if isTotWid then
                   freeTree( wexpr );
                if isPrec then
                   freeTree( pexpr );
              end else begin { write binary data file }
                if not comptypes(lsp1^.filtype,lsp) then error(129);
                write( prc, '$fp-> buffer = ' );
                genCExpr( oexpr );
                writeln(prc, ';' );
                if lnflag then writeln(prc, '#line ', linecount:1);
                writeln(prc, 'fwrite( &$fp->buffer, sizeof($fp->buffer), 1, $fp->f); $fp->flags = -1; // write' );
                if lnflag then writeln(prc, '#line ', linecount:1);
              end;
              freeTree( oexpr );
              test := sy <> comma;
              if not test then begin
                 insymbol;
                 expression(fsys + [comma,colon,rparent]);
              end
            until test;
            if sy = rparent then insymbol else error(4)
           end else begin
              { no parens, output must be in header and must be a writeln }
              if outputhdf then begin
                write(prc, 'text *const $fp = &' );
                writeId( outputPtr );
                writeln(prc, ';');
                if lnflag then writeln(prc, '#line ', linecount:1);
                outputPtr^.refer := true;
              end
              else error(176); { output not present in header }
              if lkey <> stdNwriteln then error(116);
           end;
           if lkey = stdNwriteln then begin (*writeln*)
             writeln(prc, 'fprintf( $fp->f, "\n");' );
             if lnflag then writeln(prc, '#line ', linecount:1);
             writeln(prc, '$fp->flags = -1;' );     { flag eoln }
             if lnflag then writeln(prc, '#line ', linecount:1);
           end;
           write( prc, '})' );
         end (*writeprocedure*) ;


          procedure packprocedure;
          { TODO: error unless src is packed, dst is unpacked}
          var lsp,lsp1 : stp; lattr: attr;
            iexpr      : exprTreePtr;
            lo, hi : integer;
          begin
            write( prc, '({' );
            lsp := nil; lsp1 := nil;
            variable(fsys + [comma,rparent], false); { pack from this array }
            if gattr.typtr <> nil then
              with gattr.typtr^ do
                if form = arrays then begin
                  if packing then error(-4); {array must not be packed}
                  lsp := inxtype; lsp1 := aeltype;
                  if confFlag then begin
                    write( prc, 'const int $lo2=' );
                    writeId( lowbound );
                    write( prc, ', $hi2=' );
                    writeId( highbound );
                  end
                  else begin
                    getbounds(lsp, lo, hi );
                    write( prc, 'const int $lo2=', lo:1, ', $hi2=', hi:1 );
                  end;
                end
                else
                  error(116); { can pack only from an array }

            lattr := gattr;

            if sy = comma then insymbol else error(20);
            expression(fsys + [comma,rparent]); { index into src array }
            iexpr := gattr.codeTree;
            { check index has correct type }
            if gattr.typtr <> nil then
              if gattr.typtr^.form <> scalar then error(116)
              else
                if not comptypes(lsp, gattr.typtr) then error(116);

            if sy = comma then insymbol else error(20);
            variable(fsys + [rparent], false); { get destination }

            { check arrays are campatible }
            if gattr.typtr <> nil then
              with gattr.typtr^ do
                if form = arrays then begin
                  if not packing then error(-5); {array must be packed}
                  if confFlag then begin
                    write( prc, ', $lo1=' );
                    writeId( lowbound );
                    write( prc, ', $hi1=' );
                    writeId( highbound );
                    writeln(prc, ';' );
                  end
                  else begin
                    getbounds(inxtype, lo, hi ); {dst}
                    writeln(prc, ', $lo1=', lo:1, ', $hi1=', hi:1, ';' );
                  end;
                  if lnflag then writeln(prc, '#line ', linecount:1);
                  if not comptypes(aeltype, lsp1) then error(116)
                  else if filecomponent(aeltype) then error(146);
                end
                else error(116);

            if (gattr.typtr <> nil) and (lattr.typtr <> nil) then begin
              { require iexpr + (nr component dst) <= (nr component src) }
              { TODO: if these are const, do compile time check }
              write( prc, 'memcpy( ' );
              genCExpr( gattr.codeTree );
              write( prc, '.component, ' );
              genCExpr( lattr.codeTree );
              write( prc, '.component - $lo2 + ' );
              if debug then begin
                { iexpr <= hi2-hi1+lo1 }
                write( prc, '({ int $i = ' );
                genCExpr( iexpr );
                writeln(prc, '; if($i>$hi2-$hi1+$lo1 || $i<$lo2) ',
                              '_Pfatal("pack bounds error", ', linecount:1, '); $i;})' );
                if lnflag then writeln(prc, '#line ', linecount:1);
              end
              else
                genCExpr( iexpr );
              write( prc, ', sizeof( ' );
              genCExpr( gattr.codeTree );
              writeln(prc, ' )); // pack()' );
              if lnflag then writeln(prc, '#line ', linecount:1);

            end;
            freeTree( lattr.codeTree );
            freeTree( gattr.codeTree );
            freeTree( iexpr );
            write( prc, '})' );
          end (*pack*) ;


          procedure unpackprocedure;
          { TODO: error unless dst is packed, src is unpacked }
          var lsp,lsp1: stp; lattr,lattr1: attr;
              lo, hi : integer;
          begin
            write( prc, '({' );
            lsp := nil; lsp1 := nil;
            variable(fsys + [comma,rparent], false); { packed src array }
            if gattr.typtr <> nil then
              with gattr.typtr^ do
                if form = arrays then begin
                  if not packing then error(-5); {array must be packed}
                  lsp1 := aeltype;
                  if confFlag then begin
                    write( prc, 'const int $lo1=' );
                    writeId( lowbound );
                    write( prc, ', $hi1=' );
                    writeId( highbound );
                  end
                  else begin
                    getbounds( inxtype, lo, hi);
                    write( prc, 'const int $lo1=', lo:1, ', $hi1=', hi:1 );
                  end
                end
                else error(116);
            lattr := gattr;

            if sy = comma then insymbol else error(20);
            variable(fsys + [comma,rparent], false); { unpacked dst array }
            lattr1 := gattr;
            if gattr.typtr <> nil then
              with gattr.typtr^ do
                if form = arrays then begin
                  if packing then error(-4); {array must not be packed}
                  lsp := inxtype;
                  if confFlag then begin
                    write( prc, ', $lo2=' );
                    writeId( lowbound );
                    write( prc, ', $hi2=' );
                    writeId( highbound );
                    writeln(prc, ';' );
                  end
                  else begin
                    getbounds(inxtype, lo, hi ); {dst}
                    writeln(prc, ', $lo2=', lo:1, ', $hi2=', hi:1, ';' );
                  end;
                  if lnflag then writeln(prc, '#line ', linecount:1);
                  if not comptypes(aeltype, lsp1) then error(116)
                  else if filecomponent(aeltype) then error(146);
                end
                else error(116);

            if sy = comma then insymbol else error(20);
            expression(fsys + [rparent]); { index into dst }
            if gattr.typtr <> nil then
              if gattr.typtr^.form <> scalar then error(116)
              else
                if not comptypes(lsp, gattr.typtr) then error(116);

            if (lattr.typtr <> nil) and (lattr1.typtr <> nil) then begin
              { require iexpr + (nr component src) <= (nr component dst) }
              { TODO: if these are const, do compile time check }
              write( prc, 'memcpy( ' );
              genCExpr( lattr1.codeTree ); { dst }
              if debug then begin
                write( prc, '.component - $lo2 + ({ int $i = ' );
                genCExpr( gattr.codeTree ); { offset in dst }
                write( prc, '; if($i>$hi2-$hi1+$lo1 || $i<$lo2) ',
                        ' _Pfatal("unpack bounds error", ', linecount:1,
                        '); $i;}), ' );
              end
              else begin
                write( prc, '.component - $lo2 + ' );
                genCExpr( gattr.codeTree ); { offset in dst }
                write( prc, ', ' );
              end;
              genCExpr( lattr.codeTree ); { src }
              write( prc, '.component, sizeof( ' );
              genCExpr( lattr.codeTree );
              writeln(prc, ' )); // unpack()' );
              if lnflag then writeln(prc, '#line ', linecount:1);
            end; {if}
            freeTree( lattr.codeTree );
            freeTree( lattr1.codeTree );
            freeTree( gattr.codeTree );
            write( prc, '})' );
          end (*unpack*) ;


          procedure newdisposeprocedure;
            label 1;
            var lsp,lsp1: stp;
                lval: valu;
                lexpr: exprTreePtr;
                mtype : stp;

            procedure prPtr;
            begin
              write( prc, '(*$p)');
            end; { prPtr }

          begin
            {dispose can take an expression as well as a variable}
            if lkey = stdNnew then begin
              variable(fsys + [comma,rparent], false);
            end
            else
              expression(fsys + [comma,rparent]);
            lexpr := gattr.codeTree;
            lsp := nil;
            mtype := nil;
            if gattr.typtr <> nil then
              with gattr.typtr^ do
                if form = pointer then begin
                  mtype := eltype;
                  if eltype <> nil then begin
                    if eltype^.form = records then
                      lsp := eltype^.recvar
                  end
                end
                else error(116); {arg wasn't a pointer}

            { if lsp is nil, or points to the variant
              allocate memory for largest variant }
            { TODO: allocate memory for a particular combination of variants? }
            while sy = comma do begin
              { loop thru the tag constants }
              insymbol;
              constant(fsys + [comma,rparent],lsp1,lval); { get tag constant }
              (*debug check: is constant in tagfieldtype range*)
              if lsp = nil then error(158)
              else if lsp^.form <> tagfld then
                error(162) {this should not be possible}
              else if lsp^.tagfieldp <> nil then
                if isString(lsp1) or (lsp1 = realptr) then
                  error(159)
                else if comptypes(lsp^.tagfieldp^.idtype, lsp1) then begin
                  lsp1 := lsp^.fstvar;
                  { scan thru variants until one matches tag constant }
                  while lsp1 <> nil do
                    with lsp1^ do
                      if varval = lval.ival then begin
                        { tag matches constant }
                        lsp := subvar;
                        goto 1 { found match, so break out of loop }
                      end
                      else lsp1 := nxtvar;
                  lsp := nil;
                end
                else error(116);
1:          end (*while*) ;

            if lkey = stdNnew then begin
              if memDebug or debug then begin
                write( prc, '({ ' );
                genTypeOf( lexpr );
                write( prc, ' $p ' );
              end
              else
                genCExpr( lexpr );
              write( prc, ' = calloc( 1, sizeof( ' );
              genCType( mtype, false );
              write( prc, '))' );
              if memDebug or debug then begin
                writeln(prc, ';' );
                writeln(prc, 'if($p==NULL) _Pfatal("out of memory", ',
                               linecount:1, ');' );
                if lnflag then writeln(prc, '#line ', linecount:1);
                genCExpr( lexpr );
                writeln(prc, ' = $p;' );
                if memDebug then
                  write( prc, '_Padd_mem( &_Proot, $p, ', linecount:1, ' );' );
                write(prc, '})' );
              end;
            end
            else begin
              write( prc, '({ ' );
              genTypeOf( lexpr );
              write( prc, ' $p=');
              genCExpr( lexpr );
              writeln(prc, '; ' );
              if lnflag then writeln(prc, '#line ', linecount:1);
              if fileComponent(mtype) then begin
                write( prc, '// dispose - closing files (' );
                genCtype(mtype, false);
                writeln(prc, ')' );
                if lnflag then writeln(prc, '#line ', linecount:1);
                genCloseFiles(mtype, prPtr);
              end;
              if memDebug then begin
                write( prc, '_Pfree_mem( _Proot, $p, ', linecount:1, ');' );
              end
              else begin
                write( prc, 'free($p);' );
              end;
              write( prc, '})' );
            end;
            freeTree( lexpr );
          end (*newdisposeprocedure*) ;

          procedure checkIntReal;
          begin
            if gattr.typtr <> nil then
              if (gattr.typtr <> intptr) and
                 (gattr.typtr <> realptr) then
              begin error(125); gattr.typtr := intptr end
          end; { checkIntReal }

          procedure checkReal;
          begin
            if gattr.typtr <> nil then
              if gattr.typtr <> realptr then error(125);
            gattr.typtr := intptr
          end; { checkReal }

          procedure oddfunction;
          begin
            if gattr.typtr <> nil then
              if gattr.typtr <> intptr then error(125);
            gattr.typtr := boolptr
          end (*odd*) ;

          procedure ordfunction;
          begin
            if gattr.typtr <> nil then
              { ord(pointer) allowed! }
              if (gattr.typtr = realptr) or   {!!! bug fix}
                 (gattr.typtr^.form >= power) then error(125);
            gattr.typtr := intptr
          end (*ord*) ;

          procedure chrfunction;
          begin
            if gattr.typtr <> nil then
              if gattr.typtr <> intptr then error(125);
            gattr.typtr := charptr
          end (*chr*) ;

          procedure predsuccfunction;
          begin
            if gattr.typtr <> nil then
              if (gattr.typtr = realptr) or  {!!! bug fix}
                 (gattr.typtr^.form <> scalar) then begin
                   error(125);
                   gattr.typtr := nil;
              end;
          end (*predsucc*) ;

          procedure eofeolnfunction;
          var
            lexpr: exprTreePtr;
          begin
            new(lexpr, stdNode);
            lexpr^.n := stdNode;
            lexpr^.key := lkey;

            if sy = lparent then begin
              insymbol;
              variable(fsys + [rparent], false);
              lexpr^.arg := gattr.codeTree;
              if gattr.typtr <> nil then
                if gattr.typtr^.form <> files then error(125)
                else if (lkey = stdNeoln) and (gattr.typtr <> textptr) then
                  error(116);
              if sy = rparent then insymbol else error(4)
            end
            else if inputhdf then begin {no parens}
              new(lexpr^.arg, varNode );
              with lexpr^.arg^ do begin
                n := varNode;
                isvar := false;
                nodeVar := inputptr;
              end;
              with gattr do begin
                typtr := textptr; kind := varbl; access := drct;
                packing := false; vlevel := inputptr^.vlev;
                inputPtr^.refer := true;
              end
            end
            else begin
              error(175);
            end;

            lexpr^.argType := gattr.typtr;
            gattr.codeTree := lexpr;
            gattr.typtr := boolptr;
            if lexpr^.argType = textptr then {dbg}
              write( prc, '/* eof/eoln on text file */ ' )
            else
              write( prc, '/* eof on bin file */ ' )
          end (*eof*) ;

          procedure callnonstandard;
            var nxt,lcp: ctp;
                lsp, lspof, lspoa: stp;
                lb: boolean;
                varp: boolean;
                lexpr: exprTreePtr;
                xPar, prevPar : pfParamPtr;

        { determine if the formal conformant array parameter fspf
          is conformable to the actual array parameter fspa.
          see pascal standard, 6.6.3.8 }
        function conformable(fspf, fspa: stp): boolean;
        var
          test: boolean;
          lspf,lspa: stp;
          lminf,lmina,lmaxf,lmaxa: integer;
        begin { conformable }

          if (fspf = fspa) or (fspf = nil) or (fspa = nil) then begin
            conformable := true;
          end
          else if (fspf^.form <> arrays) or (fspa^.form <> arrays) then
            conformable := false
          else begin
            test := fspf^.confFlag;

            if test then
              test := conformable(fspf^.aeltype, fspa^.aeltype);

            if test then
              test := fspf^.packing = fspa^.packing;

            lspf := fspf^.inxtype;
            if test and (lspf <> nil) then begin
              { check the indexes and bounds }

              lspa := fspa^.inxtype;
              test := comptypes(lspf, lspa);

              if test and (lspa <> nil) then begin
                getbounds(lspa, lmina, lmaxa);
                getbounds(lspf, lminf, lmaxf);
                if fspa^.confFlag then begin
                  { need overlapping ranges }
                  test := (lmina <= lmaxf) and (lmaxa >= lminf);
                end
                else begin
                  { actual param is a fixed array }
                  test := (lmina >= lminf) and (lmaxa <= lmaxf)
                end; { lspa^.confFlag }
              end; { lspa <> nil }
            end; { lspf <> nil }

            conformable := test;
          end; {if fspf=fspa ...}
        end; { conformable }


          { determine if parameter lists plf and pla are congruous
            plf is formal parameter list, pla is actual parameter list
            see pascal standard, 6.6.3.6
            - var/value match
            - proc/func match & parameters are congruous
            - identical function return types
            - var/value conf arrays & equivalent
              - index types are the same
              - pack/unpack match
              - the components are identical or equivalent
          }
          procedure congruous(plf, pla: ctp);
          var test : boolean;
              oldPlfType, oldPlaType: stp;

          { return true iff array parameters fsp1 and fsp2 are equivalent }
            function equivalent(fsp1, fsp2: stp): boolean;
            begin
              if (fsp1 = nil) or (fsp2 = nil) or (fsp1 = fsp2) then
                equivalent := true
              else if (fsp1^.form <> arrays) or (fsp2^.form <> arrays) then
                equivalent := false
              else { conformant array }
                equivalent := fsp1^.confFlag and fsp2^.confFlag and
                (fsp1^.packing = fsp2^.packing) and
                equivalent(fsp1^.aeltype, fsp2^.aeltype) and
                equivalent(fsp1^.inxtype, fsp2^.inxtype);
            end; {equivalent}

          begin {congruous}
            { TODO: can the error numbers be different for different errors?
                    use error numbers 210..219 ?}

            if plf^.klass <> pla^.klass then begin
              {we wouldn't be here if the klasses were different,
               but handle it anyway }
              error(189)
            end
            else if plf^.klass = func then begin
              {for iso conformance the types should be the same,
               see standard 6.6.3.5}
              if (plf^.idtype <> pla^.idtype)
                      and (plf^.idtype <> nil)
                      and (pla^.idtype <> nil)
              then
                error(128);
            end;

            oldPlfType := nil; oldPlaType := nil;
            plf := plf^.pflist; pla := pla^.pflist;
            while (plf <> nil) and (pla <> nil) do begin

              test := plf^.klass = pla^.klass;     { !!! bug fix }

              if test then
                if plf^.klass = vars then begin    { !!! bug fix }
                  test := plf^.vkind = pla^.vkind; { var/value mismatch }

                  if test then
                    { error if actuals are grouped & formals aren't or vice versa }
                    if isConfArray(plf^.idType) and
                        ((plf^.idtype = oldPlfType) or (pla^.idtype = oldPlaType))
                    then
                      test := (plf^.idtype = oldPlfType) and (pla^.idtype = oldPlaType)
                    else
                      test := equivalent(plf^.idtype, pla^.idtype);
                end
                else if plf^.klass in [proc, func] then begin
                  congruous(plf, pla);  { !!! bug fix }
                end
                else begin
                  writeln( '*** unknown parameter class (', ord(plf^.klass), ') ***' );
                end;

              if not test then
                error(189);

              oldPlfType := plf^.idType; oldPlaType := pla^.idType;
              plf := plf^.next; pla := pla^.next
            end;
            if (plf <> nil) or (pla <> nil) then error(189)
          end; {congruous}

          begin (* callnonstandard *)
            new( lexpr, callNode );
            lexpr^.n := callNode;
            lexpr^.firstPar := nil; { there might be an arg list }
            lexpr^.nodeFunc := fcp;
            with fcp^ do begin
                nxt := pflist;
            end; { with }
            if sy = lparent then begin

              { loop thru the params, nxt is formal param list }
              lspof := nil; lspoa := nil;
              repeat
                lb := false; (*decide whether proc/func must be passed*)
                if nxt = nil then error(126)
                else
                  lb := nxt^.klass in [proc,func];
                insymbol;
                if lb then begin  (*pass function or procedure*)
                  if sy <> ident then
                    begin error(2); skip(fsys + [comma,rparent]) end
                  else begin
                    {NB: always return id of correct klass, even if undeclared id}
                    searchid([nxt^.klass], lcp);

                    { compare signatures }
                    congruous(nxt, lcp);
                    new( xPar );
                    with xPar^ do begin
                      parType := lcp^.idtype;
                      next := nil;
                      parAccess := funcParam;
                      new( parExpr );
                      with parExpr^ do begin
                        n := fparNode;
                        fPar := lcp;
                      end;
                    end;
                    if lexpr^.firstPar = nil then
                      lexpr^.firstPar := xPar
                    else
                      prevPar^.next := xPar;
                    prevPar := xPar;
                    insymbol;
                    if not (sy in fsys + [comma,rparent]) then
                    begin error(6); skip(fsys + [comma,rparent]) end
                  end;
                  lsp := nil; {this was not var or value param}
                end (*if lb*)
                else begin
                  { var or value param }
                  varp := false;
                  if nxt <> nil then
                    varp := nxt^.vkind = formal;
                  if varp then begin
                    {write( prc, ' /* var arg*/ ' );}
                    variable(fsys + [comma,rparent], true);
                    if gattr.typtr = nil then error(154);
                  end
                  else begin
                    {write( prc, ' /* value arg*/ ' );}
                    expression(fsys + [comma,rparent]);
                  end;

                  if gattr.typtr <> nil then begin
                    if nxt <> nil then begin
                      lsp := nxt^.idtype; { formal param type }
                      if lsp <> nil then begin
                        new( xPar );
                        with xPar^ do begin
                          parType := lsp;
                          next := nil;
                          parExpr := gattr.codeTree;
                        end;
                        if lexpr^.firstPar = nil then
                          lexpr^.firstPar := xPar
                        else
                          prevPar^.next := xPar;
                        prevPar := xPar;
                        if nxt^.vkind = actual then begin
                          { value param }
                          xPar^.parAccess := valueParam;
                          if lsp^.form <= power then begin
                            if comptypes(realptr,lsp)
                               and (gattr.typtr = intptr)
                            then begin
                              gattr.typtr := realptr
                            end;
                          end
                          else if isString(lsp) or isConfArray(lsp) then begin
                            with xPar^.parExpr^ do begin
                              if (n = constNode) and
                                 (constType = charptr)
                                then begin
                                  {replace char with string length 1}
                                  mkStrConst(constType, 1);
                                  gattr.typtr := constType;
                                end;
                            end;
                          end;

                          if isConfArray( lsp ) then begin
                            { TODO: maybe this test should be for all params,
                                    not just conf array params? }
                            if lsp = lspof then begin
                              { this param is part of the same group as the
                                the previous param, so the actual arguments
                                must have identical types }
                              if gattr.typtr <> lspoa then
                                error(127);
                            end
                            else if not conformable(lsp, gattr.typtr) then begin
                              error(142); { TODO: need better messages }
                            end;
                          end
                          else if comptypes(lsp, gattr.typtr) then begin
                            if (gattr.kind = cst) and
                              (lsp^.form <= subrange) and
                              (lsp <> intptr) and
                              (lsp <> realptr)
                            then
                              checkbounds(lsp, gattr.cval.iVal, 303);
                          end
                          else
                            error(142)

                        end else begin
                          { var param }
                          xPar^.parAccess := varParam;
                          if gattr.packcom then error(197);
                          if gattr.tagfieldg then error(198);
                          if isConfArray( lsp ) then begin
                            if lsp = lspof then begin
                              { this param is part of the same group as the
                                the previous param, so the actual arguments
                                must have identical types }
                              if gattr.typtr <> lspoa then
                                error(127);
                            end
                            else if not conformable(lsp, gattr.typtr) then begin
                              error(199); { TODO: need better messages }
                            end;
                          end
                          else if lsp <> gattr.typtr then error(199)
                        end
                      end { if lsp ... }
                    end { if nxt ... }
                    else
                      freeTree(gattr.codeTree);
                  end { if gattr.typtr ... }
                  else
                    freeTree(gattr.codeTree);
                end;
                lspof := lsp; lspoa := gattr.typtr;
                if nxt <> nil then
                  nxt := nxt^.next { next formal param }
              until sy <> comma; { until no more parameters }
              if sy = rparent then insymbol else error(4)
            end (*if lparent*);
            if nxt <> nil then error(126);  { !!! bug fix }
            if fcp^.klass = proc then begin
               genCExpr( lexpr );
               freeTree( lexpr );
            end
            else begin
               gattr.codeTree := lexpr;
            end;
            gattr.typtr := fcp^.idtype;
          end (*callnonstandard*) ;

        begin (*call*)
          if fcp^.pfdeckind = standard then begin
            lkey := fcp^.key;
            if fcp^.klass = proc then begin
              if not(lkey in [stdNread, stdNwrite, stdNreadln,
                              stdNwriteln, stdNpage]) then
                if sy = lparent then insymbol else error(9);
              case lkey of
                stdNget,stdNput,
                stdNreset,stdNrewrite:   getputresetrewriteprocedure;
                stdNpage:                pageprocedure;
                stdNread,stdNreadln:     readprocedure;
                stdNwrite,stdNwriteln:   writeprocedure;
                stdNpack:                packprocedure;
                stdNunpack:              unpackprocedure;
                stdNnew,stdNdispose:     newdisposeprocedure;
              end;

              if not(lkey in [stdNread, stdNwrite, stdNreadln,
                              stdNwriteln, stdNpage]) then
                if sy = rparent then insymbol else error(4)
            end
            else begin { standard functions }
              if (lkey in [stdNtrunc..stdNsucc]) then begin
                if sy = lparent then insymbol else error(9);
                expression(fsys + [rparent]);
                new( lexpr, stdNode );
                lexpr^.n := stdNode;
                lexpr^.key := lkey;
                lexpr^.argType := gattr.typtr;
                lexpr^.arg := gattr.codeTree;
                gattr.codeTree := lexpr;

                case lkey of
                  stdNtrunc,
                  stdNround:         checkReal;
                  stdNabs,
                  stdNsqr:           checkIntReal;
                  stdNodd:           oddfunction;
                  stdNord:           ordfunction;
                  stdNchr:           chrfunction;
                  stdNpred,stdNsucc: predsuccfunction;
                end;

                if sy = rparent then insymbol else error(4);
              end
              else if (lkey = stdNeof) or (lkey = stdNeoln) then begin
                eofeolnfunction
              end;
            end;
            gattr.kind := expr;
          end (*standard procedures and functions*)
          else callnonstandard
        end (*call*) ;


        procedure expression;
          var lattr : attr; lop: operator;
              lexpr : exprTreePtr;

          procedure simpleexpression(fsys  : setofsys);
            var lattr: attr; lop: operator; signed: boolean;
                lexpr: exprTreePtr;

            procedure term(fsys: setofsys);
              var lattr: attr; lop: operator;
                  lexpr: exprTreePtr;

              procedure factor(fsys: setofsys);
                var lcp: ctp;
                    lsp: stp;
                    tattr, rattr: attr;
                    haveComma: boolean;
                    errFlag: boolean;
                    lexpr: exprTreePtr;
                    tlo, thi : integer;
                    c1 : constElementPtr; { helps build set const part }
                    v1 : varElementPtr;   { helps build set var part }
              begin
                { check and recover if error found }
                if not (sy in facbegsys) then begin
                  error(58); skip(fsys + facbegsys);
                end;
                gattr.typtr := nil;
                gattr.codeTree := nil;
                while sy in facbegsys do begin
                   case sy of
                     ident: begin              { ------------  identifier }
                         searchid([konst,vars,boundid,field,func], lcp);
                         insymbol;
                         if lcp^.klass = func then begin
                           { function parameters }
                           call(fsys,lcp);
                           with gattr do begin
                             kind := expr;
                             if typtr <> nil then
                               if typtr^.form=subrange then
                                 typtr := typtr^.rangetype
                           end;
                         end
                         else if lcp^.klass = konst then begin
                           { write out constant value }
                           with gattr, lcp^ do begin
                             typtr := idtype; kind := cst;
                             cval := values;
                             new( codeTree, constNode );
                           end;
                           with gattr.codeTree^ do begin
                             n := constNode;
                             nodeCval := lcp^.values;
                             constType := lcp^.idtype;
                           end;
                         end
                         else begin
                           { array index, record member, pointer, file buffer }
                           if lcp^.klass = boundid then begin
                             with lcp^, gattr do begin
                               kind := varbl; typtr := idtype;
                               access := drct;
                               vlevel := lev;
                               tagfieldg := false;
                               packing := false;
                               packcom := false;
                               new( codeTree, varNode );
                               with codeTree^ do begin
                                 n := varNode;
                                 nodeVar := lcp;
                                 isVar := false;
                               end; {with}
                             end;
                           end { klass boundid }
                           else begin
                             selector(fsys,lcp,false);
                           end;

                           { L8163 elim. subr. types to simplify later tests }
                           { NB: this also scuppers prospects of using the
                                 subrange info later on}
                           if gattr.typtr <> nil then
                             with gattr,typtr^ do
                               if form = subrange then
                                 typtr := rangetype
                         end
                       end;

                     (*cst*)
                     intconst:              { ------------  constant }
                       begin
                         with gattr do begin
                           typtr := intptr; kind := cst;
                           cval := val;
                           new( codeTree, constNode );
                         end;
                         with gattr.CodeTree^ do begin
                           n := constNode;
                           nodeCval := val;
                           constType := intptr;
                         end;
                         insymbol
                       end;
                     realconst:
                       begin
                         with gattr do begin
                           typtr := realptr; kind := cst;
                           cval := val;
                           new( codeTree, constNode );
                           with codeTree^ do begin
                             n := constNode;
                             nodeCval := val;
                             constType := realptr;
                           end;
                         end;
                         insymbol
                       end;

                     stringconst: begin
                         with gattr do begin
                           if lgth = 1 then
                             typtr := charptr
                           else
                             mkStrConst(typtr, lgth);
                           kind := cst;
                           cval := val;
                           new( codeTree, constNode );
                           with codeTree^ do begin
                             n := constNode;
                             nodeCval := val;
                             constType := typtr;
                           end;
                         end; { with }
                         insymbol;
                       end;

                     { ( }
                     lparent: begin             { ------------  open paren }
                         insymbol;
                         expression(fsys + [rparent]);
                         if gattr.typtr <> nil then
                           if (gattr.typtr^.form <> power) and
                             (gattr.kind <> cst) and (gattr.kind <> varbl)
                           then begin
                             { preserve parens unless sets or single items }
                             new( lexpr, unopnode );
                             lexpr^.n := unopnode;
                             lexpr^.unOpKind := parenOp;
                             lexpr^.operand := gattr.codeTree;
                             gattr.codeTree := lexpr;
                           end;
                         if sy = rparent then begin
                           insymbol
                         end
                         else error(4)
                       end;
                     (*not*)
                     notsy:              { ------------  not }
                       begin
                         new( lexpr, unopNode );
                         lexpr^.n := unopNode;
                         lexpr^.unOpKind := notOp;
                         insymbol;
                         factor(fsys);
                         with gattr do begin
                           kind := expr;
                           lexpr^.operand := codeTree;
                           codeTree := lexpr;
                           if typtr <> nil then
                             { error if operand is not boolean }
                             if typtr <> boolptr then begin
                               error(135);
                               typtr := nil
                             end;
                         end; {with}
                       end;

                     (*[*)
                     lbrack: begin        { ------------  [...] set }
                         insymbol;
                         new(lsp, power); pshstc(lsp);
                         with lsp^ do begin
                           typeName := nil; hasFile := false;
                           form:=power; elset:=nil;
                           packing := false; matchpack := false
                         end;
                         new( lexpr, setNode );
                         with lexpr^ do begin
                           n := setNode;
                           varList := nil;
                           constList := nil;
                           listLo := maxintTarget;
                           listHi := -maxintTarget;
                           sparent := nil;
                         end;
                         if sy = rbrack then begin { found empty set }
                           gattr.kind := cst;
                           insymbol
                         end
                         else begin
                           { loop to get each set element }
                           errFlag := false;
                           repeat
                             expression(fsys + [comma,range,rbrack]);
                             test := errFlag; {true iff previous element was in error}
                             if gattr.typtr <> nil then begin
                               if (gattr.typtr^.form <> scalar) or
                                  (gattr.typtr = realptr)
                               then begin
                                 error(136); gattr.typtr := nil
                               end
                               else if not comptypes(lsp^.elset, gattr.typtr) then begin
                                   if not test then {write error if it's new}
                                   begin error(137); test := true end; {incompatible types}
                               end
                             end;
                             if gattr.typtr = nil then
                               freeTree( gattr.codeTree )
                             else
                               lsp^.elset := gattr.typtr; { TODO: is subrange info lost here? }

                             rattr.typtr := nil; rattr.codeTree := nil;
                             if sy = range then begin
                               insymbol;
                               tattr := gattr;
                               expression(fsys + [comma,rbrack]);
                               if gattr.typtr <> nil then begin
                                 if (gattr.typtr^.form <> scalar) or
                                    (gattr.typtr = realptr)   {!!! bug fix}
                                 then begin
                                   error(136); gattr.typtr := nil
                                 end
                                 else if not comptypes(lsp^.elset,gattr.typtr) then begin
                                   if not test then {write error if it's new}
                                   begin error(137); test := true; end;
                                 end;
                               end;
                               if gattr.typtr = nil then
                                 freeTree( gattr.codeTree )
                               else
                                 lsp^.elset := gattr.typtr; { TODO: is subrange info lost here? }

                               if tattr.typtr <> nil then begin
                                 rattr := gattr; gattr := tattr;
                               end;
                             end;

                             errFlag := not errFlag and test; {new error or clear errorFlag}

                             { gattr & rattr describe valid set elements
                               or typtr is nil,
                               rattr <> nil => a range of set elements }
                             if gattr.typtr <> nil then begin
                               { process if type of element is correct }
                               if rattr.typtr <> nil then begin { x..y form }
                                 { if a constant range found, and it's in
                                 range then add to constant part }
                                 if (gattr.kind = cst) and
                                   (rattr.kind = cst)
                                 then begin
                                   new( c1 );
                                   with c1^ do begin
                                     next := lexpr^.constList;
                                     isRange := true;
                                     elvalue := gattr.cval.ival;
                                     hiValue := rattr.cval.ival;
                                     with lexpr^ do begin
                                       if elvalue < listLo then
                                         listLo := elvalue;
                                       if hivalue > listHi then
                                         listHi := hivalue;
                                       {write( prc, '/* ', elvalue:1, '..', hivalue:1, ' */' );}
                                     end;
                                   end; { with }
                                   freeTree(gattr.codeTree);
                                   freeTree(rattr.codeTree);
                                   lexpr^.constList := c1;
                                 end
                                 else begin { variable part }
                                   new( v1 );
                                   with v1^ do begin
                                     next := lexpr^.varList;
                                     isRange := true;
                                     elvalue := gattr.codeTree;
                                     hiValue := rattr.codeTree;
                                     writeln(prc, '/* x..y */' );
                                     if lnflag then writeln(prc, '#line ', linecount:1);
                                   end; { with }
                                   lexpr^.varList := v1;
                                 end;
                               end
                               else begin { not range }
                                 { if const add to const part }
                                 if gattr.kind = cst then begin
                                   new( c1 );
                                   with c1^ do begin
                                     next := lexpr^.constList;
                                     isRange := false;
                                     elvalue := gattr.cval.ival;
                                   end;
                                   with c1^, lexpr^ do begin
                                     if elvalue < listLo then
                                       listLo := elvalue;
                                     if elvalue > listHi then begin
                                       listHi := elvalue;
                                     end;
                                     constList := c1;
                                   end;
                                   freeTree(gattr.codeTree);
                                 end
                                 else begin { var part }
                                   new( v1 );
                                   with v1^ do begin
                                     next := lexpr^.varList;
                                     isRange := false;
                                     elvalue := gattr.codeTree;
                                   end;
                                   lexpr^.varList := v1;
                                 end
                               end;
                             end;

                             { continue until no more elements }
                             haveComma := sy = comma;
                             if haveComma then insymbol
                           until not haveComma;
                           gattr.kind := expr;
                           if sy = rbrack then insymbol else error(12)
                         end; {not empty set}

                         with lexpr^ do begin
                           seltype := lsp^.elset;
                           if varlist <> nil then begin
                             getbounds( seltype, tlo, thi );
                             if tlo < listLo then
                               listLo := tlo;
                             if thi > listHi then
                               listHi := thi;
                           end;
                         end;
                         gattr.typtr := lsp;
                         gattr.codeTree := lexpr;
                       end;

                     (*nil*)              { ------------  nil }
                     nilsy: begin
                               with gattr do begin
                                 typtr := nilptr; kind := cst;
                                 new( codeTree, constNode );
                               end;
                               with gattr.codeTree^ do begin
                                 n := constNode;
                                 constType := nilptr;
                               end;
                               insymbol;
                            end
                    end (*case*) ;
                    { if the following symbol is unexpected,
                      look for a factor and try to parse that }
                    if not (sy in fsys) then begin
                      error(6); skip(fsys + facbegsys);
                      freeTree( gattr.codeTree );
                      gattr.codeTree := nil;
                    end;
                end; (*while*)
              end (*factor()*) ;

            begin (*term()*)
              factor(fsys + [mulop]);
              while sy = mulop do begin
                 lattr := gattr;
                 lop := op;
                 insymbol;
                 factor(fsys + [mulop]);
                 if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin

                   case lop of
            (***)     mul:  if (lattr.typtr<>intptr) or (gattr.typtr<>intptr)
                            then begin
                              { convert int to real then multiply }
                              if lattr.typtr = intptr then begin
                                lattr.typtr := realptr
                              end
                              else if gattr.typtr = intptr then begin
                                gattr.typtr := realptr
                              end;
                              if (lattr.typtr = realptr)
                                  and (gattr.typtr=realptr) then
                              else if (lattr.typtr^.form=power) and
                                    comptypes(lattr.typtr,gattr.typtr) then begin
                                { set intersection }
                              end
                              else
                                begin error(134); gattr.typtr:=nil end
                            end;
            (* / *)   rdiv: begin
                              if gattr.typtr = intptr then begin
                                 gattr.typtr := realptr
                              end;
                              if lattr.typtr = intptr then begin
                                  lattr.typtr := realptr
                                end;
                              if (lattr.typtr <> realptr)
                                or (gattr.typtr <> realptr)
                              then begin error(134); gattr.typtr := nil end
                            end;
            (*div*)   idiv: if (lattr.typtr = intptr)
                               and (gattr.typtr = intptr)
                            then begin
                                { check for division by zero}
                              if (gattr.kind = cst) and
                                ( gattr.cval.ival = 0)
                              then
                                error(300);
                            end
                            else begin error(134); gattr.typtr := nil end;
            (*mod*)   imod: if (lattr.typtr = intptr)
                              and (gattr.typtr = intptr)
                            then begin
                                { check for division by zero}
                              if (gattr.kind = cst) and
                                ( gattr.cval.ival = 0)
                              then
                                error(300);
                            end
                            else begin error(134); gattr.typtr := nil end;
            (*and*)   andop:if (lattr.typtr = boolptr)
                              and (gattr.typtr = boolptr) then
                            else begin error(134); gattr.typtr := nil end
                   end; { case }

                   if gattr.typtr <> nil then begin {no error found}

                     if lattr.typtr^.form = power then begin
                       { TODO: make this a subroutine, see add }
                       new( lexpr, setOpNode );
                       with lexpr^ do begin
                         n := setOpNode;
                         setOpKind := lop; { * }
                         setLeft := lattr.codeTree;
                         setRight := gattr.codeTree;
                         findResBounds( lexpr );
                         locked := false;
                       end;
                       gattr.kind := expr;
                       gattr.codeTree := lexpr;
                     end
                     else if {false and}
                       (lattr.typtr=intptr) and (gattr.typtr=intptr) and
                       (gattr.kind = cst) and (lattr.kind = cst)
                     then begin
                       {merge two constant integers}
                       with gattr.CodeTree^.nodeCval do begin
                         if iVal <> 0 then begin
                           case lop of
                             mul  :
                               if abs(lattr.Cval.ival) > maxint div abs(iVal)
                               then
                                 error(204)
                               else
                                 iVal := lattr.Cval.ival * ival;
                             idiv :
                                 iVal := lattr.Cval.ival div ival;
                             imod :
                                 iVal := lattr.Cval.ival mod ival;
                           end; {case}
                         end; {if}
                         gattr.cval.ival := ival;
                       end; {with}
                       freeTree(lattr.codetree);
                     end
                     else begin
                       new( lexpr, binOpNode );
                       lexpr^.n := binOpNode;
                       with lexpr^ do begin
                         binOpKind := lop;
                         binOpType := gattr.typtr;
                         left := lattr.codeTree;
                         right := gattr.codeTree;
                       end;
                       gattr.kind := expr;
                       gattr.codeTree := lexpr;
                     end;
                   end
                   else {if gattr.typtr}
                     freeTree(lattr.codeTree);
                 end
                 else begin
                   gattr.typtr := nil;
                   freeTree( lattr.codeTree );
                 end;
              end; (*while*)
            end (*term()*) ;

         {sexpr1 & sexpr2 are sets, one is just a list, so
          merge it into the other one}
         function mergeSets(sexpr1, sexpr2: exprTreePtr): exprTreePtr;
         var
           resExpr : exprTreePtr;
           t1      : exprTreePtr;
           c1      : constElementPtr;
           v1      : varElementPtr;
         begin

           if sexpr1^.sparent = nil then begin
             write(prc, ' /* merge left + right --> result */ ' );
             t1 := sexpr1;
             resExpr := sexpr2;
           end
           else if sexpr2^.sparent = nil then begin
             write(prc, ' /* merge right + left --> result */ ' );
             t1 := sexpr2;
             resExpr := sexpr1;
           end;

           with resExpr^ do begin

             {TODO: the constant lists could be sorted (binary tree?)
                    and consecutive constants merged
                    ==> later operations much more efficient}
             {merge constant lists}
             c1 := constList;
             if c1 = nil then
               constList := t1^.constList
             else begin
               while c1^.next <> nil do
                 c1 := c1^.next;
               c1^.next := t1^.constList;
             end;
             if listLo > t1^.listLo then
               listLo := t1^.listLo;
             if listHi < t1^.listHi then
               listHi := t1^.listHi;

             {merge variable lists}
             v1 := VarList;
             if v1 = nil then begin
               VarList := t1^.varList;
             end
             else begin
               while v1^.next <> nil do
                 v1 := v1^.next;
               v1^.next := t1^.varList;
             end;

             if selType = nil then selType := t1^.selType;
           end; {with}

           dispose(t1);

           mergeSets := resExpr;
         end; { mergeSets }


          begin (*simpleexpression()*)
            signed := false;
            if (sy = addop) and (op in [plus,minus]) then begin
              signed := true;
              lop := op;
              insymbol
            end;
            term(fsys + [addop]);

            if signed then begin
              if (gattr.typtr = intptr) or (gattr.typtr = realptr) then begin
                if lop = minus then begin
                  { optimisation: convert -ve integer constant from
                    expression to constant }
                  if (gattr.kind = cst) and
                     (gattr.typtr = intptr) and
                     { assuming short circuit boolean expr }
                     (gattr.CodeTree^.n = constNode)
                  then begin
                    with gattr.CodeTree^.nodeCval do begin
                      if iVal < -maxint then
                        error(204)
                      else begin
                        iVal := -ival;
                        gattr.cval.ival := -gattr.cval.ival;
                      end;
                    end; {with}
                  end
                  else begin
                    new( lexpr, unOpNode );
                    lexpr^.n := unOpNode;
                    with lexpr^ do begin
                      if gattr.typtr = intptr then
                        unOpKind := minusOpi
                      else
                        unOpKind := minusOp;
                      operand := gattr.codeTree;
                    end;
                    gattr.codeTree := lexpr;
                    gattr.kind := expr;
                  end
                end
              end
              else
              begin error(134); gattr.typtr := nil end;
            end; { if signed }

            while sy = addop do begin
              lattr := gattr; lop := op;
              insymbol;
              term(fsys + [addop]);
              if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin

                case lop of
          (*+*)   plus:
                    if (lattr.typtr = intptr) and (gattr.typtr = intptr) then
                    else begin
                      if lattr.typtr = intptr then begin
                        lattr.typtr := realptr
                      end
                      else if gattr.typtr = intptr then begin
                        gattr.typtr := realptr
                      end;
                      if (lattr.typtr = realptr) and (gattr.typtr = realptr)
                        then
                      else if(lattr.typtr^.form=power) and
                                 comptypes(lattr.typtr,gattr.typtr) then begin
                        { set union }
                      end
                      else begin error(134); gattr.typtr:=nil end
                    end;
          (*-*)   minus:
                    if (lattr.typtr = intptr) and (gattr.typtr = intptr) then
                    else begin
                      if lattr.typtr = intptr then begin
                        lattr.typtr := realptr
                      end
                      else if gattr.typtr = intptr then begin
                        gattr.typtr := realptr
                      end;
                      if (lattr.typtr = realptr) and
                               (gattr.typtr = realptr) then
                      else if (lattr.typtr^.form = power) and
                             comptypes(lattr.typtr,gattr.typtr) then begin
                      end
                      else begin error(134); gattr.typtr := nil end
                    end;
          (*or*)  orop:
                    if (lattr.typtr=boolptr) and (gattr.typtr=boolptr) then
                    else begin error(134); gattr.typtr := nil end
                end; {case}

                if gattr.typtr <> nil then begin {no error found}

                  if lattr.typtr^.form = power then begin

                    if (lop = plus)
                      and (lattr.codeTree^.n = setNode)
                      and (gattr.codeTree^.n = setNode)
                      and ((lattr.codeTree^.sparent = nil)
                           or (gattr.codeTree^.sparent = nil))
                    then begin
                      {special case: one of the sets is just a list
                      ==> keep the other one, merge the lists
                      and make the node a set node
                      this avoids creating an extra set }

                      lexpr := mergeSets(lattr.codeTree, gattr.codeTree);

                    end
                    else begin

                      new( lexpr, setOpNode );
                      with lexpr^ do begin

                        n := setOpNode;
                        setOpKind := lop; { +, - }
                        setLeft := lattr.codeTree;
                        setRight := gattr.codeTree;

                        findResBounds( lexpr );
                        locked := false;
                      end; { with }
                    end; { if not special case }
                    gattr.codeTree := lexpr;
                    gattr.kind := expr;
                  end {if power}
                  else if {false and}
                    (lattr.typtr=intptr) and (gattr.typtr=intptr) and
                    (gattr.kind = cst) and (lattr.kind = cst)
                  then begin

                    {merge two constant integers}
                    with gattr.CodeTree^.nodeCval do begin
                      case lop of
                        plus  :
                            if ((ival < 0) and
                               (lattr.Cval.ival < -maxint - iVal)) or
                               ((ival > 0) and
                               (lattr.Cval.ival > maxint - iVal))
                            then
                              error(204)
                            else
                              iVal := lattr.Cval.ival + ival;
                        minus :
                            if ((ival > 0) and
                               (lattr.Cval.ival < -maxint + iVal)) or
                               ((ival < 0) and
                               (lattr.Cval.ival > maxint + iVal))
                            then
                              error(204)
                            else
                               iVal := lattr.Cval.ival - ival;
                      end; {case}
                      gattr.cval.ival := ival;
                    end; {with}
                    freeTree(lattr.codetree);
                  end
                  else begin {not constants}

                    new( lexpr, binOpNode );
                    with lexpr^ do begin
                      n := binOpNode;
                      binOpKind := lop;
                      binOpType := gattr.typtr;
                      left := lattr.codeTree;
                      right := gattr.codeTree;
                    end;
                    gattr.codeTree := lexpr;
                    gattr.kind := expr;
                  end
                end {if no error found}
                else
                  freeTree(lattr.codeTree);
              end
              else begin
                gattr.typtr := nil;
                freeTree( lattr.codeTree )
              end;
            end; (*while*)
          end (*simpleexpression()*) ;

        begin (*expression()*)
          simpleexpression(fsys + [relop]);
          if sy = relop then begin
            lattr := gattr; lop := op;
            insymbol;
            simpleexpression(fsys);

            if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin
              if lop = inop then
                if gattr.typtr^.form = power then
                  if comptypes(lattr.typtr, gattr.typtr^.elset) then begin
                    { TODO: is this common code? }
                    new( lexpr, setOpNode );
                    with lexpr^ do begin
                      n := setOpNode;
                      setOpKind := inop;
                      setLeft := lattr.codeTree;
                      setRight := gattr.codeTree;
                      getbounds( gattr.typtr^.elset, resLo, resHi );
                      locked := false;
                    end;
                    gattr.codeTree := lexpr;
                    { set in operator }
                  end
                  else begin
                    error(129);
                    freeTree( lattr.codeTree ); gattr.typtr := nil
                  end
                else begin
                  error(130);
                  freeTree( lattr.codeTree ); gattr.typtr := nil
                end
              else begin { not inop }
                if lattr.typtr <> gattr.typtr then begin
                  if lattr.typtr = intptr then begin
                    lattr.typtr := realptr
                  end
                  else if gattr.typtr = intptr then begin
                    gattr.typtr := realptr
                  end
                  else if isString(lattr.typtr) then begin
                    with gattr.codeTree^ do begin
                      if (n = constNode) and (constType = charptr) then begin
                        {replace char with string length 1}
                        mkStrConst(constType,1);
                        gattr.typtr := constType;
                      end;
                    end;
                  end
                  else if isString(gattr.typtr) then begin
                    with lattr.codeTree^ do begin
                      if (n = constNode) and (constType = charptr) then begin
                        {replace char with string length 1}
                        mkStrConst(constType,1);
                        lattr.typtr := constType;
                      end;
                    end;
                  end;
                end;
                if comptypes(lattr.typtr, gattr.typtr) then begin
                  lexpr := nil;
                  case lattr.typtr^.form of
                    scalar: begin
                        new( lexpr, binOpNode );
                        with lexpr^ do begin
                          n := binOpNode;
                          binOpKind := lop;
                          binOpType := gattr.typtr;
                          left := lattr.codeTree;
                          right := gattr.codeTree;
                        end; {with}
                      end;
                    pointer: begin
                        if lop in [ltop,leop,gtop,geop] then
                          error(131)
                        else begin
                          new( lexpr, binOpNode );
                          with lexpr^ do begin
                            n := binOpNode;
                            binOpKind := lop;
                            binOpType := gattr.typtr;
                            left := lattr.codeTree;
                            right := gattr.codeTree;
                          end; {with}
                        end;
                      end;
                    power: begin
                        if lop in [ltop,gtop] then
                          error(132)
                        else begin
                          { TODO: subroutine this }
                          new( lexpr, setOpNode );
                          with lexpr^ do begin
                            n := setOpNode;
                            setOpKind := lop; { compare op }
                            setLeft := lattr.codeTree;
                            setRight := gattr.codeTree;
                            locked := false;
                            findResBounds( lexpr );
                          end; { with }
                        end;
                      end;
                    arrays: begin
                        if not isString(lattr.typtr) then
                          error(134)
                        else begin
                          new( lexpr, strOpNode );
                          with lexpr^ do begin
                            n := strOpNode;
                            strOpKind := lop;
                            strLeft := lattr.codeTree;
                            strRight := gattr.codeTree;
                            lvar := lattr.kind <> cst;
                            rvar := gattr.kind <> cst;
                            if rvar then begin
                              slen := gattr.typtr^.inxtype^.smax;
                            end
                            else begin
                              slen := gattr.typtr^.slen;
                            end;
                          end; {with}
                        end;
                      end;
                    records:
                      begin error(134); end;
                    files:
                      begin error(133); end
                  end; { case }
                  if lexpr <> nil then
                    gattr.codeTree := lexpr
                  else
                    freeTree( lattr.codeTree );
                end
                else begin {incompatible types}
                  error(129);
                  freeTree( lattr.codeTree );
                end;
              end { not inop }
            end {valid typtr}
            else
              freeTree( lattr.codeTree );
            gattr.typtr := boolptr;
            gattr.kind := expr
          end; (*sy = relop*)
        end (*expression*) ;


        { ctp is the variable (or start of say something.m[i])
          plain old data is direct
          pointers, var params & arrays & records are indirect
        }
        procedure assignment(fcp: ctp);
          var lattr: attr;
              lvar, lexpr : exprTreePtr;
              lo, hi : integer;
        begin
          selector(fsys + [becomes],fcp,true);
          lvar := gattr.codeTree;

          if sy = becomes then begin
            { if function result, set assigned }
            if fcp^.klass = func then begin
              if fcp^.pfdeckind = declared then
                fcp^.asgn := true
            end
            else if fcp^.klass = vars then with fcp^ do begin
              if vlev < level then threat := true;
              if forcnt > 0 then error(195)
            end;
            lattr := gattr;
            insymbol;
            expression(fsys);
            lexpr := gattr.codeTree;

            if (lattr.typtr <> nil) and (gattr.typtr <> nil) then begin
              if lattr.typtr^.form = power then begin
                write( prc, '({ ' );
                getbounds(lattr.typtr^.elset, lo, hi );
                if debug then begin
                  writeln(prc, 'bool $r=0;');
                  if checkSet(lexpr, lo, hi) then
                    error(304);
                  writeln(prc, 'if($r) _Pfatal("assigning element outside set bounds",',
                        linecount:1, ');');
                  if lnflag then writeln(prc, '#line ', linecount:1);
                end;
                { TODO: make this a better test,
                eg op=, or dest is not on rhs expression }
                if lexpr^.n = setNode then begin
                  { construct a set into lvar
                  this destroys destination,
                  so is OK only when dest is dead }
                  write( prc, 'uint8_t *const $s0 = ' );
                  genSetPtr( lvar^.sparent );
                  writeln(prc, ';' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                  constructSet( lexpr, lo, hi, 0 );
                end
                else if lexpr^.n = setOpNode then begin
                  { if rhs is 'setNode op list' no need for a 2nd temp }
                  if (lexpr^.setLeft^.n = setNode) and
                     ( (lexpr^.setRight^.n = setNode) and
                     (lexpr^.setRight^.sparent = nil) ) then begin
                    write( prc, 'uint8_t *const $s0 = ' );
                    genSetPtr( lvar^.sparent );
                    writeln(prc, '; /* avoid set copy */' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    constructSet( lexpr, lo, hi, 0 );
                  end
                  else begin
                    write( prc, 'uint8_t $s0 [(', hi:1,
                          '>>3)-(', lo:1, '>>3)+1]; ' );
                    constructSet( lexpr, lo, hi, 0 );
                    { result is in s0 }
                    write( prc, 'memcpy(' );
                    genSetPtr( lvar^.sparent );
                    write( prc, ', $s0, sizeof($s0));' );
                  end
                end
                else begin
                  writeln(prc, '>>> set expression expected (4)' )
                end;
                writeln(prc, '}) // $s0 := set expr' );
                if lnflag then writeln(prc, '#line ', linecount:1);
              end {if power}
              else if lvar <> nil then begin
                genCExpr( lvar );
                write( prc, ' = ' );
                if isString(lattr.typtr) then begin
                  if {gattr.kind = cst} lexpr^.n = constNode then begin
                    with lexpr^ do begin
                      if constType = charptr then begin
                        {replace char with string length 1}
                        mkStrConst(constType, 1);
                        gattr.typtr := constType;
                      end; {if}
                    end; {with}
                    write( prc, '(' );
                    genTypeOf( lvar );
                    write( prc, '){{' );
                    genCExpr( lexpr );
                    write( prc, '}}' );
                  end
                  else begin
                    write( prc, '*(' );
                    genTypeOf( lvar );
                    write( prc, ' *)&' );
                    genCExpr( lexpr );
                  end;
                end   {if string}
                else begin
                  with lattr do
                    if (gattr.kind = cst) and
                       (typtr^.form <= subrange) and
                       (typtr <> intptr) and
                       (typtr <> realptr) and
                       comptypes(typtr, gattr.typtr)
                    then begin
                      checkbounds( typtr, gattr.cval.iVal, 303);
                      genCExpr( lexpr );
                    end
                    else if debug and
                      (typtr^.form <= subrange) and
                      (typtr <> intptr) and
                      (typtr <> realptr)
                    then begin
                      getbounds( typtr, lo, hi );
                      write( prc, '({int $i = ' );
                      genCExpr( lexpr );
                      writeln(prc, '; if($i>', hi:1, '|| $i<', lo:1,
                                    ') _Pfatal("bounds error in assignment",',
                                    linecount:1, '); $i;})' );
                      if lnflag then writeln(prc, '#line ', linecount:1);
                    end
                    else
                      genCExpr( lexpr );
                end;
              end;
              writeln(prc, ';' );
              if lnflag then writeln(prc, '#line ', linecount:1);

              { check assignment compatible }
              if comptypes(realptr, lattr.typtr) and
                 (gattr.typtr=intptr) then begin
                   {gattr.typtr := realptr};
              end
              else if not comptypes(lattr.typtr, gattr.typtr) then
                error(129)
              else if filecomponent(gattr.typtr) then
                error(146);                { error if file assignment }
            end; { if }
            freeTree( lexpr );
          end (*sy = becomes*)
          else error(51);
          freeTree( lvar );
        end (*assignment*) ;

        procedure gotostatement;
        var llp : lbp; ttop,ttop1: disprange;

        begin
          insymbol;
          if sy = intconst then begin
            ttop := top;
            while display[ttop].occur <> blck do ttop := ttop - 1;
            ttop1 := ttop;
            repeat
              searchlabel(llp, ttop); { find label }
              if llp <> nil then
                with llp^ do begin
                  refer := true;
                  if defined then
                    if slevel > stalvl then { defining point level greater than
                                            present statement level }
                      error(185) { goto references deeper nested statement }
                    else if (slevel > 1) and not bact then
                      error(187); { Goto references label in different nested
                                  statement }
                  { establish the minimum statement level a goto appeared at }
                  if minlvl > stalvl then minlvl := stalvl;
                  if ttop = ttop1 then begin
                    writeln(prc, 'goto _PL', labname:1, ';' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                  end
                  else begin { interprocedural goto }
                    write(prc, '({' );
                    write( prc, 'while(_Phead!=NULL && _Phead->level>', vlevel:1, ') {' );
                    write( prc, ' _Phead->cuFunc();' );
                    write( prc, ' _Phead=_Phead->link; }; ' );


                    writeln(prc, 'longjmp( _PJB', labname:1, ', 1 );});' );
                    if lnflag then writeln(prc, '#line ', linecount:1);
                    ipcref := true
                  end
                end;
              ttop := ttop - 1
            until (llp <> nil) or (ttop = 0);
            if llp = nil then begin
              error(167); { undeclared label }
              newlabel(llp); { create dummy label in current context }
              llp^.refer := true;
            end;
            insymbol
          end
          else error(15)
        end (*gotostatement*) ;

        procedure compoundstatement;
        var done: boolean;
        begin
          writeln(prc, '{' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          insymbol;
          { L7600, this code is duplicated in body() }
          addlvl;
          repeat
            { could be inside nested if statements, so remove elsesy from fsys
              so errors like ... end; else ... can be detected
              need to do this to avoid end symbols getting out of sync with the code and
              causing a cascade of follow on errors. }
            repeat statement(fsys + [semicolon,endsy] - [elsesy]);
            until not (sy in statbegsys);
            done := sy <> semicolon;
            if not done then begin
              insymbol;
              done := sy = endsy;
            end;
          until done;
          if sy = endsy then begin
            writeln(prc, '}' );
            if lnflag then writeln(prc, '#line ', linecount:1);
            insymbol;
          end
          else error(13);
          sublvl
        end (*compoundstatement*) ;


        procedure ifstatement;
        begin
          write( prc, 'if( ' );
          insymbol;
          expression(fsys + [thensy]);
          if (gattr.typtr <> nil) and (gattr.typtr <> boolptr) then begin
            error(135);
            gattr.typtr := nil
          end;
          genCExpr( gattr.codeTree );
          freeTree( gattr.codeTree );
          writeln(prc, ' )' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          if sy = thensy then insymbol else error(52);
          addlvl;
          statement(fsys + [elsesy]);
          sublvl;
          if sy = elsesy then begin
            writeln(prc, 'else ' );
            if lnflag then writeln(prc, '#line ', linecount:1);
            insymbol;
            addlvl;
            statement(fsys);
            sublvl;
          end
        end (*ifstatement*) ;


        procedure casestatement;
          label 1;
          var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu;
              test: boolean;
              caseDebug: boolean;
              caseLine: integer;
        begin
          caseDebug := debug;
          caseLine := linecount;
          insymbol;
          expression(fsys + [ofsy,comma,colon]);
          write( prc, 'switch( ' );
          genCExpr( gattr.codeTree );
          freeTree( gattr.codeTree );
          writeln(prc, ' ) {' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          lsp := gattr.typtr;
          if lsp <> nil then { only non-real scalars allowed }
            if (lsp^.form <> scalar) or (lsp = realptr) then
              begin error(144); lsp := nil end;
          if sy = ofsy then insymbol else error(8);
          fstptr := nil;
          repeat
            { loop for each case branch }
            lpt3 := nil;
            if not(sy in [semicolon,endsy]) then begin
              repeat
                { loop for each case value }
                constant(fsys + [comma,colon],lsp1,lval);
                writeln(prc, 'case ', lval.ival:1, ' :' );
                if lnflag then writeln(prc, '#line ', linecount:1);
                if (lsp <> nil) and (lsp1 <> nil) then
                  if comptypes(lsp,lsp1) then begin
                    lpt1 := fstptr; lpt2 := nil;
                    while lpt1 <> nil do
                      with lpt1^ do begin
                        { check if this case value has already occured }
                        if cslab <= lval.ival then begin
                          if cslab = lval.ival then error(156);
                          goto 1
                        end;
                        lpt2 := lpt1; lpt1 := next
                      end;
           1:       getcas(lpt3);
                    with lpt3^ do begin
                      next := lpt1; cslab := lval.ival;
                    end;
                    if lpt2 = nil then fstptr := lpt3
                    else lpt2^.next := lpt3
                  end
                  else error(147); {type error}
                test := sy <> comma;
                if not test then insymbol
              until test;
              if sy = colon then insymbol else error(5);
              { compile the statement, account for error recovery }
              addlvl;
              repeat
                statement(fsys + [semicolon,endsy]);
              until not (sy in statbegsys);
              sublvl;
              if lpt3 <> nil then begin
                writeln(prc, 'break;' );
                if lnflag then writeln(prc, '#line ', linecount:1);
              end;
            end;
            test := sy <> semicolon;
            if not test then insymbol
          until test;

          while fstptr <> nil do begin
            lpt1 := fstptr; fstptr := fstptr^.next;
            putcas(lpt1);
          end;

          if sy = endsy then begin
            { check for out of range case values }
            if caseDebug then begin
              writeln(prc, 'default: _Pfatal("no case constant for expression",',
                      caseLine:1, ');');
              if lnflag then writeln(prc, '#line ', linecount:1);
            end;
            insymbol;
          end
          else error(13);
          writeln(prc, '} /* switch */' );
          if lnflag then writeln(prc, '#line ', linecount:1);
        end (*casestatement*) ;

        procedure repeatstatement;
        begin
          writeln(prc, 'do {' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          insymbol;
          addlvl;
          repeat
            statement(fsys + [semicolon,untilsy]);
            if sy in statbegsys then error(14)
          until not(sy in statbegsys);
          while sy = semicolon do begin
            insymbol;
            { short circuit if null statement found }
            if sy <> untilsy then begin
              repeat
                statement(fsys + [semicolon,untilsy]);
                if sy in statbegsys then error(14);
              until not (sy in statbegsys);
            end;
          end;
          if sy = untilsy then begin
            write( prc, '} while( ! ' );
            insymbol;
            expression(fsys);
            if (gattr.typtr <> nil) and (gattr.typtr <> boolptr) then begin
              error(135);
              gattr.typtr := nil
            end;
            genCExpr( gattr.codeTree );
            freeTree( gattr.codeTree );
            writeln(prc, ');' );
            if lnflag then writeln(prc, '#line ', linecount:1);
          end
          else error(53);
          sublvl;
        end (*repeatstatement*) ;

        procedure whilestatement;
        begin
          write( prc, 'while( ' );
          insymbol;
          expression(fsys + [dosy]);
          if (gattr.typtr <> nil) and (gattr.typtr <> boolptr) then begin
            error(135);
            gattr.typtr := nil
          end;
          genCExpr( gattr.codeTree );
          freeTree( gattr.codeTree );
          writeln(prc, ')' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          if sy = dosy then insymbol else error(54);
          addlvl;
          statement(fsys);
          sublvl;
        end (*whilestatement*) ;

        procedure forstatement;
          var lattr: attr;  istosy: boolean;
              lo, hi, lin : integer;
        begin
          write( prc, '{ const int $tf1 = ' );
          insymbol;
          lcp := nil;
          with lattr do begin { set default attributes for loop variable }
            typtr := nil; kind := varbl;
            access := drct; vlevel := level; packing := false;
          end;
          if sy = ident then begin
            searchid([vars],lcp);
            with lcp^, lattr do begin
              typtr := idtype; kind := varbl; packing := false;
              if threat or (forcnt > 0) then error(195);
              forcnt := forcnt+1;
              if vkind = actual then begin { check if legal loop variable }
                access := drct; vlevel := vlev;
                if vlev <> level then error(183);
              end
              else begin error(155); typtr := nil end
            end; { with }
            if lattr.typtr <> nil then
              if (lattr.typtr^.form <= subrange)
                and not comptypes(realptr,lattr.typtr)
              then
                getbounds( lattr.typtr, lo, hi ) { for range checking }
              else
                begin error(143); lattr.typtr := nil end;
            insymbol
          end
          else
          begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end;

          if sy = becomes then begin
            insymbol; { get start value, check it's compatible with loop var }
            expression(fsys + [tosy,downtosy,dosy]); { tf1 }
            genCExpr( gattr.codeTree );
            freeTree( gattr.codeTree );
            write( prc, '; const int $tf2 = ' );
            if gattr.typtr <> nil then
              if gattr.typtr^.form <> scalar then
                error(144)
              else if not comptypes(lattr.typtr,gattr.typtr) then
                error(145)
          end
          else
          begin error(51); skip(fsys + [tosy,downtosy,dosy]) end;
          istosy := sy = tosy;
          if sy in [tosy,downtosy] then begin
            { get end value, check it's compatible with loop var }
            insymbol;
            expression(fsys + [dosy]);
            genCExpr( gattr.codeTree );
            freeTree( gattr.codeTree );
            writeln(prc, ';' ); { tf2 }
            if lnflag then writeln(prc, '#line ', linecount:1);
            if istosy then begin
              writeln(prc, 'if( $tf2 >= $tf1 ) {' );
              end
            else begin
              writeln(prc, 'if( $tf2 <= $tf1 ) {' );
            end;
            if lnflag then writeln(prc, '#line ', linecount:1);
            if debug then begin
              lin := linecount;
              if istosy then begin
                writeln(prc, 'if( $tf1<', lo:1, ') _Pfatal("initial value of control variable low range error", ',
                              lin:1, ');' );
              end
              else begin
                writeln(prc, 'if( $tf1>', hi:1, ') _Pfatal("initial value of control variable high range error", ',
                             lin:1, ');' );
              end;
              if lnflag then writeln(prc, '#line ', linecount:1);
            end;
            writeId( lcp );
            writeln(prc, ' = $tf1; do' );
            if lnflag then writeln(prc, '#line ', linecount:1);
            if gattr.typtr <> nil then
              if gattr.typtr^.form <> scalar then
                error(144)
              else if not comptypes(lattr.typtr,gattr.typtr) then
                error(145)
          end
          else begin error(55); skip(fsys + [dosy]) end;
          if sy = dosy then insymbol else error(54);
          addlvl;
          statement(fsys);
          write( prc, 'while(' );
          writeId( lcp );
          write( prc, ' != $tf2 && (' );
          if debug then begin
            write( prc, '({ if(' );
            writeId( lcp );
            if istosy then begin
              write( prc, '>=', hi:1, ') _Pfatal("control variable exceeds range limit", ' );
            end
            else begin
              write( prc, '<=', lo:1, ') _Pfatal("control variable falls below range limit", ' );
            end;
            write(prc, lin:1, '); 1;}), ' );
          end;

          if istosy then
            write( prc, '++' )
          else
            write( prc, '--' );
          writeId( lcp );
          writeln(prc, ', 1) ); }}' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          sublvl;
          if lcp <> nil then lcp^.forcnt := lcp^.forcnt-1
        end (*forstatement*) ;


        procedure withstatement;
          var lcp: ctp; lcnt1: disprange;
              test: boolean;
        begin
          insymbol;
          lcnt1 := 0;
          writeln(prc, '{ // with statement' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          repeat
            { get first/next variable in the list }
            if sy = ident then
              begin searchid([vars,field],lcp); insymbol end
            else begin error(2); lcp := uvarptr end;
            selector(fsys + [comma,dosy], lcp, false);
            { now we have the variable, error if it is not a record }
            if gattr.typtr <> nil then
              if gattr.typtr^.form = records then
                if top < displimit then begin
                  { setup display info from record }
                  top := top + 1; lcnt1 := lcnt1 + 1;
                  if gattr.typtr^.typeName <> nil then
                    genCType( gattr.typtr, false )
                  else begin
                    genTypeOf( gattr.codeTree );
                  end;
                  write( prc, ' *const $tw', top:1, ' = ' );
                  with display[top] do begin
                    fname := gattr.typtr^.fstfld;
                    flabel := nil;
                    flabel := nil;
                    fconst := nil;
                    fstruct := nil;
                    packing := gattr.packing;
                    packcom := gattr.packcom;
                    ptrref := gattr.ptrref;
                    if gattr.access = drct then begin
                      { direct => constant record }
                      occur := crec;
                      clev := gattr.vlevel;
                    end
                    else begin
                      { indirect => variable record }
                      { create temp variable, assigned address of record }
                      occur := vrec;
                    end;
                  end; {with}
                  write( prc, '&' );
                  genCExpr( gattr.codeTree );
                  writeln(prc, ';' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                end
                else error(250) {scope nest limit exceeded}
              else error(140); { not a record }
            freeTree( gattr.codeTree );
            test := sy <> comma;
            if not test then insymbol
          until test;
          if sy = dosy then insymbol else error(54);
          addlvl;
          statement(fsys);
          sublvl;
          writeln(prc, '} // with' );
          if lnflag then writeln(prc, '#line ', linecount:1);
          { purge display levels }
          while lcnt1 > 0 do begin
             { don't recycle the record context }
             display[top].fname := nil;
             putdsp(top); { purge }
             top := top-1; lcnt1 := lcnt1-1; { count off }
          end;
        end (*withstatement*) ;

      begin (*statement()*)
        mergeFixedSets := false;
        if sy = intconst then begin (*label*)
          if lnflag then writeln(prc, '#line ', linecount:1);
            searchlabel(llp, level); { search label }
            if llp <> nil then with llp^ do begin { found }
              if defined then error(165); { multidefined label }
              bact := true; { set in active block now }
              slevel := stalvl; { establish statement level }
              defined := true; { set defined }
              if ipcref and (stalvl > 1) then
                error(184) { intraprocedure goto does not reference outter block }
              else if minlvl < stalvl then
                error(186); { Goto references label within a nested statement }
              writeln(prc, '_PL', labname:1, ':' );
            end else begin { not found }
              error(167); { undeclared label }
              newlabel(llp) { create a dummy label }
            end;
            insymbol;
            if sy = colon then insymbol else error(5);
        end;
        if not (sy in fsys + [ident]) then
          begin error(6); skip(fsys) end;
        if sy in statbegsys + [ident] then begin
          if lnflag then writeln(prc, '#line ', linecount:1);
          case sy of
            ident: begin {assignment or call}
                searchid([vars,field,boundid,proc,func],lcp); insymbol;
                if lcp = uvarptr then { undeclared variable }
                  if sy in fsys + [lparent,semicolon] then
                    lcp := uprcptr; {make it undeclared proc}
                if lcp^.klass = proc then begin
                  call(fsys,lcp);
                  writeln(prc, ';' );
                  if lnflag then writeln(prc, '#line ', linecount:1);
                end
                else begin
                  if lcp^.klass = boundid then
                    error(224);
                  assignment(lcp);
                  end;
              end;
            beginsy:  compoundstatement;
            gotosy:   gotostatement;
            ifsy:     ifstatement;
            casesy:   casestatement;
            whilesy:  whilestatement;
            repeatsy: repeatstatement;
            forsy:    forstatement;
            withsy:   withstatement
          end; { case }
          if not (sy in [semicolon,endsy,elsesy,untilsy]) then
              begin error(6); skip(fsys) end
        end
        else
          writeln( prc, ';' ); { terminate empty c statement }
      end (*statement*) ;


    { set up files for auto deletion when leaving the current function/procedure }
    procedure genCleanup;

    var
      t : fileListItemPtr;

    procedure prname;
    begin writeId(t^.filevar); end;

    begin {genCleanup}
      { look for file vars, make a cleanup function to close them }

      { skip if there are compilation errors - so no need to check for nil pointers }
      if fileList <> nil then begin
        writeln(prc, 'void _Pcleanup(void) {' );
        if false and (display[level].bname <> nil) then begin
          write( prc, 'printf("cleaning up ' );
          writeId(display[level].bname);
          writeln(prc, '\n");' );
        end;
        repeat
          t := fileList;
          genCloseFiles( t^.fileVar^.idtype, prname );
          fileList := fileList^.next;
          dispose(t);
        until fileList = nil;
        writeln(prc, '} // _Pcleanup' );
        write( prc, 'struct _PcleanupInf _Pcudat = { .level=', level:1 );
        writeln(prc, ', .cuFunc=_Pcleanup, .link=_Phead };' );
        writeln(prc, '_Phead=&_Pcudat;' );
      end; {if}
    end; { genCleanup }


    begin { body() }
      if fprocp = nil then begin
        { this is where pascal's main program begin is
          put main() here }
        writeln(prc, 'int main( int argc, char* argv[] ) {' );
        if lnflag then writeln(prc, '#line ', linecount:1);
        if inputhdf then begin
          writeId( inputptr );
          writeln(prc, '.f =  stdin;' );
        end;
        if outputhdf then begin
          writeId( outputptr );
          writeln(prc, '.f =  stdout;' );
        end;

        {win32 lib does not do line buffering for output}
        writeln(prc, '#if defined(__WIN32__)');
        writeln(prc, 'setvbuf(stdout, NULL, _IONBF, 0);');
        writeln(prc, '#endif');

        writeln(prc, 'atexit(_Pexit);' );
        if lnflag then writeln(prc, '#line ', linecount:1);

        { set up the external files }
        if fextfilep <> nil then begin
          saveid := id;
          repeat
            with fextfilep^ do begin
              if argNr > 0 then begin { argNr = 0 for input, output }
                id := filename;
                searchidne( [vars], llcp );
                if llcp = nil then begin
                  { a header file was never declared as a var }
                  {error(172);}
                  writeln(output);
                  writeln(output,'**** Error: Undeclared external file ''',
                          filename:8, '''');
                  toterr := toterr+1;
                end
                else if llcp^.idtype <> nil then begin
                  if llcp^.idtype^.form <> files then begin
                    writeln(output);
                    writeln(output,
                           '**** Error: external, but not declared as a file: ',
                            filename:8 );
                    toterr := toterr+1
                  end
                  else begin
                    write( prc, 'if( ', argNr+1:1, ' <= argc ) ' );
                    writeId( llcp );
                    writeln(prc, '.name = argv[', argNr:1, '];' );
                    writeln(prc, 'else { ' );
                    writeId( llcp );
                    writeln(prc, '.f = tmpfile();' );
                    write(prc, 'fprintf( stderr, "warning: no external file assigned to ' );
                    writev( prc, llcp^.name, lenpv(llcp^.name) );
                    writeln(prc, '\n" ); }' );
                  end;
                end;
              end; { if argNr ... }
            end; { with }
            fp := fextfilep;
            fextfilep := fp^.nextfile;
            putfil(fp);
          until fextfilep = nil;
          id := saveid;
        end; {if external files}
      end; {if main()}

      genCleanup;
      if lnflag then writeln(prc, '#line ', linecount:1);

      { set jmp buffer for each declared & used label }
      llp := display[top].flabel;
      while llp <> nil do
        with llp^ do begin
          if ipcref then begin
            writeln(prc, 'if( setjmp( _PJB', labname:1, ') != 0 ) goto _PL', labname:1, ';' );
            if lnflag then writeln(prc, '#line ', linecount:1);
          end;
          llp := nextlab
        end;

      { this code is duplicated at L7600 }
      addlvl;
      if sy = beginsy then insymbol; { this was checked earlier in block }
      repeat
        repeat statement(fsys + [semicolon,endsy])
        until not (sy in statbegsys);
        test := sy <> semicolon;
        if not test then begin
          insymbol;
          { short circuit null statement due to trailing semicolon }
          test := sy = endsy;
        end;
      until test;
      sublvl;
      if sy = endsy then insymbol else error(13);

      llp := display[top].flabel; (*test for undefined and unreferenced labels*)
      while llp <> nil do
        with llp^ do begin
          if not defined then begin
            error(168);
            writeln(output); writeln(output,'label ',labval:11);
            write(output,' ':chcnt+16); {TODO: what's the 16?}
          end
          else if not refer then begin
            writeln(output);
            writeln(output,'label ',labval:1, ' never referenced in goto');
          end;
          llp := nextlab
        end; {with}

      printed := false; chkrefs(display[top].fname, printed);
      if fprocp = nil then begin
        { end of main program }

        if memDebug then begin
          writeln(prc, '_Preport_mem(_Proot);' );
        end;

        writeln(prc, 'exit(EXIT_SUCCESS);' );
        writeln(prc, '} /* main() */' );

        if prtables then begin
          writeln(output); printtables(true)
        end
      end;
    end (*body*) ;

  begin (*block()*)
    stalvl := 0; { clear statement nesting level }
    dp := true;
    lforwcnt := 0;
    fileList := nil;

    repeat
      if sy = labelsy then labeldeclaration;
      if sy = constsy then constdeclaration;
      if sy = typesy then typedeclaration;
      if sy = varsy then vardeclaration;
      while sy in [procsy,funcsy] do procdeclaration;
      if sy <> beginsy then
        begin error(18); skip(fsys) end
    until (sy in statbegsys) or eof(prd);
    if lforwcnt > 0 then begin
      error(117); writeln(output);
      checkforw( display[level].fname ); { report dangling forward procs }
    end;
    dp := false;

    if sy <> beginsy then error(17);
    repeat body(fsys + [casesy]);
      if sy <> fsy then
        begin error(6); skip(fsys) end
    until ((sy = fsy) or (sy in blockbegsys)) or eof(prd)
  end (* block() *) ;


  procedure programme(fsys:setofsys);
  var extfp : extfilep;
      argCounter : integer;
  begin
    memDebug := debug;

    { write out start of program }
    writeln(prc, '#include <p5c.h>' );
    writeln(prc, '#if __P5C_H__ - 0 != 100');
    writeln(prc, '#error "compiler incompatible with p5c.h"');
    writeln(prc, '#endif');

    if memDebug then begin
      writeln(prc, '#define MEMDEBUG' );
      writeln(prc, 'struct _Pmem' );
      writeln(prc, '{' );
      writeln(prc, '    struct _Pmem *left;' );
      writeln(prc, '    struct _Pmem *right;' );
      writeln(prc, '    int line;' );
      writeln(prc, '    bool f;' );
      writeln(prc, '    void * addr;' );
      writeln(prc, '};' );
      writeln(prc, 'struct _Pmem* _Proot=NULL;' );

      writeln(prc );
      writeln(prc, 'static void _Padd_mem( struct _Pmem **const m, void *const a, const int l )' );
      writeln(prc, '{' );
      writeln(prc, 'struct _Pmem *p = *m;' );
      writeln(prc, '    if( p==NULL ) {' );
      writeln(prc, '        p = (struct _Pmem*)malloc( sizeof(struct _Pmem) );' );
      writeln(prc, '        if( p != NULL ) {' );
      writeln(prc, '            *m = p;' );
      writeln(prc, '            p->left = NULL;' );
      writeln(prc, '            p->right = NULL;' );
      writeln(prc, '            p->line = l;' );
      writeln(prc, '            p->f = 0;' );
      writeln(prc, '            p->addr = a;' );
      writeln(prc, '        }' );
      writeln(prc, '        else' );
      writeln(prc, '            _Pfatal("out of memory", l);' );
      writeln(prc, '    }' );
      writeln(prc, '    else if( a < p->addr )' );
      writeln(prc, '        _Padd_mem(&p->left, a, l );' );
      writeln(prc, '    else if( a > p->addr )' );
      writeln(prc, '        _Padd_mem(&p->right, a, l );' );
      writeln(prc, '    else if( p->f != 0 ) {' );
      writeln(prc, '        p->line = l;' );
      writeln(prc, '        p->f = 0;' );
      writeln(prc, '    }' );
      writeln(prc, '    else' );
      writeln(prc, '        _Pfatal("memory already allocated", l);' );
      writeln(prc, '} // _Padd_mem()' );

      writeln(prc );
      writeln(prc, 'static void _Pfree_mem( struct _Pmem *const p, void *const a, const int l )' );
      writeln(prc, '{' );
      writeln(prc, 'char msg[50];' );
      writeln(prc, '    if( p == NULL ) _Pfatal( "attempt to dispose nil pointer", l);' );
      writeln(prc, '    if( a > p->addr )' );
      writeln(prc, '       _Pfree_mem( p->right, a, l );' );
      writeln(prc, '    else if( a < p->addr )' );
      writeln(prc, '       _Pfree_mem( p->left, a, l );' );
      writeln(prc, '    else if( p->f == 0 ) {' );
      writeln(prc, '       free(a);' );
      writeln(prc, '       p->line = l;' );
      writeln(prc, '       p->f = !0;' );
      writeln(prc, '    }' );
      writeln(prc, '    else {' );
      writeln(prc, '       sprintf(msg, "memory was already disposed at line %d", p->line );' );
      writeln(prc, '       _Pfatal( msg, l); ' );
      writeln(prc, '    }' );
      writeln(prc, '} // _Pfree_mem()' );

      writeln(prc );
      writeln(prc, 'static void _Puse_mem( struct _Pmem *const p, void *const a, const int l )' );
      writeln(prc, '{' );
      writeln(prc, '    if( p == NULL ) _Pfatal( "attempt to use invalid pointer", l);' );
      writeln(prc, '    if( a > p->addr )' );
      writeln(prc, '       _Puse_mem( p->right, a, l );' );
      writeln(prc, '    else if( a < p->addr )' );
      writeln(prc, '       _Puse_mem( p->left, a, l );' );
      writeln(prc, '    else if( p->f != 0 ) {' );
      writeln(prc, '       char msg[40];' );
      writeln(prc, '       sprintf(msg, "using pointer disposed at line %d", p->line );' );
      writeln(prc, '       _Pfatal( msg, l);' );
      writeln(prc, '    }' );
      writeln(prc, '} // _Puse_mem()' );

      writeln(prc );
      writeln(prc, 'static void _Preport_mem( struct _Pmem *const p )' );
      writeln(prc, '{' );
      writeln(prc, '    if( p == NULL ) return;' );
      writeln(prc, '    _Preport_mem( p->left );' );
      writeln(prc, '    if( p->f == 0 ) {' );
      writeln(prc, '        printf( "new memory at line %i was not disposed\n", p->line );' );
      writeln(prc, '    }' );
      writeln(prc, '    _Preport_mem( p->right );' );
      writeln(prc, '}' );
      writeln(prc );
    end;

    { file close & cleanup }
    writeln(prc, 'struct _PcleanupInf *_Phead=NULL;' );

    {TODO: compare this with reset/rewrite(), factor out common code }
    writeln(prc, 'static void _Pclose_file(text *const $fp) {' );
    writeln(prc, ' if($fp->f != NULL) {' );
    writeln(prc, '  if($fp->name!=NULL && $fp->flags==-2) putc(''\n'', $fp->f);' );
    writeln(prc, '  fclose($fp->f);' );
    writeln(prc, ' }' );
    writeln(prc, '} // _Pclose_file()' );

    if sy = progsy then begin
      insymbol;
      if sy <> ident then error(2) else insymbol;
      if not (sy in [lparent,semicolon]) then error(14);
      inputptr := nil; outputptr := nil;
      if sy = lparent  then begin
        argCounter := 1;
        repeat insymbol;
          if sy = ident then begin
            getfil(extfp);
            with extfp^ do begin
              argNr := 0;
              filename := id; nextfile := fextfilep
            end;
            { check 'input' or 'output' appears in header for defaults }
            if strequri(na[stdNinput], id) then begin
              inputhdf := true;
              new(inputptr,vars); ininam(inputptr);
              with inputptr^ do begin
                strassvf(name, na[stdNinput]); idtype := textptr; klass := vars;
                vkind := actual; next := nil; vlev := 1;
                refer := false;
                threat := false; forcnt := 0
              end;
              enterid(inputptr);
              write( prc, 'static text ' );
              writeId( inputptr );
              writeln(prc, ' = { .name="input", .buffer=2, .flags=0 };' );
            end
            else if strequri(na[stdNoutput], id) then begin
              outputhdf := true;
              new(outputptr,vars); ininam(outputptr);
              with outputptr^ do begin
                strassvf(name, na[stdNoutput]); idtype := textptr; klass := vars;
                vkind := actual; next := nil; vlev := 1;
                refer := false;
                threat := false; forcnt := 0
              end;
              enterid(outputptr);
              write( prc, 'static text ' );
              writeId( outputptr );
              writeln(prc, ' = { .name="output", .flags=-1 };' );
            end
            else begin
              extfp^.argNr := argCounter;
              argCounter := argCounter + 1;
            end;
            fextfilep := extfp;
            insymbol;
            if not ( sy in [comma,rparent] ) then error(20)
          end
          else error(2)
        until sy <> comma;
        if sy <> rparent then error(4);
        insymbol;
        if sy <> semicolon then error(14)
      end;
      if sy = semicolon then insymbol
    end else error(3);

    { cleanup output and all other files, write eoln for external files }
    writeln(prc, 'static void _Pexit(void) {' );
    if outputhdf then begin
      write( prc, 'if(');
      writeId( outputptr );
      write( prc, '.flags==-2)  putc(''\n'', ');
      writeId( outputptr );
      writeln(prc, '.f);' );
    end;
    writeln(prc, 'while(_Phead!=NULL){' );
    writeln(prc, '  _Phead->cuFunc();_Phead=_Phead->link;};' );
    writeln(prc, '} //_Pexit()' );

    repeat block(fsys,period,nil);
      if sy <> period then error(22)
    until (sy = period) or eof(prd);

    if list then writeln(output);
    if errinx <> 0 then
      begin list := false; endofline end;
  end (*programme*) ;


  {TODO: combine with entstdnames?}
  procedure stdnames;
  begin
    na[stdNfalse]  := 'false    ';  na[stdNtrue]    := 'true     ';
    na[stdNinput]  := 'input    ';  na[stdNoutput]  := 'output   ';
    na[stdNget]    := 'get      ';  na[stdNput]     := 'put      ';
    na[stdNreset]  := 'reset    ';  na[stdNrewrite] := 'rewrite  ';
    na[stdNread]   := 'read     ';  na[stdNwrite]   := 'write    ';
    na[stdNreadln] := 'readln   ';  na[stdNwriteln] := 'writeln  ';
    na[stdNpage]   := 'page     ';
    na[stdNpack]   := 'pack     ';  na[stdNunpack]  := 'unpack   ';
    na[stdNnew]    := 'new      ';  na[stdNdispose] := 'dispose  ';
    na[stdNtrunc]  := 'trunc    ';  na[stdNround]   := 'round    ';
    na[stdNabs]    := 'abs      ';  na[stdNsqr]     := 'sqr      ';
    na[stdNodd]    := 'odd      ';
    na[stdNord]    := 'ord      ';  na[stdNchr]     := 'chr      ';
    na[stdNpred]   := 'pred     ';  na[stdNsucc]    := 'succ     ';
    na[stdNeof]    := 'eof      ';  na[stdNeoln]    := 'eoln     ';
    na[stdNsin]    := 'sin      ';  na[stdNcos]     := 'cos      ';
    na[stdNexp]    := 'exp      ';  na[stdNsqrt]    := 'sqrt     ';
    na[stdNln]     := 'ln       ';  na[stdNarctan]  := 'arctan   ';
    na[stdNmaxint] := 'maxint   ';
  end (*stdnames*) ;

  procedure enterstdtypes;

  begin                                                 (*type underlying:*)
                                                        (******************)

    new(intptr,scalar,standard); pshstc(intptr);               (*integer*)
    with intptr^ do begin
      typeName:=nil; hasFile:=false;
      form:=scalar; scalkind:=standard
    end;
    new(realptr,scalar,standard); pshstc(realptr);             (*real*)
    with realptr^ do begin
      typeName:=nil; hasFile:=false;
      form:=scalar; scalkind:=standard
    end;
    new(charptr,scalar,standard); pshstc(charptr);             (*char*)
    with charptr^ do begin
      typeName:=nil; hasFile:=false;
      form:=scalar; scalkind:=standard
    end;
    new(boolptr,scalar,declared); pshstc(boolptr);             (*boolean*)
    with boolptr^ do begin
      typeName:=nil; hasFile:=false;
      form:=scalar; scalkind:=declared
    end;
    new(nilptr,pointer); pshstc(nilptr);                (*nil*)
    with nilptr^ do begin
      typeName:=nil; hasFile:=false;
      form:=pointer; eltype:=nil
    end;
    (*for alignment of parameters*)
    new(parmptr,scalar,standard); pshstc(parmptr);
    with parmptr^ do begin
      typeName:=nil; hasFile:=false;
      form:=scalar; scalkind:=standard
    end ;
    new(textptr,files); pshstc(textptr);                (*text*)
    with textptr^ do begin
      typeName:=nil; hasFile:=true;
      form:=files; filtype:=charptr
    end
  end (*enterstdtypes*) ;

  procedure entstdnames;
    var cp,cp1: ctp; i: tStdNames;

  begin                                                       (*name:*)
                                                              (*******)

    new(cp,types); ininam(cp);                                (*integer*)
    with cp^ do
      begin strassvf(name, 'integer  '); idtype := intptr; klass := types end;
    enterid(cp);
    new(cp,types); ininam(cp);                                (*real*)
    with cp^ do
      begin strassvf(name, 'real     '); idtype := realptr; klass := types end;
    enterid(cp);
    new(cp,types); ininam(cp);                                (*char*)
    with cp^ do
      begin strassvf(name, 'char     '); idtype := charptr; klass := types end;
    enterid(cp);
    new(cp,types); ininam(cp);                                (*boolean*)
    with cp^ do
      begin strassvf(name, 'boolean  '); idtype := boolptr; klass := types end;
    enterid(cp);
    new(cp,types); ininam(cp);                                (*text*)
    with cp^ do
      begin strassvf(name, 'text     '); idtype := textptr; klass := types end;
    enterid(cp);

    cp1 := nil;
    for i := stdNfalse to stdNtrue do begin
      new(cp,konst); ininam(cp);                              {false,true}
        with cp^ do begin
          strassvf(name, na[i]); idtype := boolptr;
          next := cp1; klass := konst; values.ival := ord(i) - ord(stdNfalse);
        end;
        enterid(cp); cp1 := cp
    end;
    boolptr^.fconst := cp;

    for i := stdNget to stdNdispose do begin
      new(cp,proc,standard); ininam(cp);                     {get,put,reset}
      with cp^ do begin                                      {rewrite,read}
        strassvf(name, na[i]);
        idtype := nil;                                       {write,pack,unpack}
        next := nil;                                         {new,dispose}
        klass := proc; pflist := nil;                        {readln,writeln}
        pfdeckind := standard; key := i;                     {page}
      end;
      enterid(cp)
    end;

    for i := stdNtrunc to stdNeoln do begin
      new(cp,func,standard); ininam(cp);                      {abs,sqr,trunc}
      with cp^ do begin                                       {odd,ord,chr}
        strassvf(name, na[i]); idtype := nil;                 {pred,succ,eof}
        next := nil;                                          {eoln,round}
        klass := func; pflist := nil;
        pfdeckind := standard; key := i;
      end;
      enterid(cp)
    end;

    for i := stdNsin to stdNarctan do begin
      new(cp,vars); ininam(cp);             {parameter of predeclared functions}
      with cp^ do begin
        strassvf(name, '         '); idtype := realptr; klass := vars;
        vkind := actual; next := nil; vlev := 1;
        threat := false; forcnt := 0
      end;
      new(cp1,func,declared,actual); ininam(cp1);             {sin,cos,exp}
      with cp1^ do begin                                      {sqrt,ln,arctan}
        strassvf(name, na[i]); idtype := realptr;
        klass := func; pflist := cp;
        pfdeckind := declared;  pflev := 0; pfname := i;
        pfkind := actual; forwdecl := false; externl := true;
      end;
      enterid(cp1)
    end;

    new(cp,konst); ininam(cp);                                {maxint}
    with cp^ do begin
      strassvf(name, na[stdNmaxint]); idtype := intptr;
      next := nil; klass := konst; values.ival := maxintTarget
    end;
    enterid(cp);

  end {entstdnames} ;

  procedure enterundecl;
  begin
    new(utypptr,types); ininam(utypptr);
    with utypptr^ do
      begin strassvf(name, '         '); idtype := nil; klass := types end;
    new(ucstptr,konst); ininam(ucstptr);
    with ucstptr^ do
      begin strassvf(name, '         '); idtype := nil; next := nil;
        klass := konst; values.ival := 0
      end;
    new(uvarptr,vars); ininam(uvarptr);
    with uvarptr^ do
      begin strassvf(name, '         '); idtype := nil; next := nil;
        klass := vars; vkind := actual;
        vlev := 0; threat := false; forcnt := 0
      end;
    new(ufldptr,field); ininam(ufldptr);
    with ufldptr^ do
      begin strassvf(name, '         '); idtype := nil; next := nil;
        klass := field;
      end;
    new(uprcptr,proc,declared,actual); ininam(uprcptr);
    with uprcptr^ do
      begin strassvf(name, '         '); idtype := nil; next := nil;
        klass := proc; pflist := nil;
        pfdeckind := declared; pflev := 0; pfkind := actual;
        externl := false; forwdecl := false
      end;
    new(ufctptr,func,declared,actual); ininam(ufctptr);
    with ufctptr^ do
      begin strassvf(name, '         '); idtype := nil; next := nil;
        klass := func; pflist := nil;
        pfdeckind := declared; pflev := 0;
        pfkind := actual; forwdecl := false; externl := false
      end
  end (*enterundecl*) ;

  { tear down storage allocations from enterundecl }
  procedure exitundecl;
  begin
    putnam(utypptr);
    putnam(ucstptr);
    putnam(uvarptr);
    putnam(ufldptr);
    putnam(uprcptr);
    putnam(ufctptr);
  end (*exitundecl*) ;

  procedure initscalars;
  begin
    fwptr := nil;
    prtables := false; list := true; debug := true;
    lnflag := false;
    chkvar := true; chkref := true; algSet := false;
    dp := true; errinx := 0;
    intlabel := 0; kk := maxids; fextfilep := nil;
    eol := true; linecount := 0;
    ch := ' '; chcnt := 0;
    mxint10 := maxint div 10;
    inputhdf := false; { set 'input' not in header files }
    outputhdf := false; { set 'output' not in header files }
    errtbl := []; { initialize error tracking }
    toterr := 0; { clear error count }
    totwarn := 0; { clear warning count }
    warnings := true; { eanble warnings }
    { clear the recycling tracking counters }
    strcnt := 0; { strings }
    cspcnt := 0; { constants }
    stpcnt := 0; { structures }
    ctpcnt := 0; { identifiers }
    lbpcnt := 0; { label counts }
    filcnt := 0; { file tracking counts }
    cipcnt := 0 { case entry tracking counts }
  end (*initscalars*) ;

  procedure initsets;
  begin
    constbegsys := [addop,intconst,realconst,stringconst,ident];
    simptypebegsys := [lparent] + constbegsys;
    typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys;
    typedels := [arraysy,recordsy,setsy,filesy];
    blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
    selectsys := [arrow,period,lbrack];
    facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy,nilsy];
    statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy];
  end (*initsets*) ;

  procedure inittables;
    procedure reswords;
    begin
      rw[ 1] := 'if       '; rw[ 2] := 'do       '; rw[ 3] := 'of       ';
      rw[ 4] := 'to       '; rw[ 5] := 'in       '; rw[ 6] := 'or       ';
      rw[ 7] := 'end      '; rw[ 8] := 'for      '; rw[ 9] := 'var      ';
      rw[10] := 'div      '; rw[11] := 'mod      '; rw[12] := 'set      ';
      rw[13] := 'and      '; rw[14] := 'not      '; rw[15] := 'nil      ';
      rw[16] := 'then     '; rw[17] := 'else     '; rw[18] := 'with     ';
      rw[19] := 'goto     '; rw[20] := 'case     '; rw[21] := 'type     ';
      rw[22] := 'file     '; rw[23] := 'begin    '; rw[24] := 'until    ';
      rw[25] := 'while    '; rw[26] := 'array    '; rw[27] := 'const    ';
      rw[28] := 'label    '; rw[29] := 'repeat   '; rw[30] := 'record   ';
      rw[31] := 'downto   '; rw[32] := 'packed   '; rw[33] := 'program  ';
      rw[34] := 'function '; rw[35] := 'procedure';
      frw[1] :=  1; frw[2] :=  1; frw[3] :=  7; frw[4] := 16; frw[5] := 23;
      frw[6] := 29; frw[7] := 33; frw[8] := 34; frw[9] := 35; frw[10] := 36;
    end (*reswords*) ;

    procedure symbols;
    begin
      rsy[ 1] := ifsy;      rsy[ 2] := dosy;      rsy[ 3] := ofsy;
      rsy[ 4] := tosy;      rsy[ 5] := relop;     rsy[ 6] := addop;
      rsy[ 7] := endsy;     rsy[ 8] := forsy;     rsy[ 9] := varsy;
      rsy[10] := mulop;     rsy[11] := mulop;     rsy[12] := setsy;
      rsy[13] := mulop;     rsy[14] := notsy;     rsy[15] := nilsy;
      rsy[16] := thensy;    rsy[17] := elsesy;    rsy[18] := withsy;
      rsy[19] := gotosy;    rsy[20] := casesy;    rsy[21] := typesy;
      rsy[22] := filesy;    rsy[23] := beginsy;   rsy[24] := untilsy;
      rsy[25] := whilesy;   rsy[26] := arraysy;   rsy[27] := constsy;
      rsy[28] := labelsy;   rsy[29] := repeatsy;  rsy[30] := recordsy;
      rsy[31] := downtosy;  rsy[32] := packedsy;  rsy[33] := progsy;
      rsy[34] := funcsy;    rsy[35] := procsy;
      ssy['+'] := addop ;   ssy['-'] := addop;    ssy['*'] := mulop;
      ssy['/'] := mulop ;   ssy['('] := lparent;  ssy[')'] := rparent;
      ssy['$'] := othersy ; ssy['='] := relop;    ssy[' '] := othersy;
      ssy[','] := comma ;   ssy['.'] := period;   ssy['''']:= othersy;
      ssy['['] := lbrack ;  ssy[']'] := rbrack;   ssy[':'] := colon;
      ssy['^'] := arrow ;   ssy['<'] := relop;    ssy['>'] := relop;
      ssy[';'] := semicolon; ssy['@'] := arrow;
    end (*symbols*) ;

    procedure rators;
      var i: integer;
    begin
      for i := 1 to maxres (*nr of res words*) do rop[i] := noop;
      rop[5] := inop; rop[10] := idiv; rop[11] := imod;
      rop[6] := orop; rop[13] := andop;
      for i := ordminchar to ordmaxchar do sop[chr(i)] := noop;
      sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
      sop['='] := eqop; sop['<'] := ltop;  sop['>'] := gtop;
    end (*rators*) ;

    procedure chartypes;
    var i : integer;
    begin
      for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal;
      chartp['a'] := letter  ;
      chartp['b'] := letter  ; chartp['c'] := letter  ;
      chartp['d'] := letter  ; chartp['e'] := letter  ;
      chartp['f'] := letter  ; chartp['g'] := letter  ;
      chartp['h'] := letter  ; chartp['i'] := letter  ;
      chartp['j'] := letter  ; chartp['k'] := letter  ;
      chartp['l'] := letter  ; chartp['m'] := letter  ;
      chartp['n'] := letter  ; chartp['o'] := letter  ;
      chartp['p'] := letter  ; chartp['q'] := letter  ;
      chartp['r'] := letter  ; chartp['s'] := letter  ;
      chartp['t'] := letter  ; chartp['u'] := letter  ;
      chartp['v'] := letter  ; chartp['w'] := letter  ;
      chartp['x'] := letter  ; chartp['y'] := letter  ;
      chartp['z'] := letter  ;
      chartp['A'] := letter  ;
      chartp['B'] := letter  ; chartp['C'] := letter  ;
      chartp['D'] := letter  ; chartp['E'] := letter  ;
      chartp['F'] := letter  ; chartp['G'] := letter  ;
      chartp['H'] := letter  ; chartp['I'] := letter  ;
      chartp['J'] := letter  ; chartp['K'] := letter  ;
      chartp['L'] := letter  ; chartp['M'] := letter  ;
      chartp['N'] := letter  ; chartp['O'] := letter  ;
      chartp['P'] := letter  ; chartp['Q'] := letter  ;
      chartp['R'] := letter  ; chartp['S'] := letter  ;
      chartp['T'] := letter  ; chartp['U'] := letter  ;
      chartp['V'] := letter  ; chartp['W'] := letter  ;
      chartp['X'] := letter  ; chartp['Y'] := letter  ;
      chartp['Z'] := letter  ;
      chartp['0'] := number  ;
      chartp['1'] := number  ; chartp['2'] := number  ;
      chartp['3'] := number  ; chartp['4'] := number  ;
      chartp['5'] := number  ; chartp['6'] := number  ;
      chartp['7'] := number  ; chartp['8'] := number  ;
      chartp['9'] := number  ; chartp['+'] := special ;
      chartp['-'] := special ; chartp['*'] := special ;
      chartp['/'] := special ; chartp['('] := chlparen;
      chartp[')'] := special ; chartp['$'] := special ;
      chartp['='] := special ; chartp[' '] := chspace ;
      chartp[','] := special ; chartp['.'] := chperiod;
      chartp['''']:= chstrquo; chartp['['] := special ;
      chartp[']'] := special ; chartp[':'] := chcolon ;
      chartp['^'] := special ; chartp[';'] := special ;
      chartp['<'] := chlt    ; chartp['>'] := chgt    ;
      chartp['{'] := chlcmt  ; chartp['}'] := special ;
      chartp['@'] := special ;

      ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2;
      ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5;
      ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8;
      ordint['9'] := 9;
    end;

  begin (*inittables*)
    reswords; symbols; rators;
    chartypes;
  end (*inittables*) ;

begin

  writeln('P5c Pascal compiler vs. ', majorver:1, '.', minorver:1 );
  writeln;

  (*initialize*)
  (************)
  initscalars; initsets; inittables;

  (*enter standard names and standard types:*)
  (******************************************)
  level := 0; top := 0;
  with display[0] do
    begin fname := nil; flabel := nil; fconst := nil; fstruct := nil;
      packing := false; occur := blck; hasFile := false; bname := nil end;
  enterstdtypes;   stdnames; entstdnames;   enterundecl;
  top := 1; level := 1;
  with display[1] do
    begin fname := nil; flabel := nil; fconst := nil; fstruct := nil;
      packing := false; occur := blck; hasFile := false; bname := nil end;


  (*compile:*)
  (**********)

  reset(prd); rewrite(prc);  { open pascal source and c output file }

  if eof(prd) then begin
    writeln( '--- missing pascal source code ---' );
  end
  else begin
    writeln(prc, '/*');
    writeln(prc, ' *  c file Generated by P5c Pascal compiler v ',
            majorver:1, '.', minorver:1 );
    writeln(prc, ' */');
    insymbol;
    programme(blockbegsys+statbegsys - [casesy]);

    { remove undeclared ids before their type definitions }
    exitundecl;

    { dispose of levels 0 and 1 }
    putdsp(1);
    putdsp(0);

    writeln;
    writeln('Errors in program: ', toterr:1);
    { output error report as required }
    f := true;
    for erridx := 1 to maxErrNr do
      if erridx in errtbl then begin
        if f then begin
          writeln;
          writeln('Error numbers in listing:');
          writeln('-------------------------');
          f := false
        end;
        write(erridx:3, '  '); errmsg(erridx); writeln
      end;
    if not f then writeln;
    writeln('Warnings in program: ', totwarn:1);
    f := true;
    for erridx := -10 to 0 do
      if erridx in errtbl then begin
        if f then begin
          writeln;
          writeln('Warnings in listing:');
          writeln('-------------------------');
          f := false
        end;
        write( 'W', -erridx:3, '  '); errmsg(erridx); writeln
      end;
    if not f then writeln;

    if doprtryc then begin { print recyling tracking counts }

      writeln;
      writeln('Recycling tracking counts:');
      writeln;
      writeln('string quants:              ', strcnt:1);
      writeln('constants:                  ', cspcnt:1);
      writeln('structures:                 ', stpcnt:1);
      writeln('identifiers:                ', ctpcnt:1);
      writeln('label counts:               ', lbpcnt:1);
      writeln('file tracking counts:       ', filcnt:1);
      writeln('case entry tracking counts: ', cipcnt:1);
      writeln;

    end;

    if doprtlab then prtlabels; { dump labels}
    if dodmpdsp then prtdsp; { dump display }

    { perform errors for recycling balance }

    if strcnt <> 0 then
      writeln('*** Error: Compiler internal error: string recycle balance: ',
              strcnt:1);
    if cspcnt <> 0 then
      writeln('*** Error: Compiler internal error: constant recycle balance: ',
              cspcnt:1);
    if stpcnt <> 0 then
      writeln('*** Error: Compiler internal error: structure recycle balance: ',
              stpcnt:1);
    if ctpcnt <> 0 then
      writeln('*** Error: Compiler internal error: identifier recycle balance: ',
              ctpcnt:1);
    if lbpcnt <> 0 then
      writeln('*** Error: Compiler internal error: label recycle balance: ',
              lbpcnt:1);
    if filcnt <> 0 then
      writeln('*** Error: Compiler internal error: file recycle balance: ',
              filcnt:1);
    if cipcnt <> 0 then
      writeln('*** Error: Compiler internal error: case recycle balance: ',
              cipcnt:1);
  end;

  99:

end.
{
Local Variables:
   pascal-indent-level: 2
End:
}
