home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / pascal / PTC / _PtC1 / ptc__p < prev    next >
Encoding:
Text File  |  1991-03-04  |  210.1 KB  |  9,682 lines
  1. (***************************************************************************)
  2. (***************************************************************************)
  3. (**                                      **)
  4. (**    Copyright (C) 1987 by Per Bergsten, Gothenburg, Sweden          **)
  5. (**                                      **)
  6. (**    No part of this program, or parts derived from this program,      **)
  7. (**    may be sold, hired or otherwise exploited without the author's      **)
  8. (**    written consent.                          **)
  9. (**                                      **)
  10. (**    The program may be freely redistributed provided that:          **)
  11. (**                                      **)
  12. (**        1) the original program text, including this notice,      **)
  13. (**           is reproduced unaltered,                  **)
  14. (**        2) no charge (other than a nominal media cost) is      **)
  15. (**           demanded for the copy.                  **)
  16. (**                                      **)
  17. (**    The program may be included in a package only on the condition      **)
  18. (**    that the package as a whole is distributed at media cost.      **)
  19. (**                                      **)
  20. (***************************************************************************)
  21. (***************************************************************************)
  22. (**                                      **)
  23. (**    The program ptc is a Pascal-to-C translator.              **)
  24. (**    It accepts a correct Pascal program and creates a C program      **)
  25. (**    with the same behaviour. It is not a complete compiler in the      **)
  26. (**    sense that it does NOT do complete typechecking or error-      **)
  27. (**    reporting. Only a minimal typecheck is done so that the meaning      **)
  28. (**    of each construct can be determined. Therefore, an incorrect      **)
  29. (**    Pascal program can easily cause the translator to malfunction.      **)
  30. (**                                      **)
  31. (***************************************************************************)
  32. (***************************************************************************)
  33. (**                                      **)
  34. (**    Things which are known to be dependent on the underlying cha-      **)
  35. (**    racterset are marked with a comment containing the word    CHAR.      **)
  36. (**    Things that are known to be dependent on the host operating      **)
  37. (**    system are marked with a comment containing the word OS.      **)
  38. (**    Things known to be dependent on the cpu and/or the target C-      **)
  39. (**    implementation are marked with the word CPU.              **)
  40. (**    Things dependent on the target C-library are marked with LIB.      **)
  41. (**                                      **)
  42. (**    The code generated by the translator assumes that there    is a      **)
  43. (**    C-implementation with at least a reasonable <stdio> library      **)
  44. (**    since all input/output is implemented in terms of C functions      **)
  45. (**    like fprintf(), getc(), fopen(), fseek() etc.              **)
  46. (**    If the source-program uses Pascal functions like sin(), sqrt()      **)
  47. (**    etc, there must also exist such functions in the C-library.      **)
  48. (**                                      **)
  49. (***************************************************************************)
  50. (***************************************************************************)
  51.  
  52. program    ptc(input, output, erroutput);
  53.  
  54. label    9999;                (* end of program        *)
  55.  
  56. const    version        = '@(#)ptc.p    2.6  Date 87/09/12';
  57.     rcsid        = '$Id: p.ptc 1.3 91/03/09 20:54:02 gtoal Exp Locker: gtoal $';
  58.     rcsrevision    = '$Revision: 1.3 $';
  59.  
  60.     keytablen    = 39;        (* nr of keywords        *)
  61.                    (* Added 'others' *)
  62.     keywordlen    = 10;        (* length of a keyword        *)
  63.     othersym    = 'otherwise '; (* keyword for others        *)
  64.     anothersym    = 'others    '; (* synonym for others        *)
  65.     externsym    = 'external  '; (* keyword for external        *)
  66.     dummysym    = '          '; (* dummy keyword        *)
  67.  
  68.     (* a Pascal set is implemented as an array of "wordtype" where    *)
  69.     (* each element contains bits numbered from 0 to "setbits"    *)
  70.     wordtype    = 'unsigned int';    (* CPU *)
  71.     setbits        = 31;            (* CPU *)
  72.  
  73.     maxsetrange    = 32;            (* nr of words in a set    *)
  74.     scalbase    = 0;    (* ordinal value of first scalar member    *)
  75.  
  76.     maxprio        = 7;
  77.  
  78.     maxmachdefs    = 8;    (* max nr of machine integer types    *)
  79.     machdeflen    = 16;    (* max length of machine int type name    *)
  80.  
  81.     (* limit of identifier table, identifiers and strings are saved    *)
  82.     (* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char    *)
  83.     maxstrblk    = 1023;
  84.     maxblkcnt    = 1023;
  85.     maxstrstor    = 1048575; (* maxstrstor should be ==
  86.                     (maxblkcnt+1) * (maxstrblk+1) - 1 *)
  87.  
  88.     maxtoknlen    = 127;    (* max size of token (i.e. identifier,
  89.                    string or number); must be > keywordlen
  90.                    and should be <= 256, see hashtokn()    *)
  91.  
  92.     hashmax        = 512;    (* size of hashtable - 1        *)
  93.  
  94.     null        = 0;    (* "impossible" character value, CHAR;
  95.                    a char with this value is used as delimiter
  96.                    of strings in "strstor" and in toknbuffers;
  97.                    it is also used as end-of-input marker by
  98.                    the input procedures in lexical analysis *)
  99.  
  100.     minchar        = null;
  101.     maxchar        = 255;    (* greatest possible character, CHAR; limits
  102.                    the number of elements in type "char" *)
  103.  
  104.     (* some frequently used characters *)
  105.     space        = ' ';
  106.     tab        = '    ';
  107.     tab1        = '    ';
  108.     tab2        = '        ';
  109.     tab3        = '            ';
  110.     tab4        = '                ';
  111.     bslash        = '\';
  112.     nlchr        = '''\n''';
  113.     ffchr        = '''\f''';
  114.     nulchr        = '''\0''';
  115.     spchr        = ''' ''';
  116.     quote        = '''';
  117.     cite        = '"';
  118.     xpnent        = 'e';        (* exponent char in output. CPU    *)
  119.     percent        = '%';
  120.     uscore        = '_';
  121.     badchr        = '?';        (* CHAR *)
  122.     okchr        = quote;    (* CHAR *)
  123.  
  124.     tabwidth    = 8;        (* width of a tab-stop. OS    *)
  125.  
  126.     diffcomm    = false;     (* comment delimiters different    *)
  127.     lazyfor        = false;     (* compile for-stmts a la C    *)
  128.     unionnew    = true;     (* malloc unions for variants    *)
  129.  
  130.     inttyp        = 'int';    (* for predefined functions    *)
  131.     chartyp        = 'unsigned char';
  132.     plainchartyp    = 'char';
  133.     setwtyp        = 'setword';
  134.     setptyp        = 'setptr';
  135.     floattyp    = 'float';
  136.     doubletyp    = 'double';
  137.     dblcast        = '(double)';    (* for predefined functions    *)
  138.  
  139.     realtyp        = floattyp;    (* user real-vars and functions    *)
  140.  
  141.     voidtyp        = 'void';    (* for procedures         *)
  142.     voidcast    = '(void)';
  143.  
  144.     align        = true;        (* align literal params        *)
  145.  
  146.     intlen        = 10;        (* length of written integer    *)
  147.     fixlen        = 20;        (* length of written real    *)
  148.  
  149. type
  150.     hashtyp    = 0 .. hashmax;        (* index to hash-tables    *)
  151.  
  152.     strindx    = 0 .. maxstrstor;    (* index to "strstor"        *)
  153.  
  154.     (* string-table "strstor" is implemented as an array that is grown
  155.        dynamically by adding blocks when needed *)
  156.     strbidx    = integer; (* 0 .. maxstrblk+1; *)
  157.         (* integer because many varibles of this type in fact get
  158.           the value maxstrblk+1.  Argh, Pascal subranges are
  159.           stupid. *) 
  160.     strblk    = array [ 0 .. maxstrblk ] of char;
  161.     strptr    = ^ strblk;
  162.     strbcnt    = 0 .. maxblkcnt;
  163.  
  164.     (* table for stored identifiers *)
  165.     (* an identifier in any scope is represented by an idnode which is
  166.        hooked to a slot in "idtab" as determined by a hash-function.
  167.        whenever the input procedures find an identifier its idnode is
  168.        immediately located, or created, if none was found; the identifier
  169.        is then always handled though a pointer to the idnode. the actual
  170.        text of the identifier is stored in "strstor". *)
  171.     idptr    = ^ idnode;
  172.     idnode    = record
  173.             inext    : idptr;    (* chain of idnode's    *)
  174.             inref    : integer;    (* # of refs to this id    *)
  175.             ihash    : hashtyp;    (* its hash value    *)
  176.             istr    : strindx;    (* index to "strstor"    *)
  177.           end;
  178.  
  179.     (* toknbuf is used to handle identifiers and strings in those situations
  180.        where the actual text is of intrest *)
  181.     toknidx    = 1 .. maxtoknlen;
  182.     toknbuf    = array [ toknidx ] of char;
  183.  
  184.     (* a type to hold Pascal keywords *)
  185.     keyword    = packed array [ 1 .. keywordlen ] of char;
  186.  
  187.     (* predefined identifier enumeration *)
  188.     predefs = (
  189.         dabs,        darctan,    dargc,        dargv,
  190.         dbreak, (* Like dflush *)
  191.         dboolean,    dchar,        dchr,        dclose,
  192.         dcos,        ddispose,    deof,        deoln,
  193.         derroutput,
  194.         dexit,        dexp,        dfalse,        dflush,
  195.         dget,        dhalt,        dinput,        dinteger,
  196.         dln,        dmaxint,                 dnew,
  197.         dodd,        dord,        doutput,    dpage,
  198.         dpack,        dpred,        dput,        dprompt,
  199.                                 dread,
  200.         dreadln,    dreal,        dreset,        drewrite,
  201.         dround,        dseek,
  202.                 dsin,        dsqr,        dsqrt,
  203.         dsucc,        dtell,
  204.                 dtext,        dtrue,        dtrunc,
  205.         dtan,        dwrite,        dwriteln,    dunpack,
  206.         dzfp,        dztring
  207.     );
  208.  
  209.     (* lexical symbol enumeration *)
  210.     symtyp    = (
  211.         (* keywords and eof are sorted alphabetically ...... *)
  212.         sand,        sarray,        sbegin,        scase,
  213.         sconst,        sdiv,        sdo,        sdownto,
  214.         selse,        send,        sextern,    sfile,
  215.         sfor,        sforward,    sfunc,        sgoto,
  216.         sif,        sinn,        slabel,        smod,
  217.         snil,        snot,        sof,        sor,
  218.         sother2, sother,         spacked,    sproc,        spgm,
  219.         srecord,    srepeat,    sset,        sthen,
  220.         sto,        stype,        suntil,        svar,
  221.         swhile,        swith,        seof,
  222.         (* ...... sorted *)
  223.                                 sinteger,
  224.         sreal,        sstring,    schar,        sid,
  225.         splus,        sminus,        smul,        squot,
  226.         sarrow,        slpar,        srpar,        slbrack,
  227.         srbrack,    seq,        sne,        slt,
  228.         sle,        sgt,        sge,        scomma,
  229.         scolon,        ssemic,        sassign,    sdotdot,
  230.         sdot
  231.     );
  232.     symset    = set of symtyp;
  233.  
  234.     (* lexical symbol definition *)
  235.     (* the lexical symbol holds a descriptor and the value of a symbol
  236.        read by the input procedures; note that real values are represented
  237.        as strings saved in "strstor" like ordinary strings to avoid using
  238.        float-variables and float-arithmetic in the translator *)
  239.     lexsym    =
  240.         record
  241.         case st : symtyp of
  242.           sid:        (vid    : idptr);
  243.           schar:    (vchr    : char);
  244.           sinteger:    (vint    : integer);
  245.           sreal:    (vflt    : strindx);
  246.           sstring:    (vstr    : strindx);
  247.  
  248.           sand,        sarray,        sbegin,        scase,
  249.           sconst,    sdiv,        sdo,        sdownto,
  250.           selse,    send,        sextern,    sfile,
  251.           sfor,        sforward,    sfunc,        sgoto,
  252.           sif,        sinn,        slabel,        smod,
  253.           snil,        snot,        sof,        sor,
  254.           sother2, sother,    spacked,    sproc,        spgm,
  255.           srecord,    srepeat,    sset,        sthen,
  256.           sto,        stype,        suntil,        svar,
  257.           swhile,    swith,        seof,
  258.           splus,    sminus,        smul,        squot,
  259.           sarrow,    slpar,        srpar,        slbrack,
  260.           srbrack,    seq,        sne,        slt,
  261.           sle,        sgt,        sge,        scomma,
  262.           scolon,    ssemic,        sassign,    sdotdot,
  263.           sdot:        ()
  264.         end;
  265.  
  266.     (* enumeration of symnode variants *)
  267.     ltypes = (
  268.         lpredef,    lidentifier,    lfield,        lforward,
  269.         lpointer,    lstring,    llabel,        lforwlab,
  270.         linteger,    lreal,        lcharacter
  271.     );
  272.  
  273.     declptr    = ^ declnode;
  274.     treeptr    = ^ treenode;
  275.     symptr    = ^ symnode;
  276.     (* identifier/literal symbol definition *)
  277.     (* in a given scope an identifier or a label is uniquely represented
  278.        by a "symnode"; in order to have a uniform treatment of all objects
  279.        occurring in the same syntactical positions (and hence in the parse-
  280.        tree) the literal constants are represented in a similar manner *)
  281.     symnode    =
  282.         record
  283.         lsymdecl    : treeptr;    (* symbol decl. point    *)
  284.         lnext        : symptr;    (* symtab chain pointer    *)
  285.         ldecl        : declptr;    (* backptr to symtab    *)
  286.         case lt : ltypes of
  287.           lpredef,            (* a predefined id    *)
  288.           lfield,            (* a record field    *)
  289.           lpointer,            (* a pointer id        *)
  290.           lidentifier,            (* an identifier    *)
  291.           lforward:
  292.             (
  293.             lid    : idptr;    (* ptr to its idnode    *)
  294.             lused    : boolean    (* true if symbol used    *)
  295.             );
  296.           lstring:            (* a string literal     *)
  297.             (
  298.             lstr    : strindx    (* index to "strstor"    *)
  299.             );
  300.           lreal:            (* a real literal    *)
  301.             (
  302.             lfloat    : strindx    (* index to "strstor"    *)
  303.             );
  304.           lforwlab,            (* a declared label    *)
  305.           llabel:            (* label decl & defined    *)
  306.             (
  307.             lno    : integer;    (* label number        *)
  308.             lgo    : boolean    (* non-local usage    *)
  309.             );
  310.           linteger:            (* an integer literal    *)
  311.             (
  312.             linum    : integer    (* its value        *)
  313.             );
  314.           lcharacter:            (* a character literal    *)
  315.             (
  316.             lchar    : char        (* its value        *)
  317.             )
  318.         end;
  319.  
  320.     (* symbol table definition *)
  321.     (* the symbol table consists of symnodes chained along the lnext
  322.        field; the nodes are connected in reverse order of occurence (last
  323.        declared, first in chain) in the slot in the declnode determined
  324.        by the hashfunction; when a new scope is entered a new declnode is
  325.        manufactured and the previous one is hooked to the dprev field, thus
  326.        nested scopes are represented by a list of declnodes *)
  327.     declnode = record
  328.             dprev    : declptr;
  329.             ddecl    : array [ hashtyp ] of symptr
  330.            end;
  331.  
  332.     (* enumeration of nodes in parse tree *)
  333.     (* NOTE: the subrange [ assignment .. nil ]  have priorities *)
  334.     treetyp    = (
  335.         npredef,    npgm,        nfunc,        nproc,
  336.         nlabel,        nconst,        ntype,        nvar,
  337.         nvalpar,    nvarpar,    nparproc,    nparfunc,
  338.         nsubrange,    nvariant,    nfield,        nrecord,
  339.         narray,        nconfarr,    nfileof,    nsetof,
  340.         nbegin,        nptr,        nscalar,    nif,
  341.         nwhile,        nrepeat,    nfor,        ncase,
  342.         nchoise,    ngoto,        nwith,        nwithvar,
  343.         nempty,        nlabstmt,    nassign,    nformat,
  344.         nin,        neq,        nne,        nlt,
  345.         nle,        ngt,        nge,        nor,
  346.         nplus,        nminus,        nand,        nmul,
  347.         ndiv,        nmod,        nquot,        nnot,
  348.         numinus,    nuplus,        nset,        nrange,
  349.         nindex,        nselect,    nderef,        ncall,
  350.         nid,        nchar,        ninteger,    nreal,
  351.         nstring,    nnil,        npush,        npop,
  352.         nbreak
  353.     );
  354.  
  355.     (* enumeration of predefined types *)
  356.     pretyps = (
  357.         tnone,        tboolean,    tchar,        tinteger,
  358.         treal,        tstring,    tnil,        tset,
  359.         ttext,        tpoly,        terror
  360.     );
  361.  
  362.     (* enumeration of some special attributes *)
  363.     attributes = (
  364.         anone, aregister, aextern, areference
  365.     );
  366.  
  367.     (* parse tree definition *)
  368.     (* the sourceprogram is represented by a treestructure built from
  369.        treenodes where each node corresponds to one syntactic form from
  370.        the pascal program *)
  371.     treenode =
  372.         record
  373.         tnext,            (* ptr to next node in a list    *)
  374.         ttype,            (* pointer to nodes type    *)
  375.         tup    : treeptr;    (* ptr to parent node        *) 
  376.         case tt : treetyp of
  377.           npredef:        (* predefined object decl    *)
  378.             (
  379.             tdef:        (* predefined object descr.    *)
  380.                 predefs;
  381.             tobtyp:        (* object type            *)
  382.                 pretyps
  383.             );
  384.           npgm,            (* program declaration        *)
  385.           nproc,        (* procedure declaration    *)
  386.           nfunc:        (* function declaration        *)
  387.             (
  388.             tsubid,        (* subr. identifier (nid)    *)
  389.             tsubpar,    (* parameter list        *)
  390.             tfuntyp,    (* function type (nid)        *)
  391.             tsublab,    (* label decl list (nlabel)    *)
  392.             tsubconst,    (* const decl list (nconst)    *)
  393.             tsubtype,    (* type decl list (ntype)    *)
  394.             tsubvar,    (* var decl list (nvar)        *)
  395.             tsubsub,    (* subr. decl (nproc/nfunc)    *)
  396.             tsubstmt:    (* stmt. list (NOT nbegin)    *)
  397.                 treeptr;
  398.             tstat:        (* static declaration level    *)
  399.                 integer;
  400.             tscope:        (* symbol table for local id's    *)
  401.                  declptr
  402.             );
  403.           nvalpar,        (* value parameter declaration    *)
  404.           nvarpar,        (* var parameter declaration    *)
  405.           nconst,        (* constant declaration        *)
  406.           ntype,        (* type declaration        *)
  407.           nfield,        (* record field declaration    *)
  408.           nvar:            (* var declaration declaration    *)
  409.             (
  410.             tidl,        (* list of declared id's (nid)    *)
  411.             tbind:        (* var/type-type, const-value    *)
  412.                 treeptr;
  413.             tattr:        (* special attributes for vars    *)
  414.                 attributes
  415.             );
  416.           nparproc,        (* parameter procedure        *)
  417.           nparfunc:        (* parameter function        *)
  418.             (
  419.             tparid,        (* parm proc/func id (nid)    *)
  420.             tparparm,    (* parm proc/func parm decl    *)
  421.             tpartyp:    (* parm func type (nid)        *)
  422.                 treeptr
  423.             );
  424.           nptr:            (* pointer constructor        *)
  425.             (
  426.             tptrid:        (* referenced type (nid)    *)
  427.                 treeptr;
  428.             tptrflag:    (* have seen node before    *)
  429.                 boolean
  430.             );
  431.           nscalar:        (* scalar type constructor    *)
  432.             (
  433.             tscalid:    (* list of scalar ids (nid)    *)
  434.                 treeptr
  435.             );
  436.           nfileof,        (* file type constructor    *)
  437.           nsetof:        (* set type constructor        *)
  438.             (
  439.             tof:        (* set/file component type    *)
  440.                 treeptr
  441.             );
  442.           nsubrange:        (* subrange type constructor    *)
  443.             (
  444.             tlo, thi:    (* subrange limits        *)
  445.                 treeptr
  446.             );
  447.           nvariant:        (* record variant constructor    *)
  448.             (
  449.             tselct,        (* selector list (constants)    *)
  450.             tvrnt:        (* variant field decl (nrecord)    *)
  451.                 treeptr
  452.             );
  453.  
  454.         (* the tuid field is used to attach a name to variants since
  455.            C requires all union members to have names *)
  456.           nrecord:        (* record/variant constructor    *)
  457.             (
  458.             tflist,        (* fixed field list (nfield)    *)
  459.             tvlist:        (* variant list (nvariant)    *)
  460.                 treeptr;
  461.             tuid:        (* variant name            *)
  462.                 idptr;
  463.             trscope:    (* symbol table for local id's    *)
  464.                  declptr
  465.             );
  466.           nconfarr:        (* conformant array constructor    *)
  467.             (
  468.             tcindx,        (* index declaration        *)
  469.             tindtyp,    (* conf. arr. index type (nid)    *)
  470.             tcelem:        (* array element type decl    *)
  471.                 treeptr;
  472.             tcuid:        (* variant name            *)
  473.                 idptr
  474.             );
  475.           narray:        (* array type constructor    *)
  476.             (
  477.             taindx,        (* index declaration        *)
  478.             taelem:        (* array element type decl    *)
  479.                 treeptr
  480.             );
  481.           nbegin:        (* begin statement        *)
  482.             (
  483.             tbegin:        (* statement list        *)
  484.                 treeptr
  485.             );
  486.           nlabstmt:        (* labeled statement        *)
  487.             (
  488.             tlabno,        (* label number (nlabel)    *)
  489.             tstmt:        (* statement            *)
  490.                 treeptr
  491.             );
  492.           ngoto:        (* goto statement        *)
  493.             (
  494.             tlabel:        (* label to go to (nlabel)    *)
  495.                 treeptr
  496.             );
  497.  
  498.           nassign:        (* assignment statement        *)
  499.             (
  500.             tlhs,        (* variable            *)
  501.             trhs:        (* value            *)
  502.                 treeptr
  503.             );
  504.  
  505.         (* npush/npop is used in proc/func which have local variables
  506.            used in local proc/funcs; those variables are converted to
  507.            global ptrs initialized to reference the local variable *)
  508.           npush,        (* init code for proc/func    *)
  509.           npop:            (* exit code for proc/func    *)
  510.             (
  511.             tglob,        (* global identifier (nid)    *)
  512.             tloc,        (* local identifier (nid)    *)
  513.             ttmp:        (* temp store for global (nid)    *)
  514.                 treeptr
  515.             );
  516.  
  517.           nbreak:
  518.             (
  519.             tbrkid,        (* for-variable            *)
  520.             tbrkxp:        (* value for break        *)
  521.                 treeptr
  522.             );
  523.  
  524.           ncall:        (* procedure/function call    *)
  525.             (
  526.             tcall,        (* called identifier        *)
  527.             taparm:        (* actual paramters        *)
  528.                 treeptr
  529.             );
  530.           nif:            (* if statement            *)
  531.             (
  532.             tifxp,        (* conditional expression    *)
  533.             tthen,        (* stmt execd if true condition    *)
  534.             telse:        (* stmt execd if true condition    *)
  535.                 treeptr
  536.             );
  537.           nwhile:        (* while statemnet        *)
  538.             (
  539.             twhixp,        (* conditional expression    *)
  540.             twhistmt:    (* stmt execd if true condition    *)
  541.                 treeptr
  542.             );
  543.           nrepeat:        (* repeat statement        *)
  544.             (
  545.             treptstmt,    (* statement list        *)
  546.             treptxp:    (* conditional expression    *)
  547.                 treeptr
  548.             );
  549.           nfor:            (* for statement        *)
  550.             (
  551.             tforid,        (* loop control variable (nid)    *)
  552.             tfrom,        (* initial value        *)
  553.             tto,        (* final value            *)
  554.             tforstmt:    (* stmt execd in loop        *)
  555.                 treeptr;
  556.             tincr:        (* to/downto flag true <==> to    *)
  557.                 boolean
  558.             );
  559.           ncase:        (* case statement        *)
  560.             (
  561.             tcasxp,        (* selecting expression        *)
  562.             tcaslst,    (* list of choises        *)
  563.             tcasother:    (* default action        *)
  564.                 treeptr
  565.             );
  566.           nchoise:        (* a choise in a case-stmt    *)
  567.             (
  568.             tchocon,    (* list of constants        *)
  569.             tchostmt:    (* execd statement        *)
  570.                 treeptr
  571.             );
  572.           nwith:        (* with statment        *)
  573.             (
  574.             twithvar,    (* list of variables (nwithvar)    *)
  575.             twithstmt:    (* statement execd in new scope    *)
  576.                 treeptr
  577.             );
  578.  
  579.         (* the local symbol table holds identifiers, picked from
  580.            the record fields, temporarily declared during parsing
  581.            of remainder of with-statement; these identifiers are
  582.            later converted into fields referenced through a ptr *)
  583.           nwithvar:        (* variable in with statement    *)
  584.             (
  585.             texpw:        (* record variable        *)
  586.                 treeptr;
  587.             tenv:        (* symbol table for local scope    *)
  588.                 declptr
  589.             );
  590.  
  591.           nindex:        (* array indexing expression    *)
  592.             (
  593.             tvariable,    (* indexed variable        *)
  594.             toffset:    (* index expression        *)
  595.                 treeptr
  596.             );
  597.           nselect:        (* record field selection expr    *)
  598.             (
  599.             trecord,    (* record variable        *)
  600.             tfield:        (* selected field (nid)        *)
  601.                 treeptr
  602.             );
  603.  
  604.         (* binary operators or constructors *)
  605.           nrange,        (* .. (set range)    *)
  606.           nformat,        (* :  (write format)    *)
  607.           nin,            (* in            *)
  608.           neq,            (* =            *)
  609.           nne,            (* <>            *)
  610.           nlt,            (* <            *)
  611.           nle,            (* <=            *)
  612.           ngt,            (* >            *)
  613.           nge,            (* >=            *)
  614.           nor,            (* or            *)
  615.           nplus,        (* +            *)
  616.           nminus,        (* -            *)
  617.           nand,            (* and            *)
  618.           nmul,            (* *            *)
  619.           ndiv,            (* div            *)
  620.           nmod,            (* mod            *)
  621.           nquot:        (* /            *)
  622.             (
  623.             texpl,        (* left operand expr    *)
  624.             texpr:        (* right operand expr    *)
  625.                 treeptr
  626.             );
  627.  
  628.         (* unary operators or constructors; note that uplus is
  629.            used to represent any parenthesized expression *)
  630.           nderef,        (* ^ (ptr dereference)    *)
  631.           nnot,            (* not            *)
  632.           nset,            (* [ ] (set constr)    *)
  633.           nuplus,        (* +            *)
  634.           numinus:        (* -            *)
  635.             (
  636.             tisassigndest:    (* used to prevent lazy i/o when
  637.                        assigning to file buffer variable *)
  638.                 boolean;
  639.             texps:        (* operand expression    *)
  640.                 treeptr
  641.             );
  642.  
  643.           nid,            (* identifier in decl or stmt    *)
  644.           nreal,        (* literal real (decl or stmt)    *)
  645.           ninteger,        (* literal int ( - " - )    *)
  646.           nchar,        (* literal char ( - " - )    *)
  647.           nstring,        (* literal string ( - " - )    *)
  648.           nlabel:        (* label (decl, defpt or use)    *)
  649.             (
  650.             tsym:
  651.                 symptr
  652.             );
  653.  
  654.           nnil,            (* nil (pointer constant)    *)
  655.           nempty:        (* empty statement        *)
  656.             ( );
  657.         end;
  658.  
  659.     (* "reserved" words and standard identifiers from C, C LIB and
  660.         OS environment excluding those reserved in Pascal *)
  661.     cnames = (
  662.         cabort,        cbreak,        ccontinue,    cdefine,
  663.         cdefault,    cdouble,    cedata,        cenum,
  664.         cetext,        cextern,    cfgetc,        cfclose,
  665.         cfflush,    cfloat,        cfloor,        cfprintf,
  666.         cfputc,        cfread,        cfscanf,    cfwrite,
  667.         cgetc,        cgetpid,    cint,        cinclude,
  668.         clong,        clog,        cmain,        cmalloc,
  669.         cprintf,    cpower,        cputc,        cread,
  670.         creturn,    cregister,    crewind,    cscanf,
  671.         csetbits,    csetword,    csetptr,    cshort,
  672.         csigned,    csizeof,    csprintf,    cstdin,
  673.         cstdout,    cstderr,    cstrncmp,    cstrncpy,
  674.         cstruct,    cstatic,    cswitch,    ctypedef,
  675.         cundef,        cungetc,    cunion,        cunlink,
  676.         cfseek,        cgetchar,    cputchar,
  677.         cunsigned,    cwrite
  678.     );
  679.  
  680.     (* these are the detected errors. some are user-errors,
  681.        some are internal problems and some are host system errors *)
  682.     errors    = (
  683.         ebadsymbol,    elongstring,    elongtokn,    erange,
  684.         emanytokn,    enotdeclid,    emultdeclid,    enotdecllab,
  685.         emultdecllab,    emuldeflab,    ebadstring,    enulchr,
  686.         ebadchar,    eeofcmnt,    eeofstr,    evarpar,
  687.         enew,        esetbase,    esetsize,    eoverflow,
  688.         etree,        etag,        euprconf,    easgnconf,
  689.         ecmpconf,    econfconf,    evrntfile,    evarfile,
  690.         emanymachs,    ebadmach,    eprconf
  691.     );
  692.  
  693.     machdefstr = packed array [ 1 .. machdeflen ] of char;
  694.  
  695. var
  696.     usemax,            (* program needs max-function        *)
  697.     usejmps,        (* source program uses non-local gotos    *)
  698.     usecase,        (* source program has case-statement    *)
  699.     usesets,        (* source program uses set-operations    *)
  700.     useunion,
  701.     usediff,
  702.     usemksub,
  703.     useintr,
  704.     usesge,
  705.     usesle,
  706.     useseq,
  707.     usesne,
  708.     usememb,
  709.     useins,
  710.     usescpy,
  711.     usecomp,        (* source program uses string-compare    *)
  712.     usealig,        (* source program uses aligned params    *)
  713.     usesal : boolean;
  714.  
  715.     top    : treeptr;    (* top of parsetree, result from parse    *)
  716.  
  717.     setlst    : treeptr;    (* list of set-initializations        *)
  718.     setcnt    : integer;    (* counter for setlst length        *)
  719.  
  720.     currsym    : lexsym;    (* current lexical symbol        *)
  721.  
  722.     keytab    : array [ 0 .. keytablen ] of    (* table of keywords    *)
  723.             record
  724.             wrd    : keyword;    (* keyword text        *)
  725.             sym    : symtyp    (* corresponding symbol    *)
  726.             end;
  727.  
  728.     strstor    : array [ strbcnt ] of strptr;    (* store for strings    *)
  729.     strfree    : strindx;            (* first free position    *)
  730.     strleft    : strbidx;            (* room in last blk    *)
  731.  
  732.     idtab    : array [ hashtyp ] of idptr;    (* hashed table of id's    *)
  733.  
  734.     symtab    : declptr;            (* table of symbols    *)
  735.  
  736.     statlvl,                (* static decl. level    *)
  737.     maxlevel : integer;            (*  - " - maximum value    *) 
  738.  
  739.     deftab    : array [ predefs ] of treeptr;    (* predefined idents.    *)
  740.     defnams    : array [ predefs ] of symptr;    (*        - " -        *)
  741.     typnods    : array [ pretyps ] of treeptr;    (* predef. types.    *)
  742.  
  743.     pprio,
  744.     cprio    : array [ nassign .. nnil ] of 0 .. maxprio;
  745.  
  746.     ctable    : array [ cnames ] of idptr;    (* table of C-keywords    *)
  747.  
  748.     nmachdefs : 0 .. maxmachdefs;
  749.     machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types    *)
  750.             record
  751.                 lolim, hilim    : integer;
  752.                 typstr        : strindx
  753.             end;
  754.  
  755.     lineno,                    (* input line number    *)
  756.     colno,                    (* input column number    *)
  757.     lastcol,                (* last OK input column    *)
  758.     lastline : integer;            (* last OK input line    *)
  759.  
  760.     lasttok    : toknbuf;            (* last input token    *)
  761.  
  762.     varno    : integer;        (* counter for unique id's    *)
  763.  
  764.     pushchr    : char;            (* pushback for lexical scanner    *)
  765.     pushed    : boolean;
  766.  
  767.     hexdig    : array [ 0 .. 15 ] of char;
  768. { IF-PASCAL
  769.     erroutput : text;
  770. END-IF-PASCAL }
  771.  
  772. (*    Prtmsg produces an error message.                               *)
  773. procedure prtmsg(m : errors);
  774.  
  775. const    user    = 'Error: ';
  776.     restr    = 'Implementation restriction: ';
  777.     inter    = '* Internal error * ';
  778.     xtoklen    = 64;                (* should be <= maxtoklen *)
  779.  
  780. var    i    : toknidx;
  781.     xtok    : packed array [ 1 .. xtoklen ] of char;
  782.  
  783. begin
  784.     case m of
  785.       ebadsymbol:
  786.         writeln(erroutput, user, 'Unexpected symbol');
  787.       ebadchar:
  788.         writeln(erroutput, user, 'Bad character');
  789.       elongstring:
  790.         writeln(erroutput, restr, 'Too long string');
  791.       ebadstring:
  792.         writeln(erroutput, user, 'Newline in string or character');
  793.       eeofstr:
  794.         writeln(erroutput, user, 'End of file in string or character');
  795.       eeofcmnt:
  796.         writeln(erroutput, user, 'End of file in comment');
  797.       elongtokn:
  798.         writeln(erroutput, restr, 'Too long identfier');
  799.       emanytokn:
  800.         writeln(erroutput, restr, 'Too many strings, identifiers or real numbers');
  801.       enotdeclid:
  802.         writeln(erroutput, user, 'Identifier not declared');
  803.       emultdeclid:
  804.         writeln(erroutput, user, 'Identifier declared twice');
  805.       enotdecllab:
  806.         writeln(erroutput, user, 'Label not declared');
  807.       emultdecllab:
  808.         writeln(erroutput, user, 'Label declared twice');
  809.       emuldeflab:
  810.         writeln(erroutput, user, 'Label defined twice');
  811.       evarpar:
  812.         writeln(erroutput, user, 'Actual parameter not a variable');
  813.       enulchr:
  814.         writeln(erroutput, restr, 'Cannot handle nul-character in strings');
  815.       enew:
  816.         writeln(erroutput, restr, 'New returned a nil-pointer');
  817.       eoverflow:
  818.         writeln(erroutput, restr, 'Token buffer overflowed');
  819.       esetbase:
  820.         writeln(erroutput, restr, 'Cannot handle sets with base >> 0');
  821.       esetsize:
  822.         writeln(erroutput, restr, 'Cannot handle sets with very large range');
  823.       etree:
  824.         writeln(erroutput, inter, 'Bad tree structure');
  825.       etag:
  826.         writeln(erroutput, inter, 'Cannot find tag');
  827.       evrntfile:
  828.         writeln(erroutput, restr, 'Cannot initialize files in record variants');
  829.       evarfile:
  830.         writeln(erroutput, restr, 'Cannot handle files in structured variables');
  831.       euprconf:
  832.         writeln(erroutput, inter, 'No upper bound on conformant arrays');
  833.       easgnconf:
  834.         writeln(erroutput, inter, 'Cannot assign conformant arrays');
  835.       ecmpconf:
  836.         writeln(erroutput, inter, 'Cannot compare conformant arrays');
  837.       econfconf:
  838.         writeln(erroutput, restr, 'Cannot handle nested conformat arrays');
  839.       erange:
  840.         writeln(erroutput, inter, 'Cannot find C-type for integer-subrange');
  841.       emanymachs:
  842.         writeln(erroutput, restr, 'Too many machine integer types');
  843.       ebadmach:
  844.         writeln(erroutput, inter, 'Bad name for machine integer type');
  845.       eprconf:
  846.         writeln(erroutput, inter, 'Cannot write conformant arrays');
  847.     end;(* case *)
  848.     if lastline <> 0 then
  849.         begin
  850.         (* error detected during parsing,
  851.             report line/column and print the offending symbol *)
  852.         writeln(erroutput, 'Line ', lastline:1, ', col ', lastcol:1, ':');
  853.         if m in [enulchr, ebadchar, ebadstring, ebadsymbol,
  854.             emuldeflab, emultdecllab, enotdecllab, emultdeclid,
  855.             enotdeclid, elongtokn, elongstring] then
  856.             begin
  857.             i := 1;
  858.             while (i < xtoklen) and (lasttok[i] <> chr(null)) do
  859.                 begin
  860.                 xtok[i] := lasttok[i];
  861.                 i := i + 1
  862.                 end;
  863.             writeln(erroutput, 'Current symbol: ', xtok:i-1)
  864.             end
  865.         end
  866. end;
  867.  
  868. procedure fatal(m : errors);    forward;
  869. procedure error(m : errors);    forward;
  870.  
  871. (*    Map letters to upper-case.                    *)
  872. (*    This function assumes a machine collating sequence where the    *)
  873. (*    letters of either case form a contigous sequence, CHAR.    *)
  874. function uppercase(c : char) : char;
  875.  
  876. begin
  877.     if (c >= 'a') and (c <= 'z') then
  878.         uppercase := chr(ord(c) + ord('A') - ord('a'))
  879.     else
  880.         uppercase := c
  881. end;
  882.  
  883.  
  884. (*    Map letters to lower-case.                    *)
  885. (*    This function assumes a machine collating sequence where the    *)
  886. (*    letters of either case form a contigous sequence, CHAR.    *)
  887. function lowercase(c : char) : char;
  888.  
  889. begin
  890.     if (c >= 'A') and (c <= 'Z') then
  891.         lowercase := chr(ord(c) - ord('A') + ord('a'))
  892.     else
  893.         lowercase := c
  894. end;
  895.  
  896. (*    Retrieve a string from strstor.                *)
  897. procedure gettokn(i : strindx; var t : toknbuf);
  898.  
  899. var    c    : char;
  900.     k    : toknidx;
  901.     j    : strbidx;
  902.     p    : strptr;
  903.  
  904. begin
  905.     k := 1;
  906.     (* compute block and offset in block *)
  907.     p := strstor[i div (maxstrblk + 1)];
  908.     j := i mod (maxstrblk + 1);
  909.     (* retrieve text up to null *)
  910.     repeat
  911.         c := p^[j];
  912.         t[k] := c;
  913.         j := j + 1;
  914.         k := k + 1;
  915.         if k = maxtoknlen then
  916.             begin
  917.             c := chr(null);
  918.             t[maxtoknlen] := chr(null);
  919.             prtmsg(eoverflow)
  920.             end
  921.     until    c = chr(null)
  922. end;
  923.  
  924. (*    Deposit a string into strstor at a given start-position.    *)
  925. procedure puttokn(i : strindx; var t : toknbuf);
  926.  
  927. var    c    : char;
  928.     k    : toknidx;
  929.     j    : strbidx;
  930.     p    : strptr;
  931.  
  932. begin
  933.     k := 1;
  934.     p := strstor[i div (maxstrblk + 1)];
  935.     j := i mod (maxstrblk + 1);
  936.     repeat
  937.         c := t[k];
  938.         p^[j] := c;
  939.         k := k + 1;
  940.         j := j + 1
  941.     until    c = chr(null)
  942. end;
  943.  
  944. (*    Write a token on standard output.                *)
  945. procedure writetok(var w : toknbuf);
  946.  
  947. var    j    : toknidx;
  948.  
  949. begin
  950.     j := 1;
  951.     while w[j] <> chr(null) do
  952.         begin
  953.         write(w[j]);
  954.         j := j + 1
  955.         end
  956. end;
  957.  
  958. (*    Print a float number on standard output.            *)
  959. procedure printtok(i : strindx);
  960.  
  961. var    w    : toknbuf;
  962.  
  963. begin
  964.     gettokn(i, w);
  965.     writetok(w)
  966. end;
  967.  
  968. (*    Print an identifier on standard output.                *)
  969. procedure printid(ip : idptr);
  970.  
  971. begin
  972.     printtok(ip^.istr)
  973. end;
  974.  
  975. (*    Print a character on standard output with proper C-quoting.    *)
  976. procedure printchr(c : char);
  977.  
  978. begin
  979.     if (c = quote) or (c = bslash) then
  980.         write(quote, bslash, c, quote)
  981.     else
  982.         write(quote, c, quote)
  983. end;
  984.  
  985. (*    Print a string on standard output with proper C-quoting.    *)
  986. procedure printstr(i : strindx);
  987.  
  988. var    k    : toknidx;
  989.     c    : char;
  990.     w    : toknbuf;
  991.  
  992. begin
  993.     gettokn(i, w);
  994.     write(cite);
  995.     k := 1;
  996.     while w[k] <> chr(null) do
  997.         begin
  998.         c := w[k];
  999.         k := k + 1;
  1000.         if (c = cite) or (c = bslash) then
  1001.             write(bslash);
  1002.         write(c)
  1003.         end;
  1004.     write(cite)
  1005. end;
  1006.  
  1007. (*    Return a pointer to the declarationpoint of an identifier.    *)
  1008. function idup(ip : treeptr) : treeptr;
  1009.  
  1010. begin
  1011.     idup := ip^.tsym^.lsymdecl^.tup
  1012. end;
  1013.  
  1014. (*    Compute a hashvalue for an identifier or a string.        *)
  1015. function hashtokn(var id : toknbuf) : hashtyp;
  1016.  
  1017. var    h    : integer;
  1018.     i    : toknidx;
  1019.  
  1020. begin
  1021.     i := 1;
  1022.     h := 0;
  1023.     while id[i] <> chr(null) do
  1024.         begin
  1025.         (* if ord() of a character ranges from 0 to 127 then we can loop
  1026.            256 times without causing h to exceed 32767, this is safe as
  1027.            both strings and identifiers are limited in length *)
  1028.         h := h + ord(id[i]);    (* CHAR, CPU *)
  1029.         i := i + 1
  1030.         end;
  1031.     hashtokn := h mod hashmax
  1032. end;
  1033.  
  1034. (*    Global string table update.                    *)
  1035. (*    This function accepts a string and stores it in strstor.    *)
  1036. (*    It returns the id-number for the new string.            *)
  1037. function savestr(var t : toknbuf) : strindx;
  1038.  
  1039. var    k    : toknidx;
  1040.     i    : strindx;
  1041.     j    : strbcnt;
  1042.  
  1043. begin
  1044.     (* find length of new string including null-char *)
  1045.     k := 1;
  1046.     while t[k] <> chr(null) do
  1047.         k := k + 1;
  1048.     if k > strleft then
  1049.         begin
  1050.         (* out of space in strstore *)
  1051.         if strstor[maxblkcnt] <> nil then    (* last slot used *)
  1052.             error(emanytokn);
  1053.         (* allocate a new block *)
  1054.         j := (strfree + maxstrblk) div (maxstrblk + 1);
  1055.         new(strstor[j]);
  1056.         if strstor[j] = nil then
  1057.             error(enew);
  1058.         strfree := j * (maxstrblk + 1);
  1059.         strleft := maxstrblk
  1060.         end;
  1061.     (* copy new str, update location of last used cell,
  1062.        return starting location for new str *)
  1063.     i := strfree;
  1064.     strfree := strfree + k;
  1065.     strleft := strleft - k;
  1066.     puttokn(i, t);
  1067.     savestr := i
  1068. end;
  1069.  
  1070. (*    Global id table lookup.                        *)
  1071. (*    This procedure accepts an identifier and determines if it has    *)
  1072. (*    been seen before. If that is the case a pointer to its idnode    *)
  1073. (*    is returned, otherwise the identifier is saved and a pointer to    *)
  1074. (*    a new node is returned.                        *)
  1075. function saveid(var id : toknbuf) : idptr;
  1076.  
  1077. label    999;
  1078.  
  1079. var    k    : toknidx;
  1080.     ip    : idptr;
  1081.     h    : hashtyp;
  1082.     t    : toknbuf;
  1083.  
  1084. begin
  1085.     h := hashtokn(id);
  1086.     ip := idtab[h];                (* scan hashlist for id    *)
  1087.     while ip <> nil do
  1088.         begin
  1089.         gettokn(ip^.istr, t);        (* look at saved token    *)
  1090.         k := 1;
  1091.         while id[k] = t[k] do
  1092.             if id[k] = chr(null) then
  1093.                 goto 999    (* found it!        *)
  1094.             else
  1095.                 k := k + 1;    (* look at next char    *)
  1096.         ip := ip^.inext
  1097.         end;
  1098.  
  1099.     (* identifier wasn't previously seen, manufacture a new idnode,
  1100.        save index to strstor and hashvalue, insert idnode in idtab *)
  1101.     new(ip);
  1102.     if ip = nil then
  1103.         error(enew);
  1104.     ip^.inref := 0;
  1105.     ip^.istr := savestr(id);
  1106.     ip^.ihash := h;
  1107.     ip^.inext := idtab[h];
  1108.     idtab[h] := ip;
  1109.  
  1110. 999:
  1111.     (* return the idnode *)
  1112.     saveid := ip
  1113. end;
  1114.  
  1115. (*    This function creates a new variable by concatenating one name    *)
  1116. (*    with another injecting a given separator.            *)
  1117. function mkconc(sep : char; p, q : idptr) : idptr;
  1118.  
  1119. var    w, x    : toknbuf;
  1120.     i, j    : toknidx;
  1121.  
  1122. begin
  1123.     (* fetch second part and determine its length *)
  1124.     gettokn(q^.istr, x);
  1125.     j := 1;
  1126.     while x[j] <> chr(null) do
  1127.         j := j + 1;
  1128.     (* fetch first part and locate its end *)
  1129.     w[1] := chr(null);
  1130.     if p <> nil then
  1131.         gettokn(p^.istr, w);
  1132.     i := 1;
  1133.     while w[i] <> chr(null) do
  1134.         i := i + 1;
  1135.     (* check total length *)
  1136.     if i + j + 2 >= maxtoknlen then
  1137.         error(eoverflow);
  1138.  
  1139.     (* add separators *)
  1140.     if sep = '>' then
  1141.         begin
  1142.         (* special case 1: > gives arrow: a->b *)
  1143.         w[i] := '-';
  1144.         i := i + 1
  1145.         end;
  1146.     if sep <> space then
  1147.         begin
  1148.         (* special case 2: space gives nothing: ab *)
  1149.         w[i] := sep;
  1150.         i := i + 1
  1151.         end;
  1152.     (* add second part *)
  1153.     j := 1;
  1154.     repeat
  1155.         w[i] := x[j];
  1156.         i := i + 1;
  1157.         j := j + 1
  1158.     until w[i-1] = chr(null);
  1159.     (* save new identifier *)
  1160.     mkconc := saveid(w)
  1161. end;
  1162.  
  1163. (*    Create a new id with name-prefix from w.            *)
  1164. function mkuniqname(var t : toknbuf) : idptr;
  1165.  
  1166. var    i    : toknidx;
  1167.  
  1168.     procedure dig(n : integer);
  1169.     begin
  1170.         if n > 0 then
  1171.             begin
  1172.             dig(n div 10);
  1173.             if i = maxtoknlen then
  1174.                 error(eoverflow);
  1175.             t[i] := chr(n mod 10 + ord('0'));    (* CHAR *)
  1176.             i := i + 1
  1177.             end
  1178.     end;
  1179.  
  1180. begin
  1181.     i := 1;
  1182.     while t[i] <> chr(null) do
  1183.         i := i + 1;
  1184.     varno := varno + 1;
  1185.     dig(varno);
  1186.     t[i] := chr(null);
  1187.     mkuniqname := saveid(t)
  1188. end;
  1189.  
  1190. (*    Make a new unique variable with given char as prefix.        *)
  1191. function mkvariable(c : char) : idptr;
  1192.  
  1193. var    t    : toknbuf;
  1194.  
  1195. begin
  1196.     t[1] := c;
  1197.     t[2] := chr(null);
  1198.     mkvariable := mkuniqname(t)
  1199. end;
  1200.  
  1201. (*    Make a new unique variable with given char as prefix and    *)
  1202. (*    with a given id as tail. Commonly used for renaming id's.    *)
  1203. function mkrename(c : char; ip : idptr) : idptr;
  1204.  
  1205. begin
  1206.     mkrename := mkconc(uscore, mkvariable(c), ip)
  1207. end;
  1208.  
  1209. (*    Make a name for a variant. Variants are mapped onto C unions,    *)
  1210. (*    which we always give the name "U", thus the name of the variant    *)
  1211. (*    becomes "U.Vnnn" where "nnn" is a unique number.        *)
  1212. function mkvrnt : idptr;
  1213.  
  1214. var    t    : toknbuf;
  1215.  
  1216. begin
  1217.     t[1] := 'U';
  1218.     t[2] := '.';
  1219.     t[3] := 'V';
  1220.     t[4] := chr(null);
  1221.     mkvrnt := mkuniqname(t)
  1222. end;
  1223.  
  1224. procedure checksymbol(ss : symset);
  1225. begin
  1226.     if not (currsym.st in ss) then
  1227.         error(ebadsymbol);
  1228. end;
  1229.  
  1230. (*    Lexical analysis routine.                    *)
  1231. (*    This procedure reads and classifies the next lexical token in    *)
  1232. (*    the input stream. The token is saved in the global variable    *)
  1233. (*    "currsym". The found symbol should be one of the symbols given    *)
  1234. (*    in the parameter "ss" otherwise the error routine is called.    *)
  1235. procedure nextsymbol(ss : symset);
  1236.  
  1237. var    lastchr    : 0 .. maxtoknlen;
  1238.  
  1239.     (*    This function reads the next character from the input    *)
  1240.     (*    and updates "lineno" and "colno" accordingly.        *)
  1241.     function nextchar : char;
  1242.  
  1243.     var    c    : char;
  1244.  
  1245.     begin
  1246.         if pushed then
  1247.             begin
  1248.             c := pushchr;
  1249.             pushed := false
  1250.             end
  1251.         else if eof then
  1252.             c := chr(null)
  1253.         else begin
  1254.             colno := colno + 1;
  1255.             if eoln then
  1256.                 begin
  1257.                 lineno := lineno + 1;
  1258.                 colno := 0
  1259.                 end;
  1260.             read(c);
  1261.             if c = tab then
  1262.                 colno := (((colno - 1) div tabwidth) + 1) *
  1263.                         tabwidth
  1264.              end;
  1265.         if lastchr > 0 then
  1266.             begin
  1267.             lasttok[lastchr] := c;
  1268.             lastchr := lastchr + 1
  1269.             end;
  1270.         nextchar := c
  1271.     end;
  1272.  
  1273.     (*    This function looks at the next input character.    *)
  1274.     function peekchar : char;
  1275.  
  1276.     begin
  1277.         if pushed then
  1278.             peekchar := pushchr
  1279.         else if eof then
  1280.             peekchar := chr(null)
  1281.         else
  1282.             peekchar := input^
  1283.     end;
  1284.  
  1285.     (*    Read and classify the next token.            *)
  1286.     procedure nexttoken(realok : boolean);
  1287.  
  1288.     var    c    : char;
  1289.         n    : integer;
  1290.  
  1291.         ready    : boolean;
  1292.  
  1293.         wl    : 0..maxtoknlen;
  1294.         wb    : toknbuf;
  1295.  
  1296.         (*    Determine if c is valid in an identifier.    *)
  1297.         (*    This function assumes a machine collating    *)
  1298.         (*    sequence where letters and digits form conti-    *)
  1299.         (*    gous sequences, CHAR.                *)
  1300.         function idchar(c : char) : boolean;
  1301.  
  1302.         begin
  1303.             idchar := 
  1304.                 (c >= 'a') and (c <= 'z') or
  1305.                     (c >= '0') and (c <= '9') or
  1306.                     (c >= 'A') and (c <= 'Z') or
  1307.                         (c = uscore)
  1308.         end;
  1309.  
  1310.         (*    Determine if c is valid in a number. CHAR.    *)
  1311.         function numchar(c : char) : boolean;
  1312.  
  1313.         begin
  1314.             numchar := (c >= '0') and (c <= '9')
  1315.         end;
  1316.  
  1317.         (*    Convert a digit to its numeric value. CHAR    *)
  1318.         function numval(c : char) : integer;
  1319.  
  1320.         begin
  1321.             numval := ord(c) - ord('0')
  1322.         end;
  1323.  
  1324.         (*    Determine if the current token is a keyword.    *)
  1325.         function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;
  1326.  
  1327.         var    n    : 1 .. keywordlen;
  1328.             i, j, k    : 0 .. keytablen;
  1329.             wrd    : keyword;
  1330.             kwc    : symtyp;
  1331.  
  1332.         begin
  1333.             (* quick check on token length,
  1334.                pascal keywords range from 2 to 9 chars in length *)
  1335.             if (l > 1) and (l < keywordlen) then
  1336.                 begin
  1337.                 (* could be a keyword, initialize wrd *)
  1338.                 wrd := keytab[keytablen].wrd;
  1339.                 (* copy w to wrd *)
  1340.                 for n := 1 to l do
  1341.                     wrd[n] := w[n];
  1342.  
  1343.                 (* binary search for tokn,
  1344.                    relies on symtyp being sorted *)
  1345.                 i := 0;
  1346.                 j := keytablen;
  1347.                 while j > i do
  1348.                     begin
  1349.                     k := (i + j) div 2;
  1350.                     if keytab[k].wrd >= wrd then
  1351.                         j := k
  1352.                     else
  1353.                         i := k + 1
  1354.                     end;
  1355.                 if keytab[j].wrd = wrd then
  1356.                     kwc := keytab[j].sym
  1357.                 else
  1358.                     kwc := sid
  1359.                 end
  1360.             else
  1361.                 kwc := sid;
  1362.             keywordcheck := kwc
  1363.         end;
  1364.  
  1365.     begin    (* nexttoken *)
  1366.         (* don't save blanks/comments *)
  1367.         lastchr := 0;
  1368.         (* read non-blank character *)
  1369.         repeat
  1370.             c := nextchar;
  1371.             (* skip comments, the two comment delimiters of pascal
  1372.                are treated as different if "diffcomm" is true *)
  1373.             if c = '{' then
  1374.                 begin
  1375.                 repeat
  1376.                     c := nextchar;
  1377.                     if diffcomm then
  1378.                         ready := c = '}'
  1379.                     else
  1380.                         ready := ((c = '*') and
  1381.                                 (peekchar = ')'))
  1382.                             or (c = '}')
  1383.                 until ready or eof;
  1384.                 if eof and not ready then
  1385.                     error(eeofcmnt);
  1386.                 if (c = '*') and not eof then
  1387.                     c := nextchar;
  1388.                 c := space
  1389.                 end
  1390.             else if (c = '(') and (peekchar = '*')  then
  1391.                 begin
  1392.                 c := nextchar;
  1393.                 repeat
  1394.                     c := nextchar;
  1395.                     if diffcomm then
  1396.                         ready := (c = '*') and
  1397.                             (peekchar = ')')
  1398.                     else
  1399.                         ready := ((c = '*') and
  1400.                                 (peekchar = ')'))
  1401.                             or (c = '}')
  1402.                 until ready or eof;
  1403.                 if eof and not ready then
  1404.                     error(eeofcmnt);
  1405.                 if (c = '*') and not eof then
  1406.                     c := nextchar;
  1407.                 c := space
  1408.                 end
  1409.         until    (c <> space) and (c <> tab);
  1410.  
  1411.         (* save characters from this token and save line- and column-
  1412.            numbers for errormessages *)
  1413.         lasttok[1] := c;
  1414.         lastchr := 2;
  1415.         lastcol := colno;
  1416.         lastline := lineno;
  1417.  
  1418.         (* map all CHAR control characters onto "badchr" *)
  1419.         if c < okchr then
  1420.             c := badchr;
  1421.  
  1422.         (* decode symbol *)
  1423.         with currsym do
  1424.             if eof then
  1425.             begin
  1426.                 lasttok[1] := '*';
  1427.                 lasttok[2] := 'E';
  1428.                 lasttok[3] := 'O';
  1429.                 lasttok[4] := 'F';
  1430.                 lasttok[5] := '*';
  1431.                 lastchr := 6;
  1432.                 st := seof
  1433.             end
  1434.             else
  1435.             case c of
  1436.  
  1437.  
  1438.             (* CHAR, chars not in Pascal *)
  1439.               '|', '`', '~', '}',
  1440.               bslash, uscore, badchr:
  1441.                 error(ebadchar);
  1442.  
  1443.             (* identifiers or keywords *)
  1444.               'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
  1445.               'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
  1446.               'u', 'v', 'w', 'x', 'y', 'z',
  1447.               'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
  1448.               'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
  1449.               'U', 'V', 'W', 'X', 'Y', 'Z':
  1450.                 begin
  1451.                 (* read token into buffer *)
  1452.                 wb[1] := lowercase(c);
  1453.                 wl := 2;
  1454.                 while (wl < maxtoknlen) and idchar(peekchar) do
  1455.                     begin
  1456.                     wb[wl] := lowercase(nextchar);
  1457.                     wl := wl + 1
  1458.                     end;
  1459.                 if wl >= maxtoknlen then
  1460.                     begin
  1461.                     lasttok[lastchr] := chr(null);
  1462.                     error(elongtokn)
  1463.                     end;
  1464.                 (* terminate token and match *)
  1465.                 wb[wl] := chr(null);
  1466.                 (* check if keyword/identifier *)
  1467.                 st := keywordcheck(wb, wl-1);
  1468.                 if st = sid then
  1469.                     vid := saveid(wb)
  1470.                 end;
  1471.  
  1472.             (* integer or real numbers *)
  1473.               '0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
  1474.                 begin
  1475.                 (* assume integer number, save it in buffer *)
  1476.                 wb[1] := c;
  1477.                 wl := 2;
  1478.                 n := numval(c);
  1479.                 while numchar(peekchar) do
  1480.                     begin
  1481.                     c := nextchar;
  1482.                     n := n * 10 + numval(c);
  1483.                     wb[wl] := c;
  1484.                     wl := wl + 1
  1485.                     end;
  1486.                 st := sinteger;
  1487.                 vint := n;
  1488.                 if realok and (peekchar = '.') then
  1489.                     begin
  1490.                     c := nextchar;
  1491.                     realok := numchar(peekchar);
  1492.                     pushchr := c;
  1493.                     pushed := true
  1494.                     end;
  1495.                 if realok then
  1496.                     begin
  1497.                     if peekchar = '.' then
  1498.                         begin
  1499.                         (* this is a real number *)
  1500.                         st := sreal;
  1501.                         wb[wl] := nextchar;
  1502.                         wl := wl + 1;
  1503.                         while numchar(peekchar) do
  1504.                             begin
  1505.                             wb[wl] := nextchar;
  1506.                             wl := wl + 1
  1507.                             end
  1508.                         end;
  1509.                     c := peekchar;
  1510.                     if (c = 'e') or (c = 'E') then
  1511.                         begin
  1512.                         (* this is a real number *)
  1513.                         st := sreal;
  1514.                         c := nextchar;
  1515.                         wb[wl] := xpnent;
  1516.                         wl := wl + 1;
  1517.                         c := peekchar;
  1518.                         if (c = '-') or (c = '+') then
  1519.                             begin
  1520.                             wb[wl] := nextchar;
  1521.                             wl := wl + 1
  1522.                             end;
  1523.                         while numchar(peekchar) do
  1524.                             begin
  1525.                             wb[wl] := nextchar;
  1526.                             wl := wl + 1
  1527.                             end
  1528.                         end;
  1529.                     if st = sreal then
  1530.                         begin
  1531.                         wb[wl] := chr(null);
  1532.                         vflt := savestr(wb)
  1533.                         end
  1534.                     end
  1535.                 end;
  1536.  
  1537.               '(':
  1538.                 if peekchar = '.' then
  1539.                     begin
  1540.                     (* some compilers on non-ascii systems
  1541.                        use (. for [ and .) for ] *)
  1542.                     c := nextchar;
  1543.                     st := slbrack
  1544.                     end
  1545.                 else
  1546.                     st := slpar;
  1547.               ')':
  1548.                 st := srpar;
  1549.               '[':
  1550.                 st := slbrack;
  1551.               ']':
  1552.                 st := srbrack;
  1553.               '.':
  1554.                 if peekchar = '.' then
  1555.                     begin
  1556.                     c := nextchar;
  1557.                     st := sdotdot
  1558.                     end
  1559.                 else if peekchar = ')' then
  1560.                     begin
  1561.                     c := nextchar;
  1562.                     st := srbrack
  1563.                     end
  1564.                 else
  1565.                     st := sdot;
  1566.               ';':
  1567.                 st := ssemic;
  1568.               ':':
  1569.                 if peekchar = '=' then
  1570.                     begin
  1571.                     c := nextchar;
  1572.                     st := sassign
  1573.                     end
  1574.                 else
  1575.                     st := scolon;
  1576.               ',':
  1577.                 st := scomma;
  1578.               '@',
  1579.               '^':
  1580.                 st := sarrow;
  1581.               '=':
  1582.                 st := seq;
  1583.               '<':
  1584.                 if peekchar = '=' then
  1585.                     begin
  1586.                     c := nextchar;
  1587.                     st := sle
  1588.                     end
  1589.                 else if peekchar = '>' then
  1590.                     begin
  1591.                     c := nextchar;
  1592.                     st := sne
  1593.                     end
  1594.                 else
  1595.                     st := slt;
  1596.               '>':
  1597.                 if peekchar = '=' then
  1598.                     begin
  1599.                     c := nextchar;
  1600.                     st := sge
  1601.                     end
  1602.                 else
  1603.                     st := sgt;
  1604.               '+':
  1605.                 st := splus;
  1606.               '-':
  1607.                 st := sminus;
  1608.               '*':
  1609.                 st := smul;
  1610.               '/':
  1611.                 st := squot;
  1612.               quote:
  1613.                 begin
  1614.                 (* assume the symbol is a literal string *)
  1615.                 wl := 1;
  1616.                 ready := false;
  1617.                 repeat
  1618.                     if eoln then
  1619.                         begin
  1620.                         lasttok[lastchr] := chr(null);
  1621.                         error(ebadstring)
  1622.                         end;
  1623.                     c := nextchar;
  1624.                     if c = quote then
  1625.                         if peekchar = quote then
  1626.                             c := nextchar
  1627.                         else
  1628.                             ready := true;
  1629.                     if c = chr(null) then
  1630.                         begin
  1631.                         if eof then
  1632.                             error(eeofstr);
  1633.                         lasttok[lastchr] := chr(null);
  1634.                         error(enulchr)
  1635.                         end;
  1636.                     if not ready then
  1637.                         begin
  1638.                         wb[wl] := c;
  1639.                         if wl >= maxtoknlen then
  1640.                             begin
  1641.                             lasttok[lastchr] :=
  1642.                                 chr(null);
  1643.                             error(elongstring)
  1644.                             end;
  1645.                         wl := wl + 1;
  1646.                         end
  1647.                 until    ready;
  1648.                 if wl = 2 then
  1649.                     begin
  1650.                     (* only 1 character => not a string *)
  1651.                     st := schar;
  1652.                     vchr := wb[1]
  1653.                     end
  1654.                 else begin
  1655.                     (* > 1 character => its a string *)
  1656.                     wb[wl] := chr(null);
  1657.                     st := sstring;
  1658.                     vstr := savestr(wb)
  1659.                      end
  1660.                 end
  1661.  
  1662.             end;(* case *)
  1663.         if lastchr = 0 then
  1664.             lastchr := 1;
  1665.         lasttok[lastchr] := chr(null)
  1666.     end;    (* nexttoken *)
  1667.  
  1668. begin    (* nextsymbol *)
  1669.     nexttoken(sreal in ss);
  1670.     checksymbol(ss)
  1671. end;    (* nextsymbol *)
  1672.  
  1673. (*    Return a pointer to the node describing the type of tp. This    *)
  1674. (*    function also stores the result in the node for future ref.    *)
  1675. function typeof(tp : treeptr) : treeptr;
  1676.  
  1677. var    tf, tq    : treeptr;
  1678.  
  1679. begin
  1680.     tq := tp;
  1681.     tf := tq^.ttype;
  1682.     (* keep working until a type is found *)
  1683.     while tf = nil do
  1684.         begin
  1685.         case tq^.tt of
  1686.           nchar:
  1687.             tf := typnods[tchar];
  1688.  
  1689.           ninteger:
  1690.             tf := typnods[tinteger];
  1691.  
  1692.           nreal:
  1693.             tf := typnods[treal];
  1694.  
  1695.           nstring:
  1696.             tf := typnods[tstring];
  1697.  
  1698.           nnil:
  1699.             tf := typnods[tnil];
  1700.  
  1701.           nid:
  1702.             begin
  1703.             tq := idup(tq);
  1704.             if tq = nil then
  1705.                 fatal(etree)
  1706.             end;
  1707.  
  1708.           ntype,
  1709.           nvar,
  1710.           nconst,
  1711.           nfield,
  1712.           nvalpar,
  1713.           nvarpar:
  1714.             tq := tq^.tbind;
  1715.  
  1716.           npredef,
  1717.           nptr,
  1718.           nscalar,
  1719.           nrecord,
  1720.           nconfarr,
  1721.           narray,
  1722.           nfileof,
  1723.           nsetof:
  1724.             tf := tq;    (* these nodetypes represent types *)
  1725.  
  1726.           nsubrange:
  1727.             if tq^.tup^.tt = nconfarr then
  1728.                 tf := tq^.tup^.tindtyp
  1729.             else
  1730.                 tf := tq;
  1731.  
  1732.           ncall:
  1733.             begin
  1734.             tf := typeof(tq^.tcall);
  1735.             if tf = typnods[tpoly] then
  1736.                 tf := typeof(tq^.taparm)
  1737.             end;
  1738.  
  1739.           nfunc:
  1740.             tq := tq^.tfuntyp;
  1741.  
  1742.           nparfunc:
  1743.             tq := tq^.tpartyp;
  1744.  
  1745.           nproc,
  1746.           nparproc:
  1747.             tf := typnods[tnone];
  1748.  
  1749.           nvariant,
  1750.           nlabel,
  1751.           npgm,
  1752.           nempty,
  1753.           nbegin,
  1754.           nlabstmt,
  1755.           nassign,
  1756.           npush,
  1757.           npop,
  1758.           nif,
  1759.           nwhile,
  1760.           nrepeat,
  1761.           nfor,
  1762.           ncase,
  1763.           nchoise,
  1764.           ngoto,
  1765.           nwith,
  1766.           nwithvar:
  1767.             fatal(etree);
  1768.  
  1769.           nformat,
  1770.           nrange:
  1771.             tq := tq^.texpl;
  1772.  
  1773.           nplus,
  1774.           nminus,
  1775.           nmul:
  1776.             begin
  1777.             tf := typeof(tq^.texpl);
  1778.             if tf = typnods[tinteger] then
  1779.                 tf := typeof(tq^.texpr)
  1780.             else if tf^.tt = nsetof then
  1781.                 tf := typnods[tset]
  1782.             end;
  1783.  
  1784.           numinus,
  1785.           nuplus:
  1786.             tq := tq^.texps;
  1787.  
  1788.           nmod,
  1789.           ndiv:
  1790.             tf := typnods[tinteger];
  1791.  
  1792.           nquot:
  1793.             tf := typnods[treal];
  1794.  
  1795.           neq,
  1796.           nne,
  1797.           nlt,
  1798.           nle,
  1799.           ngt,
  1800.           nge,
  1801.           nin,
  1802.           nor,
  1803.           nand,
  1804.           nnot:
  1805.             tf := typnods[tboolean];
  1806.  
  1807.           nset:
  1808.             tf := typnods[tset];
  1809.  
  1810.           nselect:
  1811.             tq := tq^.tfield;
  1812.  
  1813.           nderef:
  1814.             begin
  1815.             tq := typeof(tq^.texps);
  1816.             case tq^.tt of
  1817.               nptr:
  1818.                 tq := tq^.tptrid;
  1819.               nfileof:
  1820.                 tq := tq^.tof;
  1821.               npredef:
  1822.                 tf := typnods[tchar]    (* textfile *)
  1823.             end (* case *)
  1824.             end;
  1825.  
  1826.           nindex:
  1827.             begin
  1828.             tq := typeof(tq^.tvariable);
  1829.             if tq^.tt = nconfarr then
  1830.                 tq := tq^.tcelem
  1831.             else if tq = typnods[tstring] then
  1832.                 tf := typnods[tchar]
  1833.             else
  1834.                 tq := tq^.taelem
  1835.             end;
  1836.  
  1837.         end (* case *)
  1838.     end;
  1839.     if tp^.ttype = nil then
  1840.         tp^.ttype := tf;    (* remember type for future reference *)
  1841.     typeof := tf
  1842. end;    (* typeof *)
  1843.  
  1844. (*    Connect all nodes to their fathers.                *)
  1845. procedure linkup(up, tp : treeptr);
  1846.  
  1847. begin
  1848.     while tp <> nil do
  1849.         begin
  1850.         if tp^.tup = nil then
  1851.             begin
  1852.             tp^.tup := up;
  1853.             case tp^.tt of
  1854.               npgm,
  1855.               nfunc,
  1856.               nproc:
  1857.                 begin
  1858.                 linkup(tp, tp^.tsubid);
  1859.                 linkup(tp, tp^.tsubpar);
  1860.                 linkup(tp, tp^.tfuntyp);
  1861.                 linkup(tp, tp^.tsublab);
  1862.                 linkup(tp, tp^.tsubconst);
  1863.                 linkup(tp, tp^.tsubtype);
  1864.                 linkup(tp, tp^.tsubvar);
  1865.                 linkup(tp, tp^.tsubsub);
  1866.                 linkup(tp, tp^.tsubstmt)
  1867.                 end;
  1868.  
  1869.  
  1870.               nvalpar,
  1871.               nvarpar,
  1872.               nconst,
  1873.               ntype,
  1874.               nfield,
  1875.               nvar:
  1876.                 begin
  1877.                 linkup(tp, tp^.tidl);
  1878.                 linkup(tp, tp^.tbind)
  1879.                 end;
  1880.  
  1881.               nparproc,
  1882.               nparfunc:
  1883.                 begin
  1884.                 linkup(tp, tp^.tparid);
  1885.                 linkup(tp, tp^.tparparm);
  1886.                 linkup(tp, tp^.tpartyp)
  1887.                 end;
  1888.  
  1889.               nptr:
  1890.                 linkup(tp, tp^.tptrid);
  1891.               nscalar:
  1892.                 linkup(tp, tp^.tscalid);
  1893.  
  1894.               nsubrange:
  1895.                 begin
  1896.                 linkup(tp, tp^.tlo);
  1897.                 linkup(tp, tp^.thi)
  1898.                 end;
  1899.               nvariant:
  1900.                 begin
  1901.                 linkup(tp, tp^.tselct);
  1902.                 linkup(tp, tp^.tvrnt)
  1903.                 end;
  1904.               nrecord:
  1905.                 begin
  1906.                 linkup(tp, tp^.tflist);
  1907.                 linkup(tp, tp^.tvlist)
  1908.                 end;
  1909.               nconfarr:
  1910.                 begin
  1911.                 linkup(tp, tp^.tcindx);
  1912.                 linkup(tp, tp^.tcelem);
  1913.                 linkup(tp, tp^.tindtyp)
  1914.                 end;
  1915.               narray:
  1916.                 begin
  1917.                 linkup(tp, tp^.taindx);
  1918.                 linkup(tp, tp^.taelem)
  1919.                 end;
  1920.               nfileof,
  1921.               nsetof:
  1922.                 linkup(tp, tp^.tof);
  1923.               nbegin:
  1924.                 linkup(tp, tp^.tbegin);
  1925.               nlabstmt:
  1926.                 begin
  1927.                 linkup(tp, tp^.tlabno);
  1928.                 linkup(tp, tp^.tstmt)
  1929.                 end;
  1930.               nassign:
  1931.                 begin
  1932.                 linkup(tp, tp^.tlhs);
  1933.                 linkup(tp, tp^.trhs)
  1934.                 end;
  1935.               npush,
  1936.               npop:
  1937.                 begin
  1938.                 linkup(tp, tp^.tglob);
  1939.                 linkup(tp, tp^.tloc);
  1940.                 linkup(tp, tp^.ttmp)
  1941.                 end;
  1942.               ncall:
  1943.                 begin
  1944.                 linkup(tp, tp^.tcall);
  1945.                 linkup(tp, tp^.taparm )
  1946.                 end;
  1947.               nif:
  1948.                 begin
  1949.                 linkup(tp, tp^.tifxp);
  1950.                 linkup(tp, tp^.tthen);
  1951.                 linkup(tp, tp^.telse)
  1952.                 end;
  1953.               nwhile:
  1954.                 begin
  1955.                 linkup(tp, tp^.twhixp);
  1956.                 linkup(tp, tp^.twhistmt)
  1957.                 end;
  1958.               nrepeat:
  1959.                 begin
  1960.                 linkup(tp, tp^.treptstmt);
  1961.                 linkup(tp, tp^.treptxp)
  1962.                 end;
  1963.               nfor:
  1964.                 begin
  1965.                 linkup(tp, tp^.tforid);
  1966.                 linkup(tp, tp^.tfrom);
  1967.                 linkup(tp, tp^.tto);
  1968.                 linkup(tp, tp^.tforstmt)
  1969.                 end;
  1970.               ncase:
  1971.                 begin
  1972.                 linkup(tp, tp^.tcasxp);
  1973.                 linkup(tp, tp^.tcaslst);
  1974.                 linkup(tp, tp^.tcasother)
  1975.                 end;
  1976.               nchoise:
  1977.                 begin
  1978.                 linkup(tp, tp^.tchocon);
  1979.                 linkup(tp, tp^.tchostmt)
  1980.                 end;
  1981.               nwith:
  1982.                 begin
  1983.                 linkup(tp, tp^.twithvar);
  1984.                 linkup(tp, tp^.twithstmt)
  1985.                 end;
  1986.               nwithvar:
  1987.                 linkup(tp, tp^.texpw);
  1988.               nindex:
  1989.                 begin
  1990.                 linkup(tp, tp^.tvariable);
  1991.                 linkup(tp, tp^.toffset)
  1992.                 end;
  1993.               nselect:
  1994.                 begin
  1995.                 linkup(tp, tp^.trecord);
  1996.                 linkup(tp, tp^.tfield)
  1997.                 end;
  1998.  
  1999.               ngoto:
  2000.                 linkup(tp, tp^.tlabel);
  2001.  
  2002.               nrange, nformat,
  2003.               nin, neq,
  2004.               nne, nlt, nle,
  2005.               ngt, nge, nor,
  2006.               nplus, nminus,
  2007.               nand, nmul,
  2008.               ndiv, nmod,
  2009.               nquot:
  2010.                 begin
  2011.                 linkup(tp, tp^.texpl);
  2012.                 linkup(tp, tp^.texpr)
  2013.                 end;
  2014.  
  2015.               nderef,
  2016.               nnot, nset,
  2017.               numinus,
  2018.               nuplus:
  2019.                 linkup(tp, tp^.texps);
  2020.  
  2021.               nid,
  2022.               nnil, ninteger,
  2023.               nreal, nchar,
  2024.               nstring, npredef,
  2025.               nlabel, nempty:
  2026.                 (* no op *)
  2027.             end (* case *)
  2028.         end;
  2029.         tp := tp^.tnext
  2030.         end
  2031. end;    (* linkup *)
  2032.  
  2033. (*    Allocate a new symbol node.                    *)
  2034. function mksym(vt : ltypes) : symptr;
  2035.  
  2036. var    mp    : symptr;
  2037.  
  2038. begin
  2039.     new(mp);
  2040.     if mp = nil then
  2041.         error(enew);
  2042.     mp^.lt := vt;
  2043.     mp^.lnext := nil;
  2044.     mp^.lsymdecl := nil;
  2045.     mp^.ldecl := nil;
  2046.     mksym := mp
  2047. end;
  2048.  
  2049. (*    Enter a symbol at current declarationlevel.            *)
  2050. procedure declsym(sp : symptr);
  2051.  
  2052. var    h    : hashtyp;
  2053.  
  2054. begin
  2055.     if sp^.lt in [lpredef, lidentifier, lfield, lforward, lpointer] then
  2056.         h := sp^.lid^.ihash
  2057.     else
  2058.         h := hashmax;
  2059.     sp^.lnext := symtab^.ddecl[h];
  2060.     symtab^.ddecl[h] := sp;
  2061.     sp^.ldecl := symtab
  2062. end;
  2063.  
  2064. (*    Create a node of selected type.                    *)
  2065. function mknode(nt : treetyp) : treeptr;
  2066.  
  2067. var    tp    : treeptr;
  2068.  
  2069. begin
  2070.     tp := nil;
  2071.     case nt of
  2072.       npredef:    new(tp, npredef);
  2073.       npgm:        new(tp, npgm);
  2074.       nfunc:    new(tp, nfunc);
  2075.       nproc:    new(tp, nproc);
  2076.       nlabel:    new(tp, nlabel);
  2077.       nconst:    new(tp, nconst);
  2078.       ntype:    new(tp, ntype);
  2079.       nvar:        new(tp, nvar);
  2080.       nvalpar:    new(tp, nvalpar);
  2081.       nvarpar:    new(tp, nvarpar);
  2082.       nparproc:    new(tp, nparproc);
  2083.       nparfunc:    new(tp, nparfunc);
  2084.       nsubrange:    new(tp, nsubrange);
  2085.       nvariant:    new(tp, nvariant);
  2086.       nfield:    new(tp, nfield);
  2087.       nrecord:    new(tp, nrecord);
  2088.       nconfarr:    new(tp, nconfarr);
  2089.       narray:    new(tp, narray);
  2090.       nfileof:    new(tp, nfileof);
  2091.       nsetof:    new(tp, nsetof);
  2092.       nbegin:    new(tp, nbegin);
  2093.       nptr:        new(tp, nptr);
  2094.       nscalar:    new(tp, nscalar);
  2095.       nif:        new(tp, nif);
  2096.       nwhile:    new(tp, nwhile);
  2097.       nrepeat:    new(tp, nrepeat);
  2098.       nfor:        new(tp, nfor);
  2099.       ncase:    new(tp, ncase);
  2100.       nchoise:    new(tp, nchoise);
  2101.       ngoto:    new(tp, ngoto);
  2102.       nwith:    new(tp, nwith);
  2103.       nwithvar:    new(tp, nwithvar);
  2104.       nempty:    new(tp, nempty);
  2105.       nlabstmt:    new(tp, nlabstmt);
  2106.       nassign:    new(tp, nassign);
  2107.       nformat:    new(tp, nformat);
  2108.       nin:        new(tp, nin);
  2109.       neq:        new(tp, neq);
  2110.       nne:        new(tp, nne);
  2111.       nlt:        new(tp, nlt);
  2112.       nle:        new(tp, nle);
  2113.       ngt:        new(tp, ngt);
  2114.       nge:        new(tp, nge);
  2115.       nor:        new(tp, nor);
  2116.       nplus:    new(tp, nplus);
  2117.       nminus:    new(tp, nminus);
  2118.       nand:        new(tp, nand);
  2119.       nmul:        new(tp, nmul);
  2120.       ndiv:        new(tp, ndiv);
  2121.       nmod:        new(tp, nmod);
  2122.       nquot:    new(tp, nquot);
  2123.       nnot:        new(tp, nnot);
  2124.       numinus:    new(tp, numinus);
  2125.       nuplus:    new(tp, nuplus);
  2126.       nset:        new(tp, nset);
  2127.       nrange:    new(tp, nrange);
  2128.       nindex:    new(tp, nindex);
  2129.       nselect:    new(tp, nselect);
  2130.       nderef:    new(tp, nderef);
  2131.       ncall:    new(tp, ncall);
  2132.       nid:        new(tp, nid);
  2133.       nchar:    new(tp, nchar);
  2134.       ninteger:    new(tp, ninteger);
  2135.       nreal:    new(tp, nreal);
  2136.       nstring:    new(tp, nstring);
  2137.       nnil:        new(tp, nnil);
  2138.       npush:    new(tp, npush);
  2139.       npop:        new(tp, npop);
  2140.       nbreak:    new(tp, nbreak)
  2141.     end;(* case *)
  2142.     if tp = nil then
  2143.         error(enew);
  2144.     tp^.tt := nt;
  2145.     tp^.tnext := nil;
  2146.     tp^.tup := nil;
  2147.     tp^.ttype := nil;
  2148.     mknode := tp
  2149. end;
  2150.  
  2151. (*    Create a node with a literal value.                *)
  2152. function mklit : treeptr;
  2153.  
  2154. var    sp    : symptr;
  2155.     tp    : treeptr;
  2156.  
  2157. begin
  2158.     case currsym.st of
  2159.       sinteger:
  2160.         begin
  2161.         sp := mksym(linteger);
  2162.         sp^.linum := currsym.vint;
  2163.         tp := mknode(ninteger);
  2164.         end;
  2165.       sreal:
  2166.         begin
  2167.         sp := mksym(lreal);
  2168.         sp^.lfloat := currsym.vflt;
  2169.         tp := mknode(nreal);
  2170.         end;
  2171.       schar:
  2172.         begin
  2173.         sp := mksym(lcharacter);
  2174.         sp^.lchar := currsym.vchr;
  2175.         tp := mknode(nchar);
  2176.         end;
  2177.       sstring:
  2178.         begin
  2179.         sp := mksym(lstring);
  2180.         sp^.lstr := currsym.vstr;
  2181.         tp := mknode(nstring);
  2182.         end
  2183.     end;(* case *)
  2184.     tp^.tsym := sp;
  2185.     sp^.lsymdecl := tp;
  2186.     mklit := tp
  2187. end;
  2188.  
  2189. (*    Look up an identifier among declared symbols.            *)
  2190. function lookupid(ip : idptr; fieldok : boolean) : symptr;
  2191.  
  2192. label    999;
  2193.  
  2194. var    sp    : symptr;
  2195.     dp    : declptr;
  2196.     vs    : set of ltypes;
  2197.  
  2198. begin
  2199.     lookupid := nil;
  2200.     if fieldok then
  2201.         vs := [lidentifier, lforward, lpointer, lfield]
  2202.     else
  2203.         vs := [lidentifier, lforward, lpointer];
  2204.     sp := nil;
  2205.  
  2206.     (* pick up symboltable from innermost scope *)
  2207.     dp := symtab;
  2208.     while dp <> nil do
  2209.         begin
  2210.         (* scan linked symbols with same hasvalue *) 
  2211.         sp := dp^.ddecl[ip^.ihash];
  2212.         while sp <> nil do
  2213.             begin
  2214.             (* break out when proper id found *)
  2215.             if (sp^.lt in vs) and (sp^.lid = ip) then
  2216.                 goto 999;
  2217.             sp := sp^.lnext
  2218.             end;
  2219.         (* proceed to enclosing scope *)
  2220.         dp := dp^.dprev
  2221.         end;
  2222. 999:
  2223.     lookupid := sp
  2224. end;
  2225.  
  2226. (*    Look up a label.                        *)
  2227. function lookuplabel(i : integer) : symptr;
  2228.  
  2229. label    999;
  2230.  
  2231. var    sp    : symptr;
  2232.     dp    : declptr;
  2233.  
  2234. begin
  2235.     sp := nil;
  2236.     dp := symtab;
  2237.     while dp <> nil do
  2238.         begin
  2239.         sp := dp^.ddecl[hashmax];
  2240.         while sp <> nil do
  2241.             begin
  2242.             if (sp^.lt in [lforwlab, llabel]) and (sp^.lno = i) then
  2243.                 goto 999;
  2244.             sp := sp^.lnext
  2245.             end;
  2246.         dp := dp^.dprev
  2247.         end;
  2248. 999:
  2249.     lookuplabel := sp
  2250. end;
  2251.  
  2252. (*    Create a new declaration level (a new scope) link declnode to    *)
  2253. (*    previous node.    dp is non-nil when a procedure/function body    *)
  2254. (*    is encountered for which we have seen a forward declaration.     *)
  2255. procedure enterscope(dp : declptr);
  2256.  
  2257. var    h    : hashtyp;
  2258.  
  2259. begin
  2260.     if dp = nil then
  2261.         begin
  2262.         new(dp);
  2263.         for h := 0 to hashmax do
  2264.             dp^.ddecl[h] := nil
  2265.         end;
  2266.     dp^.dprev := symtab;
  2267.     symtab := dp
  2268. end;
  2269.  
  2270. (*    Return current scope (as a pointer to symbol-table).    *)
  2271. function currscope : declptr;
  2272.  
  2273. begin
  2274.     currscope := symtab
  2275. end;
  2276.  
  2277. (*    Drop innermost declaration scope.                *)
  2278. procedure leavescope;
  2279.  
  2280. begin
  2281.     symtab := symtab^.dprev
  2282. end;
  2283.  
  2284. (*    Create a new identifier symbol.                    *)
  2285. function mkid(ip : idptr) : symptr;
  2286.  
  2287. var    sp    : symptr;
  2288.  
  2289. begin
  2290.     sp := mksym(lidentifier);
  2291.     sp^.lid := ip;
  2292.     sp^.lused := false;
  2293.     declsym(sp);
  2294.     ip^.inref := ip^.inref + 1;
  2295.     mkid := sp
  2296. end;
  2297.  
  2298. (*    Check that the current identifier is new then save it in the    *)
  2299. (*    current scope. Create and return a new node representing this    *)
  2300. (*    instance of the identifier.                    *)
  2301. function newid(ip : idptr) : treeptr;
  2302.  
  2303. var    sp    : symptr;
  2304.     tp    : treeptr;
  2305.  
  2306. begin
  2307.     sp := lookupid(ip, false);
  2308.     if sp <> nil then
  2309.         if sp^.ldecl <> symtab then
  2310.             sp := nil;
  2311.     if sp = nil then
  2312.         begin
  2313.         (* new identifier *)
  2314.         tp := mknode(nid);
  2315.         sp := mkid(ip);
  2316.         sp^.lsymdecl := tp;
  2317.         tp^.tsym := sp
  2318.         end
  2319.     else if sp^.lt = lpointer then
  2320.         begin
  2321.         (* previously declared as a pointer type *)
  2322.         tp := mknode(nid);
  2323.         tp^.tsym := sp;
  2324.         sp^.lt := lidentifier;
  2325.         sp^.lsymdecl := tp
  2326.         end
  2327.     else if sp^.lt = lforward then
  2328.         begin
  2329.         (* previously forward declared *)
  2330.         sp^.lt := lidentifier;
  2331.         tp := sp^.lsymdecl
  2332.         end
  2333.     else
  2334.         error(emultdeclid);
  2335.     newid := tp
  2336. end;
  2337.  
  2338. (*    Check that the current identifier is already declared,    *)
  2339. (*    we fail unless l in [lforward, lpointer].        *)
  2340. (*    Create and return a new node referencing it.        *)
  2341. function oldid(ip : idptr; l : ltypes) : treeptr;
  2342.  
  2343. var    sp    : symptr;
  2344.     tp    : treeptr;
  2345.  
  2346. begin
  2347.     sp := lookupid(ip, true);
  2348.     if sp = nil then
  2349.         begin
  2350.         if l in [lforward, lpointer] then
  2351.             begin
  2352.             tp := newid(ip);
  2353.             tp^.tsym^.lt := l
  2354.             end
  2355.         else
  2356.             error(enotdeclid)
  2357.         end
  2358.     else begin
  2359.         sp^.lused := true;
  2360.         tp := mknode(nid);
  2361.         tp^.tsym := sp;
  2362.         if (sp^.lt = lpointer) and (l = lidentifier) then
  2363.             begin
  2364.             sp^.lt := lidentifier;
  2365.             sp^.lsymdecl := tp
  2366.             end
  2367.          end;
  2368.     oldid := tp
  2369. end;
  2370.  
  2371. (*    Look up a field in a record declaration.            *)
  2372. (*    Return nil if field isn't declared in "tp" or its variants.    *)
  2373. function oldfield(tp : treeptr; ip : idptr) : treeptr;
  2374.  
  2375. label    999;
  2376.  
  2377. var    tq, ti,
  2378.     fp    : treeptr;
  2379.  
  2380. begin
  2381.     fp := nil;
  2382.     tq := tp^.tflist;
  2383.     while tq <> nil do
  2384.         begin
  2385.         ti := tq^.tidl;
  2386.         while ti <> nil do
  2387.             begin
  2388.             if ti^.tsym^.lid = ip then
  2389.                 begin
  2390.                 fp := mknode(nid);
  2391.                 fp^.tsym := ti^.tsym;
  2392.                 goto 999
  2393.                 end;
  2394.             ti := ti^.tnext
  2395.             end;
  2396.         tq := tq^.tnext
  2397.         end;
  2398.     tq := tp^.tvlist;
  2399.     while tq <> nil do
  2400.         begin
  2401.         fp := oldfield(tq^.tvrnt, ip);
  2402.         if fp <> nil then
  2403.             tq := nil
  2404.         else
  2405.             tq := tq^.tnext
  2406.         end;
  2407. 999:
  2408.     oldfield := fp
  2409. end;
  2410.  
  2411. (*    This is the main parsing routine. It parses a correct pascal-    *)
  2412. (*    program and builds a parsetree which is left in the global    *)
  2413. (*    variable top.                            *)
  2414. (*    Parsing is done through recursive descent using a set of    *)
  2415. (*    mutually recursive functions.                    *)
  2416. procedure parse;
  2417.  
  2418.     function plabel : treeptr;                forward;
  2419.     function pidlist(l : ltypes) : treeptr;            forward;
  2420.     function pconst : treeptr;                forward;
  2421.     function pconstant(realok : boolean) : treeptr;        forward;
  2422.     function precord(cs : symtyp; dp : declptr) : treeptr;    forward;
  2423.     function ptypedef : treeptr;                forward;
  2424.     function ptype : treeptr;                forward;
  2425.     function pvar : treeptr;                forward;
  2426.     function psubs : treeptr;                forward;
  2427.     function psubpar : treeptr;                forward;
  2428.     function plabstmt : treeptr;                forward;
  2429.     function pstmt : treeptr;                forward;
  2430.     function psimple : treeptr;                forward;
  2431.     function pvariable(varptr : treeptr) : treeptr;        forward;
  2432.     function pexpr(tnp : treeptr) : treeptr;        forward;
  2433.     function pcase : treeptr;                forward;
  2434.     function pif : treeptr;                    forward;
  2435.     function pwhile : treeptr;                forward;
  2436.     function prepeat : treeptr;                forward;
  2437.     function pfor : treeptr;                forward;
  2438.     function pwith : treeptr;                forward;
  2439.     function pgoto : treeptr;                forward;
  2440.     function pbegin(retain : boolean) : treeptr;        forward;
  2441.  
  2442.     (*    Open scope of a record variable.            *)
  2443.     procedure scopeup(tp : treeptr);
  2444.  
  2445.         (*    Scan a record-declaration and add all fields to    *)
  2446.         (*    current scope.                    *)
  2447.         procedure addfields(rp : treeptr);
  2448.  
  2449.         var    fp, ip, vp    : treeptr;
  2450.             sp        : symptr;
  2451.  
  2452.         begin
  2453.             fp := rp^.tflist;
  2454.             while fp <> nil do
  2455.                 begin
  2456.                 ip := fp^.tidl;
  2457.                 while ip <> nil do
  2458.                     begin
  2459.                     sp := mksym(lfield);
  2460.                     sp^.lid := ip^.tsym^.lid;
  2461.                     sp^.lused := false;
  2462.                     sp^.lsymdecl := ip;
  2463.                     declsym(sp);
  2464.                     ip := ip^.tnext
  2465.                     end;
  2466.                 fp := fp^.tnext
  2467.                 end;
  2468.             vp := rp^.tvlist;
  2469.             while vp <> nil do
  2470.                 begin
  2471.                 addfields(vp^.tvrnt);
  2472.                 vp := vp^.tnext
  2473.                 end
  2474.         end;
  2475.     begin
  2476.         addfields(typeof(tp))
  2477.     end;
  2478.  
  2479.     (*    Check that the current label is new then save it in the    *)
  2480.     (*    current scope. Create and return a new node referencing    *)
  2481.     (*    the label.                        *)
  2482.     function newlbl : treeptr;
  2483.  
  2484.     var    sp    : symptr;
  2485.         tp    : treeptr;
  2486.  
  2487.     begin
  2488.         tp := mknode(nlabel);
  2489.         sp := lookuplabel(currsym.vint);
  2490.         if sp <> nil then
  2491.             if sp^.ldecl <> symtab then
  2492.                 sp := nil;
  2493.         if sp = nil then
  2494.             begin
  2495.             sp := mksym(lforwlab);
  2496.             sp^.lno := currsym.vint;
  2497.             sp^.lgo := false;
  2498.             sp^.lsymdecl := tp;
  2499.             declsym(sp)
  2500.             end
  2501.         else
  2502.             error(emultdecllab);
  2503.         tp^.tsym := sp;
  2504.         newlbl := tp
  2505.     end;
  2506.  
  2507.     (*    Check that the current label is already declared.    *)
  2508.     (*    Create and return a new node referencing it.        *)
  2509.     function oldlbl(defpt : boolean) : treeptr;
  2510.  
  2511.     var    sp    : symptr;
  2512.         tp    : treeptr;
  2513.  
  2514.     begin
  2515.         sp := lookuplabel(currsym.vint);
  2516.         if sp = nil then
  2517.             begin
  2518.             prtmsg(enotdecllab);
  2519.             tp := newlbl;
  2520.             sp := tp^.tsym
  2521.             end
  2522.         else begin
  2523.             tp := mknode(nlabel);
  2524.             tp^.tsym := sp
  2525.              end;
  2526.         if defpt then
  2527.             begin
  2528.  
  2529.             if sp^.lt = lforwlab then
  2530.                 sp^.lt := llabel
  2531.             else
  2532.                 error(emuldeflab);
  2533.             end;
  2534.         oldlbl := tp
  2535.     end;
  2536.  
  2537.     (*    Parse declaration and statement-body for prog/subs.    *)
  2538.     procedure pbody(tp : treeptr);
  2539.  
  2540.     var    tq    : treeptr;
  2541.  
  2542.     begin
  2543.         statlvl := statlvl + 1;
  2544.         if currsym.st = slabel then
  2545.             begin
  2546.             tp^.tsublab := plabel;
  2547.             linkup(tp, tp^.tsublab)
  2548.             end
  2549.         else
  2550.             tp^.tsublab := nil;
  2551.         if currsym.st = sconst then
  2552.             begin
  2553.             tp^.tsubconst := pconst;
  2554.             linkup(tp, tp^.tsubconst)
  2555.             end
  2556.         else
  2557.             tp^.tsubconst := nil;
  2558.         if currsym.st = stype then
  2559.             begin
  2560.             tp^.tsubtype := ptype;
  2561.             linkup(tp, tp^.tsubtype)
  2562.             end
  2563.         else
  2564.             tp^.tsubtype := nil;
  2565.         if currsym.st = svar then
  2566.             begin
  2567.             tp^.tsubvar := pvar;
  2568.             linkup(tp, tp^.tsubvar)
  2569.             end
  2570.         else
  2571.             tp^.tsubvar := nil;
  2572.         tp^.tsubsub := nil;
  2573.         tq := nil;
  2574.         while (currsym.st = sproc) or (currsym.st = sfunc) do
  2575.             begin
  2576.             if tq = nil then
  2577.                 begin
  2578.                 tq := psubs;
  2579.                 tp^.tsubsub := tq
  2580.                 end
  2581.             else begin
  2582.                 tq^.tnext := psubs;
  2583.                 tq := tq^.tnext
  2584.                  end
  2585.             end;
  2586.         linkup(tp, tp^.tsubsub);
  2587.         checksymbol([sbegin, seof]);
  2588.         if currsym.st = sbegin then
  2589.             begin
  2590.             tp^.tsubstmt := pbegin(false);
  2591.             linkup(tp, tp^.tsubstmt)
  2592.             end;
  2593.         statlvl := statlvl - 1
  2594.     end;
  2595.  
  2596.     (*    Parse program-declaration.                *)
  2597.     function pprogram : treeptr;
  2598.  
  2599.     var    tp    : treeptr;
  2600.  
  2601.         (*    Parse a program parameter id-list.        *)
  2602.         function pprmlist : treeptr;
  2603.  
  2604.         label    999;
  2605.  
  2606.         var    tp,
  2607.             tq    : treeptr;
  2608.             din,
  2609.             dut,
  2610.             der: idptr;
  2611.  
  2612.         begin
  2613.             tp := nil;
  2614.             din := deftab[dinput]^.tidl^.tsym^.lid;
  2615.             dut := deftab[doutput]^.tidl^.tsym^.lid;
  2616.             der := deftab[derroutput]^.tidl^.tsym^.lid;
  2617.             while (currsym.vid = din) or (currsym.vid = dut)
  2618.             or (currsym.vid = der) do
  2619.                 begin
  2620.                 (* ignore input/output/erroutput as parameters
  2621.                    so that they will be bound to stdin/stdout/
  2622.                    stderr unless declared as variables *)
  2623.                 if currsym.vid = din then
  2624.                     defnams[dinput]^.lused := true
  2625.                 else if currsym.vid = dut then
  2626.                     defnams[doutput]^.lused := true
  2627.                 else
  2628.                     defnams[derroutput]^.lused := true;
  2629.                 nextsymbol([scomma, srpar]);
  2630.                 if currsym.st = srpar then
  2631.                     goto 999;
  2632.                 nextsymbol([sid])
  2633.                 end;
  2634.             tq := newid(currsym.vid);
  2635.             write('/* ');
  2636.             printid(currsym.vid);
  2637.             writeln(' */');
  2638.             tq^.tsym^.lt := lpointer;
  2639.             tp := tq;
  2640.             nextsymbol([scomma, srpar]);
  2641.             while currsym.st = scomma do
  2642.                 begin
  2643.                 nextsymbol([sid]);
  2644.                 if currsym.vid = din then
  2645.                     defnams[dinput]^.lused := true
  2646.                 else if currsym.vid = dut then
  2647.                     defnams[doutput]^.lused := true
  2648.                 else if currsym.vid = der then
  2649.                     defnams[derroutput]^.lused := true
  2650.                 else begin
  2651.                     write('/* ');
  2652.                     printid(currsym.vid);
  2653.                     writeln(' */');
  2654.                     tq^.tnext := newid(currsym.vid);
  2655.                     tq := tq^.tnext;
  2656.                     tq^.tsym^.lt := lpointer;
  2657.                      end;
  2658.                 nextsymbol([scomma, srpar])
  2659.                 end;
  2660.         999:
  2661.             pprmlist := tp
  2662.         end;
  2663.  
  2664.     begin    (* pprogram *)
  2665.         enterscope(nil);
  2666.         tp := mknode(npgm);
  2667.         nextsymbol([sid]);
  2668.         tp^.tstat := statlvl;
  2669.         tp^.tsubid := mknode(nid);
  2670.         tp^.tsubid^.tup := tp;
  2671.         tp^.tsubid^.tsym := mksym(lidentifier);
  2672.         tp^.tsubid^.tsym^.lid := currsym.vid;
  2673.         tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid;
  2674.         linkup(tp, tp^.tsubid);
  2675.         nextsymbol([slpar, ssemic]);
  2676.         if currsym.st = slpar then
  2677.             begin
  2678.             nextsymbol([sid]);
  2679.             tp^.tsubpar := pprmlist;
  2680.             linkup(tp, tp^.tsubpar);
  2681.             nextsymbol([ssemic])
  2682.             end
  2683.         else
  2684.             tp^.tsubpar := nil;
  2685.         nextsymbol([slabel, sconst, stype, svar,
  2686.                         sproc, sfunc, sbegin]);
  2687.         pbody(tp);
  2688.         checksymbol([sdot]);
  2689.         nextsymbol([seof]);
  2690.         tp^.tscope := currscope;
  2691.         leavescope;
  2692.         pprogram := tp
  2693.     end;    (* pprogram *)
  2694.  
  2695.     (*    Parse a module.                *)
  2696.     function pmodule : treeptr;
  2697.  
  2698.     var    tp    : treeptr;
  2699.  
  2700.     begin    (* pmodule *)
  2701.         enterscope(nil);
  2702.         tp := mknode(npgm);
  2703.         tp^.tstat := statlvl;
  2704.         tp^.tsubid := nil;
  2705.         tp^.tsubpar := nil;
  2706.         pbody(tp);
  2707.         checksymbol([ssemic, seof]);
  2708.         if currsym.st = ssemic then
  2709.             nextsymbol([seof]);
  2710.         tp^.tscope := currscope;
  2711.         leavescope;
  2712.         pmodule := tp
  2713.     end;    (* pmodule *)
  2714.  
  2715.  
  2716.     (*    Parse label-clause.                    *)
  2717.     function plabel;
  2718.  
  2719.     var    tp,
  2720.         tq    : treeptr;
  2721.  
  2722.     begin
  2723.         tq := nil;
  2724.         repeat
  2725.             nextsymbol([sinteger]);
  2726.             if tq = nil then
  2727.                 begin
  2728.                 tq := newlbl;
  2729.                 tp := tq
  2730.                 end
  2731.             else begin
  2732.                 tq^.tnext := newlbl;
  2733.                 tq := tq^.tnext;
  2734.                  end;
  2735.             nextsymbol([scomma, ssemic])
  2736.         until    currsym.st = ssemic;
  2737.         nextsymbol([sconst, stype, svar, sbegin, sproc, sfunc]);
  2738.         plabel := tp
  2739.     end;
  2740.  
  2741.     (*    Parse an id-list.                    *)
  2742.     function pidlist;
  2743.  
  2744.     var    tp,
  2745.         tq    : treeptr;
  2746.  
  2747.     begin
  2748.         tq := newid(currsym.vid);
  2749.         tq^.tsym^.lt := l;
  2750.         tp := tq;
  2751.         nextsymbol([scomma, scolon, seq, srpar]);
  2752.         while currsym.st = scomma do
  2753.             begin
  2754.             nextsymbol([sid]);
  2755.             tq^.tnext := newid(currsym.vid);
  2756.             tq := tq^.tnext;
  2757.             tq^.tsym^.lt := l;
  2758.             nextsymbol([scomma, scolon, seq, srpar])
  2759.             end;
  2760.         pidlist := tp
  2761.     end;
  2762.  
  2763.     (*    Parse const-clause.                    *)
  2764.     function pconst;
  2765.  
  2766.     var    tp,
  2767.         tq    : treeptr;
  2768.  
  2769.     begin
  2770.         tq := nil;
  2771.         nextsymbol([sid]);
  2772.         repeat
  2773.             if tq = nil then
  2774.                 begin
  2775.                 tq := mknode(nconst);
  2776.                 tq^.tattr := anone;
  2777.                 tp := tq
  2778.                 end
  2779.             else begin
  2780.                 tq^.tnext := mknode(nconst);
  2781.                 tq := tq^.tnext;
  2782.                 tq^.tattr := anone
  2783.                  end;
  2784.             tq^.tidl := pidlist(lidentifier);
  2785.             checksymbol([seq]);
  2786.             nextsymbol([sid, schar, sstring, sinteger, sreal,
  2787.                         splus, sminus]);
  2788.             tq^.tbind := pconstant(true);
  2789.             nextsymbol([ssemic]);
  2790.             nextsymbol([sid, stype, svar, sbegin,
  2791.                             sfunc, sproc, seof])
  2792.         until    currsym.st <> sid;
  2793.         pconst := tp
  2794.     end;
  2795.  
  2796.     (*    Parse a declared constant or a case-statment const.    *)
  2797.     function pconstant;
  2798.  
  2799.     var    tp,
  2800.         tq    : treeptr;
  2801.         neg    : boolean;
  2802.  
  2803.     begin
  2804.         neg := currsym.st = sminus;
  2805.         if currsym.st in [splus, sminus] then
  2806.             if realok then
  2807.                 nextsymbol([sid, sinteger, sreal])
  2808.             else
  2809.                 nextsymbol([sid, sinteger]);
  2810.         if currsym.st = sid then
  2811.             tp := oldid(currsym.vid, lidentifier)
  2812.         else
  2813.             tp := mklit;
  2814.         if neg then
  2815.             begin
  2816.             tq := mknode(numinus);
  2817.             tq^.texps := tp;
  2818.             tp := tq
  2819.              end;
  2820.         pconstant := tp
  2821.     end;
  2822.  
  2823.     (*    Parse a record (or record-variant) declaration.        *)
  2824.     (*    Cs is the expected closing symbol, dp the scope.    *)
  2825.     function precord;
  2826.  
  2827.     label    999;
  2828.  
  2829.     var    tp,
  2830.         tq,
  2831.         tl,
  2832.         tv    : treeptr;
  2833.         tsym    : lexsym;
  2834.  
  2835.     begin
  2836.         tp := mknode(nrecord);
  2837.         tp^.tflist := nil;
  2838.         tp^.tvlist := nil;
  2839.         tp^.tuid := nil;
  2840.         tp^.trscope := nil;
  2841.         if cs = send then
  2842.             begin
  2843.             enterscope(dp);
  2844.             dp := currscope
  2845.             end;
  2846.         nextsymbol([sid, scase, cs]);
  2847.         tq := nil;
  2848.         while currsym.st = sid do
  2849.             begin
  2850.             if tq = nil then
  2851.                 begin
  2852.                 tq := mknode(nfield);
  2853.                 tq^.tattr := anone;
  2854.                 tp^.tflist := tq
  2855.                 end
  2856.             else begin
  2857.                 tq^.tnext := mknode(nfield);
  2858.                 tq := tq^.tnext;
  2859.                 tq^.tattr := anone
  2860.                  end;
  2861.             tq^.tidl := pidlist(lfield);
  2862.             checksymbol([scolon]);
  2863.             leavescope;
  2864.             tq^.tbind := ptypedef;
  2865.             enterscope(dp);
  2866.             if currsym.st = ssemic then
  2867.                 nextsymbol([sid, scase, cs])
  2868.             end;
  2869.         if currsym.st = scase then
  2870.             begin
  2871.             nextsymbol([sid]);
  2872.             tsym := currsym;
  2873.             nextsymbol([scolon, sof]);
  2874.             if currsym.st = scolon then
  2875.                 begin
  2876.                 tv := newid(tsym.vid);
  2877.                 if tq = nil then
  2878.                     begin
  2879.                     tq := mknode(nfield);
  2880.                     tp^.tflist := tq
  2881.                     end
  2882.                 else begin
  2883.                     tq^.tnext := mknode(nfield);
  2884.                     tq := tq^.tnext
  2885.                      end;
  2886.                 tq^.tidl := tv;
  2887.                 tv^.tsym^.lt := lfield;
  2888.                 nextsymbol([sid]);
  2889.                 leavescope;
  2890.                 tq^.tbind := oldid(currsym.vid, lidentifier);
  2891.                 enterscope(dp);
  2892.                 nextsymbol([sof])
  2893.                 end;
  2894.             tq := nil;
  2895.             repeat
  2896.                 tv := nil;
  2897.                 repeat
  2898.                     nextsymbol([sid, sinteger, schar, splus,
  2899.                              sminus, cs]);
  2900.                     if currsym.st = cs then
  2901.                         goto 999;
  2902.                     if tv = nil then
  2903.                         begin
  2904.                         tv := pconstant(false);
  2905.                         tl := tv
  2906.                         end
  2907.                     else begin
  2908.                         tv^.tnext := pconstant(false);
  2909.                         tv := tv^.tnext
  2910.                          end;
  2911.                     nextsymbol([scolon, scomma])
  2912.                 until currsym.st = scolon;
  2913.                 nextsymbol([slpar]);
  2914.                 if tq = nil then
  2915.                     begin
  2916.                     tq := mknode(nvariant);
  2917.                     tp^.tvlist := tq;
  2918.                     end
  2919.                 else begin
  2920.                     tq^.tnext := mknode(nvariant);
  2921.                     tq := tq^.tnext;
  2922.                      end;
  2923.                 tq^.tselct := tl;
  2924.                 tq^.tvrnt := precord(srpar, dp)
  2925.             until    currsym.st = cs
  2926.             end;
  2927.     999:
  2928.         if cs = send then
  2929.             begin
  2930.             tp^.trscope := dp;
  2931.             leavescope
  2932.             end;
  2933.         nextsymbol([ssemic, send, srpar]);
  2934.         (* currsym is the symbol following record end/rpar,
  2935.             (usually semicolon, sometimes enclosing end/rpar) *)
  2936.         precord := tp
  2937.     end;
  2938.  
  2939.     function ptypedef;
  2940.  
  2941.     var    tp,
  2942.         tq    : treeptr;
  2943.         st    : symtyp;
  2944.         ss    : symset;
  2945.  
  2946.     begin
  2947.         nextsymbol([sid, slpar, sarrow, sinteger, schar, splus, sminus,
  2948.                 spacked, sarray, srecord, sfile, sset]);
  2949.  
  2950.         (* the "packed" keyword is completely ignored *)
  2951.         if currsym.st = spacked then
  2952.             nextsymbol([sarray, srecord, sfile, sset]);
  2953.  
  2954.         ss := [ssemic, send, srpar, scomma, srbrack];
  2955.         case currsym.st of
  2956.           splus,
  2957.           sminus,
  2958.           schar,
  2959.           sinteger,
  2960.           sid:
  2961.             begin
  2962.             st := currsym.st;
  2963.             tp := pconstant(false);
  2964.             if st = sid then
  2965.                 nextsymbol([sdotdot] + ss)
  2966.             else
  2967.                 nextsymbol([sdotdot]);
  2968.             if currsym.st = sdotdot then
  2969.                 begin
  2970.                 nextsymbol([sid, sinteger, schar,
  2971.                                 splus, sminus]);
  2972.                 tq := mknode(nsubrange);
  2973.                 tq^.tlo := tp;
  2974.                 tq^.thi := pconstant(false);
  2975.                 tp := tq;
  2976.                 nextsymbol(ss)
  2977.                 end
  2978.             end;
  2979.           slpar:
  2980.             begin
  2981.             tp := mknode(nscalar);
  2982.             nextsymbol([sid]);
  2983.             tp^.tscalid := pidlist(lidentifier);
  2984.             checksymbol([srpar]);
  2985.             nextsymbol(ss)
  2986.             end;
  2987.           sarrow:
  2988.             begin
  2989.             tp := mknode(nptr);
  2990.             nextsymbol([sid]);
  2991.             tp^.tptrid := oldid(currsym.vid, lpointer);
  2992.             tp^.tptrflag := false;
  2993.             nextsymbol([ssemic, send, srpar])
  2994.             end;
  2995.           sarray:
  2996.             begin
  2997.             nextsymbol([slbrack]);
  2998.             tp := mknode(narray);
  2999.             tp^.taindx := ptypedef;    (* parse subrange ...    *)
  3000.             tq := tp;
  3001.             while currsym.st = scomma do
  3002.                 begin
  3003.                 (* expand:   array [ A , B ] of X
  3004.                    to:   array [ A ] of array [ B ] of X   *)
  3005.                 tq^.taelem := mknode(narray);
  3006.                 tq := tq^.taelem;
  3007.                 tq^.taindx := ptypedef    (* ... again    *)
  3008.                 end;
  3009.             checksymbol([srbrack]);
  3010.             nextsymbol([sof]);
  3011.             tq^.taelem := ptypedef
  3012.             end;
  3013.           srecord:
  3014.             tp := precord(send, nil);
  3015.           sfile,
  3016.           sset:
  3017.             begin
  3018.             if currsym.st = sfile then
  3019.                 tp := mknode(nfileof)
  3020.             else begin
  3021.                 tp := mknode(nsetof);
  3022.                 usesets := true
  3023.                  end;
  3024.             nextsymbol([sof]);
  3025.             tp^.tof := ptypedef
  3026.             end
  3027.         end;
  3028.         (* at this point "currsym" holds the symbol following the type
  3029.            (usually semicolon, sometimes the following end/rpar) *)
  3030.         ptypedef := tp
  3031.     end;
  3032.  
  3033.     (*    Parse type-clause.                    *)
  3034.     function ptype;
  3035.  
  3036.     var    tp,
  3037.         tq    : treeptr;
  3038.  
  3039.     begin
  3040.         tq := nil;
  3041.         nextsymbol([sid]);
  3042.         repeat
  3043.             if tq = nil then
  3044.                 begin
  3045.                 tq := mknode(ntype);
  3046.                 tq^.tattr := anone;
  3047.                 tp := tq
  3048.                 end
  3049.             else begin
  3050.                 tq^.tnext := mknode(ntype);
  3051.                 tq := tq^.tnext;
  3052.                 tq^.tattr := anone
  3053.                  end;
  3054.             tq^.tidl := pidlist(lidentifier);
  3055.             checksymbol([seq]);
  3056.             tq^.tbind := ptypedef;
  3057.             nextsymbol([sid, svar, sbegin, sfunc, sproc, seof])
  3058.         until    currsym.st <> sid;
  3059.         ptype := tp;
  3060.     end;
  3061.  
  3062.     (*    Parse var-clause.                    *)
  3063.     function pvar;
  3064.  
  3065.     var    ti,
  3066.         tp,
  3067.         tq    : treeptr;
  3068.  
  3069.     begin
  3070.         tq := nil;
  3071.         nextsymbol([sid]);
  3072.         repeat
  3073.             if tq = nil then
  3074.                 begin
  3075.                 tq := mknode(nvar);
  3076.                 tq^.tattr := anone;
  3077.                 tp := tq
  3078.                 end
  3079.             else begin
  3080.                 tq^.tnext := mknode(nvar);
  3081.                 tq := tq^.tnext;
  3082.                 tq^.tattr := anone
  3083.                  end;
  3084.  
  3085.             ti := newid(currsym.vid);
  3086.             tq^.tidl := ti;
  3087.             nextsymbol([scomma, scolon]);
  3088.             while currsym.st = scomma do
  3089.                 begin
  3090.                 nextsymbol([sid]);
  3091.                 ti^.tnext := newid(currsym.vid);
  3092.                 ti := ti^.tnext;
  3093.                 nextsymbol([scomma, scolon])
  3094.                 end;
  3095.  
  3096.             tq^.tbind := ptypedef;
  3097.             nextsymbol([sid, sbegin, sfunc, sproc, seof])
  3098.         until    currsym.st <> sid;
  3099.         pvar := tp
  3100.     end;
  3101.  
  3102.     (*    Parse subroutine-declaration.                *)
  3103.     function psubs;
  3104.  
  3105.     var    tp,            (* return value        *)
  3106.         tv, tq    : treeptr;    (* temporary        *)
  3107.         func    : boolean;    (* true for functions    *)
  3108.         colsem    : symtyp;    (* colon/semicolon    *)
  3109.  
  3110.     begin
  3111.         (* parsing function or procedure *)
  3112.         func := currsym.st = sfunc;
  3113.         if func then
  3114.             colsem := scolon
  3115.         else
  3116.             colsem := ssemic;
  3117.  
  3118.         (* parse id, it may already be forward declared *)
  3119.         nextsymbol([sid]);
  3120.         tq := newid(currsym.vid);
  3121.         if tq^.tup = nil then
  3122.            begin
  3123.             enterscope(nil);
  3124.             (* id wasn't previously declared, params possible *)
  3125.             if func then
  3126.                 tp := mknode(nfunc)
  3127.             else
  3128.                 tp := mknode(nproc);
  3129.             tp^.tstat := statlvl;
  3130.             tp^.tsubid := tq;
  3131.             linkup(tp, tq);
  3132.             nextsymbol([slpar, colsem]);
  3133.             if currsym.st = slpar then
  3134.                 begin
  3135.                 tp^.tsubpar := psubpar;
  3136.                 linkup(tp, tp^.tsubpar);
  3137.                 nextsymbol([colsem])
  3138.                 end
  3139.             else
  3140.                 tp^.tsubpar := nil;
  3141.             if func then
  3142.                 begin
  3143.                 (* parse function type *)
  3144.                 nextsymbol([sid]);
  3145.                 tp^.tfuntyp := oldid(currsym.vid, lidentifier);
  3146.                 nextsymbol([ssemic])
  3147.                 end
  3148.             else
  3149.                 tp^.tfuntyp := mknode(nempty);
  3150.             linkup(tp, tp^.tfuntyp);
  3151.             nextsymbol([sextern, sforward,
  3152.                     slabel, sconst, stype, svar,
  3153.                             sproc, sfunc, sbegin]);
  3154.            end
  3155.         else begin
  3156.             (* id was forward declared =>
  3157.                 pick up declarations from parameterlist *)
  3158.             enterscope(tq^.tup^.tscope);
  3159.             if func then
  3160.                 tp := mknode(nfunc)
  3161.             else
  3162.                 tp := mknode(nproc);
  3163.             tp^.tfuntyp := tq^.tup^.tfuntyp;
  3164.             (* steal id and params from forward decl *)
  3165.             tv := tq^.tup^.tsubpar;
  3166.             tp^.tsubpar := tv;
  3167.             while tv <> nil do
  3168.                 begin
  3169.                 tv^.tup := tp;
  3170.                 tv := tv^.tnext
  3171.                 end;
  3172.             tp^.tsubid := tq;
  3173.             tq^.tup := tp;
  3174.             (* id was forward declared =>
  3175.                 no params, no function type, no forward *)
  3176.             nextsymbol([ssemic]);
  3177.             nextsymbol([slabel, sconst, stype, svar,
  3178.                             sproc, sfunc, sbegin]);
  3179.              end;
  3180.         if currsym.st in [sforward, sextern] then
  3181.             begin
  3182.             tp^.tsubid^.tsym^.lt := lforward;
  3183.             nextsymbol([ssemic]);
  3184.             tp^.tsublab := nil;
  3185.             tp^.tsubconst := nil;
  3186.             tp^.tsubtype := nil;
  3187.             tp^.tsubvar := nil;
  3188.             tp^.tsubsub := nil;
  3189.             tp^.tsubstmt := nil
  3190.             end
  3191.         else
  3192.             pbody(tp);
  3193.         nextsymbol([sproc, sfunc, sbegin, seof]);
  3194.         tp^.tscope := currscope;
  3195.         leavescope;
  3196.         psubs := tp
  3197.     end;
  3198.  
  3199.     (*    Parse a conformant array index type.            *)
  3200.     function pconfsub : treeptr;
  3201.  
  3202.     var    tp    : treeptr;
  3203.  
  3204.     begin
  3205.         tp := mknode(nsubrange);
  3206.         nextsymbol([sid]);
  3207.         tp^.tlo := newid(currsym.vid);
  3208.         nextsymbol([sdotdot]);
  3209.         nextsymbol([sid]);
  3210.         tp^.thi := newid(currsym.vid);
  3211.         nextsymbol([scolon]);
  3212.         pconfsub := tp
  3213.     end;
  3214.  
  3215.     (*    Parse a conformant array-declaration.            *)
  3216.     function pconform : treeptr;
  3217.  
  3218.     var    tp, tq    : treeptr;
  3219.  
  3220.     begin
  3221.         nextsymbol([slbrack]);
  3222.         tp := mknode(nconfarr);
  3223.         tp^.tcuid := mkvariable('S');
  3224.         tp^.tcindx := pconfsub;    (* parse subrange ...    *)
  3225.         nextsymbol([sid]);
  3226.         tp^.tindtyp := oldid(currsym.vid, lidentifier);
  3227.         nextsymbol([ssemic, srbrack]);
  3228.         tq := tp;
  3229.         while currsym.st = ssemic do
  3230.             begin
  3231.             error(econfconf); (* what size does tp have *)
  3232.  
  3233.             (* expand:   array [ A ; B ] of X
  3234.                to:   array [ A ] of array [ B ] of X   *)
  3235.             tq^.tcelem := mknode(nconfarr);
  3236.             tq := tq^.tcelem;
  3237.             tq^.tcindx := pconfsub;    (* ... again    *)
  3238.             nextsymbol([sid]);
  3239.             tq^.tindtyp := oldid(currsym.vid, lidentifier);
  3240.             nextsymbol([ssemic, srbrack])
  3241.             end;
  3242.         nextsymbol([sof]);
  3243.         nextsymbol([sid, sarray]);
  3244.         case currsym.st of
  3245.           sid:
  3246.             tq^.tcelem := oldid(currsym.vid, lidentifier);
  3247.           sarray: 
  3248.             begin
  3249.             error(econfconf); (* what size does tp have *)
  3250.  
  3251.             tq^.tcelem := pconform
  3252.             end;
  3253.         end;(* case *)
  3254.         pconform := tp
  3255.     end;
  3256.  
  3257.     (*    Parse subroutine parameter list.            *)
  3258.     function psubpar;
  3259.  
  3260.     var    tp,
  3261.         tq    : treeptr;
  3262.         nt    : treetyp;
  3263.  
  3264.     begin
  3265.         tq := nil;
  3266.         repeat
  3267.             nextsymbol([sid, svar, sfunc, sproc]);
  3268.             case currsym.st of
  3269.               sid:
  3270.                 nt := nvalpar;
  3271.               svar:
  3272.                 nt := nvarpar;
  3273.               sfunc:
  3274.                 nt := nparfunc;
  3275.               sproc:
  3276.                 nt := nparproc;
  3277.             end;
  3278.             if nt <> nvalpar then
  3279.                 nextsymbol([sid]);
  3280.             if tq = nil then
  3281.                 begin
  3282.                 tq := mknode(nt);
  3283.                 tp := tq
  3284.                 end
  3285.             else begin
  3286.                 tq^.tnext := mknode(nt);
  3287.                 tq := tq^.tnext
  3288.                  end;
  3289.             case nt of
  3290.               nvarpar,
  3291.               nvalpar:
  3292.                 begin
  3293.                 tq^.tidl := pidlist(lidentifier);
  3294.                 tq^.tattr := anone;
  3295.                 checksymbol([scolon]);
  3296.                 if nt = nvalpar then
  3297.                     nextsymbol([sid])
  3298.                 else
  3299.                     nextsymbol([sid, sarray]);
  3300.                 case currsym.st of
  3301.                   sid:
  3302.                     tq^.tbind :=
  3303.                         oldid(currsym.vid, lidentifier);
  3304.                   sarray:
  3305.                     tq^.tbind := pconform
  3306.                 end;(* case *)
  3307.                 nextsymbol([srpar, ssemic])
  3308.                 end;
  3309.               nparproc:
  3310.                 begin
  3311.                 tq^.tparid := newid(currsym.vid);
  3312.                 nextsymbol([ssemic, slpar, srpar]);
  3313.                 if currsym.st = slpar then
  3314.                     begin
  3315.                     enterscope(nil);
  3316.                     tq^.tparparm := psubpar;
  3317.                     nextsymbol([ssemic, srpar]);
  3318.                     leavescope
  3319.                     end
  3320.                 else
  3321.                     tq^.tparparm := nil;
  3322.                 tq^.tpartyp := nil
  3323.                 end;
  3324.               nparfunc:
  3325.                 begin
  3326.                 tq^.tparid := newid(currsym.vid);
  3327.                 nextsymbol([scolon, slpar]);
  3328.                 if currsym.st = slpar then
  3329.                     begin
  3330.                     enterscope(nil);
  3331.                     tq^.tparparm := psubpar;
  3332.                     nextsymbol([scolon]);
  3333.                     leavescope
  3334.                     end
  3335.                 else
  3336.                     tq^.tparparm := nil;
  3337.                 nextsymbol([sid]);
  3338.                 tq^.tpartyp := oldid(currsym.vid, lidentifier);
  3339.                 nextsymbol([srpar, ssemic])
  3340.                 end
  3341.             end (* case *)
  3342.         until    currsym.st = srpar;
  3343.         psubpar := tp
  3344.     end;
  3345.  
  3346.     (*    Parse a (possibly labeled) statement.            *)
  3347.     function plabstmt;
  3348.  
  3349.     var    tp    : treeptr;
  3350.  
  3351.     begin
  3352.         nextsymbol([sid, sinteger, sif, swhile, srepeat, sfor, scase,
  3353.                   swith, sbegin, sgoto,
  3354.                     selse, ssemic, send, suntil]);
  3355.         if currsym.st = sinteger then
  3356.             begin
  3357.             tp := mknode(nlabstmt);
  3358.             tp^.tlabno := oldlbl(true);
  3359.             nextsymbol([scolon]);
  3360.             nextsymbol([sid, sif, swhile, srepeat, sfor, scase,
  3361.                   swith, sbegin, sgoto,
  3362.                     selse, ssemic, send, suntil]);
  3363.             tp^.tstmt := pstmt
  3364.             end
  3365.         else
  3366.             tp := pstmt;
  3367.         plabstmt := tp
  3368.     end;
  3369.  
  3370.     (*    Parse an unlabeled statement.                *)
  3371.     function pstmt;
  3372.  
  3373.     var    tp    : treeptr;
  3374.  
  3375.     begin
  3376.         case currsym.st of
  3377.           sid:
  3378.             tp := psimple;
  3379.           sif:
  3380.             tp := pif;
  3381.           swhile:
  3382.             tp := pwhile;
  3383.           srepeat:
  3384.             tp := prepeat;
  3385.           sfor:
  3386.             tp := pfor;
  3387.           scase:
  3388.             tp := pcase;
  3389.           swith:
  3390.             tp := pwith;
  3391.           sbegin:
  3392.             tp := pbegin(true);
  3393.           sgoto:
  3394.             tp := pgoto;
  3395.           send,
  3396.           selse,
  3397.           suntil,
  3398.           ssemic:
  3399.             tp := mknode(nempty);
  3400.         end;
  3401.         pstmt := tp
  3402.     end;
  3403.  
  3404.     procedure flagassigndest(tp : treeptr);
  3405.  
  3406.     begin
  3407.         if tp^.tt in [ nindex, nselect, nderef ] then
  3408.             case tp^.tt of
  3409.               nindex: flagassigndest(tp^.tvariable);
  3410.               nselect: flagassigndest(tp^.trecord);
  3411.               nderef: tp^.tisassigndest := true;
  3412.             end
  3413.     end;
  3414.  
  3415.     (*    Parse an assignment or a procedure call.        *)
  3416.     function psimple;
  3417.  
  3418.     var    tq,
  3419.         tp    : treeptr;
  3420.  
  3421.     begin
  3422.         tp := pvariable(oldid(currsym.vid, lidentifier));
  3423.         if currsym.st = sassign then
  3424.             begin
  3425.             tq := mknode(nassign);
  3426.             flagassigndest(tp);
  3427.             tq^.tlhs := tp;
  3428.             tq^.trhs := pexpr(nil);
  3429.             tp := tq
  3430.             end;
  3431.         psimple := tp
  3432.     end;
  3433.  
  3434.     (*    Parse a varable-reference (or a subroutine-call).    *)
  3435.     function pvariable;
  3436.  
  3437.     var    tp,
  3438.         tq    : treeptr;
  3439.  
  3440.     begin
  3441.         nextsymbol([slpar, slbrack, sdot, sarrow,
  3442.             sassign, ssemic, scomma, scolon, sdotdot,
  3443.             splus, sminus, smul, sdiv, smod, squot,
  3444.             sand, sor, sinn, srpar, srbrack,
  3445.             sle, slt, seq, sge, sgt, sne,
  3446.             send, suntil, sthen, selse, sdo, sdownto, sto, sof]);
  3447.         if currsym.st in [slpar, slbrack, sdot, sarrow] then
  3448.             begin
  3449.             case currsym.st of
  3450.               slpar:
  3451.                 begin
  3452.                 tp := mknode(ncall);
  3453.                 tp^.tcall := varptr;
  3454.                 tq := nil;
  3455.                 repeat
  3456.                     if tq = nil then
  3457.                         begin
  3458.                         tq := pexpr(nil);
  3459.                         tp^.taparm  := tq
  3460.                         end
  3461.                     else begin
  3462.                         tq^.tnext := pexpr(nil);
  3463.                         tq := tq^.tnext
  3464.                          end;
  3465.                 until    currsym.st = srpar
  3466.                 end;
  3467.               slbrack:
  3468.                 begin
  3469.                 tq := varptr;
  3470.                 repeat
  3471.                     tp := mknode(nindex);
  3472.                     tp^.tvariable := tq;
  3473.                     tp^.toffset := pexpr(nil);
  3474.                     tq := tp
  3475.                 until    currsym.st = srbrack
  3476.                 end;
  3477.               sdot:
  3478.                 begin
  3479.                 tp := mknode(nselect);
  3480.                 tp^.trecord := varptr;
  3481.                 nextsymbol([sid]);
  3482.                 tq := typeof(varptr);
  3483.                 enterscope(tq^.trscope);
  3484.                 tp^.tfield := oldid(currsym.vid, lfield);
  3485.                 leavescope
  3486.                 end;
  3487.               sarrow:
  3488.                 begin
  3489.                 tp := mknode(nderef);
  3490.                 tp^.tisassigndest := false;
  3491.                 tp^.texps := varptr
  3492.                 end
  3493.             end;(* case *)
  3494.             tp := pvariable(tp)
  3495.             end
  3496.         else begin
  3497.             tp := varptr;
  3498.             if tp^.tt = nid then
  3499.                 begin
  3500.                 tq := idup(tp);
  3501.                 if tq <> nil then
  3502.                     if tq^.tt in [nfunc, nproc,
  3503.                             nparproc, nparfunc] then
  3504.                         begin
  3505.                         (* subroutine-call without
  3506.                            parameters *)
  3507.                         tp := mknode(ncall);
  3508.                         tp^.tcall := varptr;
  3509.                         tp^.taparm := nil
  3510.                         end
  3511.                 end
  3512.              end;
  3513.         pvariable := tp
  3514.     end;
  3515.  
  3516.     (*    Parse an expression.                    *)
  3517.     function pexpr;
  3518.  
  3519.     var    tp,
  3520.         tq    : treeptr;
  3521.         nt    : treetyp;
  3522.         next    : boolean;
  3523.  
  3524.         function padjust(tu, tr : treeptr) : treeptr;
  3525.         begin
  3526.             if pprio[tu^.tt] >= pprio[tr^.tt] then
  3527.                 begin
  3528.                 if tr^.tt in [nnot, numinus, nuplus,
  3529.                             nset, nderef] then
  3530.                     tr^.texps := padjust(tu, tr^.texps)
  3531.                 else
  3532.                     tr^.texpl := padjust(tu, tr^.texpl);
  3533.                 padjust := tr
  3534.                 end
  3535.             else begin
  3536.                 if tu^.tt in [nnot, numinus, nuplus,
  3537.                             nset, nderef] then
  3538.                     tu^.texps := tr
  3539.                 else
  3540.                     tu^.texpr := tr;
  3541.                 padjust := tu
  3542.                  end
  3543.         end;
  3544.  
  3545.     begin
  3546.         nextsymbol([sid, schar, sinteger, sreal, sstring, snil,
  3547.                 splus, sminus, snot, slpar, slbrack, srbrack]);
  3548.         next := true;
  3549.         case currsym.st of
  3550.           splus:
  3551.             begin
  3552.             tp := mknode(nuplus);
  3553.             tp^.texps := nil;
  3554.             tp := pexpr(tp);
  3555.             next := false
  3556.             end;
  3557.           sminus:
  3558.             begin
  3559.             tp := mknode(numinus);
  3560.             tp^.texps := nil;
  3561.             tp := pexpr(tp);
  3562.             next := false
  3563.             end;
  3564.           snot:
  3565.             begin
  3566.             tp := mknode(nnot);
  3567.             tp^.texps := nil;
  3568.             tp := pexpr(tp);
  3569.             next := false
  3570.             end;
  3571.           schar,
  3572.           sinteger,
  3573.           sreal,
  3574.           sstring:
  3575.             tp := mklit;
  3576.           snil:
  3577.             tp := mknode(nnil);
  3578.           sid:
  3579.             begin
  3580.             tp := pvariable(oldid(currsym.vid, lidentifier));
  3581.             next := false
  3582.             end;
  3583.           slpar:
  3584.             begin
  3585.             tp := mknode(nuplus);
  3586.             tp^.texps := pexpr(nil)
  3587.             end;
  3588.           slbrack:
  3589.             begin
  3590.             usesets := true;
  3591.             tp := mknode(nset);
  3592.             tp^.texps := nil;
  3593.             tq := nil;
  3594.             repeat
  3595.                 if tq = nil then
  3596.                     begin
  3597.                     tq := pexpr(nil);
  3598.                     tp^.texps := tq
  3599.                     end
  3600.                 else begin
  3601.                     tq^.tnext := pexpr(nil);
  3602.                     tq := tq^.tnext
  3603.                      end
  3604.             until    currsym.st = srbrack;
  3605.             end;
  3606.           srbrack:
  3607.             begin
  3608.             tp := mknode(nempty);
  3609.             next := false
  3610.             end
  3611.         end;
  3612.         if next then
  3613.             nextsymbol([
  3614.                 scolon, ssemic, scomma, sdotdot, srpar, srbrack,
  3615.                 sle, slt, seq, sge, sgt, sne,
  3616.                 splus, sminus, smul, sdiv, smod, squot,
  3617.                 sand, sor, sinn,
  3618.                 send, suntil, sthen, selse, sdo, sdownto, sto,
  3619.                 sof, slpar, slbrack]);
  3620.         case currsym.st of
  3621.           sdotdot:
  3622.             nt := nrange;
  3623.           splus:
  3624.             nt := nplus;
  3625.           sminus:
  3626.             nt := nminus;
  3627.           smul:
  3628.             nt := nmul;
  3629.           sdiv:
  3630.             nt := ndiv;
  3631.           smod:
  3632.             nt := nmod;
  3633.           squot:
  3634.             begin
  3635.             defnams[dreal]^.lused := true;
  3636.             nt := nquot;
  3637.             end;
  3638.           sand:
  3639.             nt := nand;
  3640.           sor:
  3641.             nt := nor;
  3642.           sinn:
  3643.             begin
  3644.             nt := nin;
  3645.             usesets := true
  3646.             end;
  3647.           sle:
  3648.             nt := nle;
  3649.           slt:
  3650.             nt := nlt;
  3651.           seq:
  3652.             nt := neq;
  3653.           sge:
  3654.             nt := nge;
  3655.           sgt:
  3656.             nt := ngt;
  3657.           sne:
  3658.             nt := nne;
  3659.           scolon:
  3660.             nt := nformat;
  3661.           sid, schar, sinteger, sreal, sstring, snil,
  3662.           ssemic, scomma, slpar, slbrack, srpar, srbrack,
  3663.           send, suntil, sthen, selse, sdo, sdownto, sto, sof:
  3664.             nt := nnil
  3665.         end;(* case *)
  3666.         if nt in [nin .. nor, nand, nnot] then
  3667.             defnams[dboolean]^.lused := true;
  3668.         if nt <> nnil then
  3669.             begin
  3670.             (* binary operator *)
  3671.             tq := mknode(nt);
  3672.             tq^.texpl := tp;
  3673.             tq^.texpr := nil;
  3674.             tp := pexpr(tq)
  3675.             end;
  3676.  
  3677.         (* this statement yilds proper operator precedence *)
  3678.         if tnp <> nil then
  3679.             tp := padjust(tnp, tp);
  3680.         pexpr := tp
  3681.     end;
  3682.  
  3683.     (*    Parse a case-statement.                    *)
  3684.     function pcase;
  3685.  
  3686.     label    999;
  3687.  
  3688.     var    tp,
  3689.         tq,
  3690.         tv    : treeptr;
  3691.  
  3692.     begin
  3693.         tp := mknode(ncase);
  3694.         tp^.tcasxp := pexpr(nil);
  3695.         checksymbol([sof]);
  3696.         tq := nil;
  3697.         repeat
  3698.             if tq = nil then
  3699.                 begin
  3700.                 tq := mknode(nchoise);
  3701.                 tp^.tcaslst := tq
  3702.                 end
  3703.             else begin
  3704.                 tq^.tnext := mknode(nchoise);
  3705.                 tq := tq^.tnext
  3706.                  end;
  3707.             tq^.tchocon := nil;
  3708.             tq^.tchostmt := nil;
  3709.             tv := nil;
  3710.             repeat
  3711.                 nextsymbol([sid, sinteger, schar,
  3712.                         splus, sminus, send, sother, sother2]);
  3713.                 if currsym.st in [send, sother, sother2] then
  3714.                     goto 999;
  3715.                 if tv = nil then
  3716.                     begin
  3717.                     tv := pconstant(false);
  3718.                     tq^.tchocon := tv
  3719.                     end
  3720.                 else begin
  3721.                     tv^.tnext := pconstant(false);
  3722.                     tv := tv^.tnext
  3723.                      end;
  3724.                 nextsymbol([scomma, scolon])
  3725.             until    currsym.st = scolon;
  3726.             tq^.tchostmt := plabstmt
  3727.         until    currsym.st = send;
  3728.     999:
  3729.         if (currsym.st = sother) or (currsym.st = sother2) then
  3730.             begin
  3731.             (* Note: 'otherwise:' does NOT insist on the colon! *)
  3732.             nextsymbol([scolon, sid, sif, swhile, srepeat, sfor,
  3733.                     scase, swith, sbegin, sgoto,
  3734.                     selse, ssemic, send, suntil]);
  3735.             if currsym.st = scolon then
  3736.                 nextsymbol([sid, sif, swhile, srepeat, sfor,
  3737.                     scase, swith, sbegin, sgoto,
  3738.                     selse, ssemic, send, suntil]);
  3739.             tp^.tcasother := pstmt;
  3740.             if currsym.st = ssemic then
  3741.                     nextsymbol([send])
  3742.             end
  3743.         else begin
  3744.             tp^.tcasother := nil;
  3745.             usecase := true
  3746.              end;
  3747.         nextsymbol([ssemic, send, selse, suntil]);
  3748.         pcase := tp
  3749.     end;
  3750.  
  3751.     (*    Parse an if-statement.                    *)
  3752.     function pif;
  3753.  
  3754.     var    tp    : treeptr;
  3755.  
  3756.     begin
  3757.         tp := mknode(nif);
  3758.         tp^.tifxp := pexpr(nil);
  3759.         checksymbol([sthen]);
  3760.         tp^.tthen := plabstmt;
  3761.         if currsym.st = selse then
  3762.             tp^.telse := plabstmt
  3763.         else
  3764.             tp^.telse := nil;
  3765.         pif := tp;
  3766.     end;
  3767.  
  3768.     (*    Parse a while-statement.                *)
  3769.     function pwhile;
  3770.  
  3771.     var    tp    : treeptr;
  3772.  
  3773.     begin
  3774.         tp := mknode(nwhile);
  3775.         tp^.twhixp := pexpr(nil);
  3776.         checksymbol([sdo]);
  3777.         tp^.twhistmt := plabstmt;
  3778.         pwhile := tp;
  3779.     end;
  3780.  
  3781.     (*    Parse a repeat-statement.                *)
  3782.     function prepeat;
  3783.  
  3784.     var    tp,
  3785.         tq    : treeptr;
  3786.  
  3787.     begin
  3788.         tp := mknode(nrepeat);
  3789.         tq := nil;
  3790.         repeat
  3791.             if tq = nil then
  3792.                 begin
  3793.                 tq := plabstmt;
  3794.                 tp^.treptstmt := tq
  3795.                 end
  3796.             else begin
  3797.                 tq^.tnext := plabstmt;
  3798.                 tq := tq^.tnext
  3799.                  end;
  3800.             checksymbol([ssemic, suntil])
  3801.         until    currsym.st = suntil;
  3802.         tp^.treptxp := pexpr(nil);
  3803.         prepeat := tp
  3804.     end;
  3805.  
  3806.     (*    Parse a for-statement.                    *)
  3807.     function pfor;
  3808.  
  3809.     var    tp    : treeptr;
  3810.  
  3811.     begin
  3812.         tp := mknode(nfor);
  3813.         nextsymbol([sid]);
  3814.         tp^.tforid := oldid(currsym.vid, lidentifier);
  3815.         nextsymbol([sassign]);
  3816.         tp^.tfrom := pexpr(nil);
  3817.         checksymbol([sdownto, sto]);
  3818.         tp^.tincr := currsym.st = sto;
  3819.         tp^.tto := pexpr(nil);
  3820.         checksymbol([sdo]);
  3821.         tp^.tforstmt := plabstmt;
  3822.         pfor := tp
  3823.     end;
  3824.  
  3825.     (*    Parse a with-statement.                    *)
  3826.     function pwith;
  3827.  
  3828.     var    tp,
  3829.         tq    : treeptr;
  3830.  
  3831.     begin
  3832.         tp := mknode(nwith);
  3833.         tq := nil;
  3834.         repeat
  3835.             if tq = nil then
  3836.                 begin
  3837.                 tq := mknode(nwithvar);
  3838.                 tp^.twithvar := tq
  3839.                 end
  3840.             else begin
  3841.                 tq^.tnext := mknode(nwithvar);
  3842.                 tq := tq^.tnext
  3843.                  end;
  3844.             enterscope(nil);
  3845.             tq^.tenv := currscope;
  3846.             tq^.texpw := pexpr(nil);
  3847.             scopeup(tq^.texpw);
  3848.             checksymbol([scomma, sdo])
  3849.         until    currsym.st = sdo;
  3850.         tp^.twithstmt := plabstmt;
  3851.         tq := tp^.twithvar;
  3852.         while tq <> nil do
  3853.             begin
  3854.             leavescope;
  3855.             tq := tq^.tnext
  3856.             end;
  3857.         pwith := tp
  3858.     end;
  3859.  
  3860.     (*    Parse a goto-statement.                    *)
  3861.     function pgoto;
  3862.  
  3863.     var    tp    : treeptr;
  3864.  
  3865.     begin
  3866.         nextsymbol([sinteger]);
  3867.         tp := mknode(ngoto);
  3868.         tp^.tlabel := oldlbl(false);
  3869.         nextsymbol([ssemic, send, suntil, selse]);
  3870.         pgoto := tp
  3871.     end;
  3872.  
  3873.     (*    Parse a begin-statement.                *)
  3874.     function pbegin;
  3875.  
  3876.     var    tp,
  3877.         tq    : treeptr;
  3878.  
  3879.     begin
  3880.         tq := nil;
  3881.         repeat
  3882.             if tq = nil then
  3883.                 begin
  3884.                 tq := plabstmt;
  3885.                 tp := tq
  3886.                 end
  3887.             else begin
  3888.                 tq^.tnext := plabstmt;
  3889.                 tq := tq^.tnext
  3890.                  end
  3891.         until    currsym.st = send;
  3892.         if retain then
  3893.             begin
  3894.             tq := mknode(nbegin);
  3895.             tq^.tbegin := tp;
  3896.             tp := tq
  3897.             end;
  3898.         nextsymbol([send, selse, suntil, sdot, ssemic]);
  3899.         pbegin := tp
  3900.     end;
  3901.  
  3902. begin    (* parse *)
  3903.     nextsymbol([spgm, sconst, stype, svar, sproc, sfunc]);
  3904.     if currsym.st = spgm then
  3905.         top := pprogram
  3906.     else
  3907.         top := pmodule
  3908. end;    (* parse *)
  3909.  
  3910. (*    Compute value for a node (which must be some kind of constant).    *)
  3911. function cvalof(tp : treeptr) : integer;
  3912.  
  3913. var    v    : integer;
  3914.     tq    : treeptr;
  3915.  
  3916. begin
  3917.     case tp^.tt of
  3918.       nuplus:
  3919.         cvalof := cvalof(tp^.texps);
  3920.       numinus:
  3921.         cvalof := - cvalof(tp^.texps);
  3922.       nnot:
  3923.         cvalof := 1 - cvalof(tp^.texps);
  3924.       nid:
  3925.         begin
  3926.         tq := idup(tp);
  3927.         if tq = nil then
  3928.             fatal(etree);
  3929.         tp := tp^.tsym^.lsymdecl;
  3930.         case tq^.tt of
  3931.           nscalar:
  3932.             begin
  3933.             v := 0;
  3934.             tq := tq^.tscalid;
  3935.             while tq <> nil do
  3936.                 if tq = tp then
  3937.                     tq := nil
  3938.                 else begin
  3939.                     v := v + 1;
  3940.                     tq := tq^.tnext
  3941.                      end;
  3942.             cvalof := v
  3943.             end;
  3944.           nconst:
  3945.             cvalof := cvalof(tq^.tbind);
  3946.         end;(* case *)
  3947.         end;
  3948.       ninteger:
  3949.         cvalof := tp^.tsym^.linum;
  3950.       nchar:
  3951.         cvalof := ord(tp^.tsym^.lchar);
  3952.     end (* case *)
  3953. end;    (* cvalof *)
  3954.  
  3955. (*    Compute lower value of subrange or scalar type.            *)
  3956. function clower(tp : treeptr) : integer;
  3957.  
  3958. var    tq    : treeptr;
  3959.  
  3960. begin
  3961.     tq := typeof(tp);
  3962.     if tq^.tt = nscalar then
  3963.         clower := scalbase
  3964.     else if tq^.tt = nsubrange then
  3965.         if tq^.tup^.tt = nconfarr then
  3966.             clower := 0
  3967.         else
  3968.             clower := cvalof(tq^.tlo)
  3969.     else if tq = typnods[tchar] then
  3970.         clower := 0
  3971.     else if tq = typnods[tinteger] then
  3972.         clower := -maxint
  3973.     else
  3974.         fatal(etree)
  3975. end;    (* clower *)
  3976.  
  3977. (*    Compute upper value of subrange or scalar type.            *)
  3978. function cupper(tp : treeptr) : integer;
  3979.  
  3980. var    tq    : treeptr;
  3981.     i    : integer;
  3982.  
  3983. begin
  3984.     tq := typeof(tp);
  3985.     if tq^.tt = nscalar then
  3986.         begin
  3987.         tq := tq^.tscalid;
  3988.         i := scalbase;
  3989.         while tq^.tnext <> nil do
  3990.             begin
  3991.             i := i + 1;
  3992.             tq := tq^.tnext
  3993.             end;
  3994.         cupper := i
  3995.         end
  3996.     else if tq^.tt = nsubrange then
  3997.         if tq^.tup^.tt = nconfarr then
  3998.             fatal(euprconf)
  3999.         else
  4000.             cupper := cvalof(tq^.thi)
  4001.     else if tq = typnods[tchar] then
  4002.         cupper := maxchar
  4003.     else if tq = typnods[tinteger] then
  4004.         cupper := maxint
  4005.     else
  4006.         fatal(etree)
  4007. end;    (* cupper *)
  4008.  
  4009. (*    Compute the number of elements in a subrange.            *)
  4010. function crange(tp : treeptr) : integer;
  4011.  
  4012. begin
  4013.     crange := cupper(tp) - clower(tp) + 1
  4014. end;
  4015.  
  4016. (*    Return number of words uset to store a set.            *)
  4017. function csetwords(i : integer) : integer;
  4018.  
  4019. begin
  4020.     i := (i+(setbits)) div (setbits+1);
  4021.     if i > maxsetrange then
  4022.         error(esetsize);
  4023.     csetwords := i
  4024. end;
  4025.  
  4026. (*    Return number of words uset to store a set.            *)
  4027. function csetsize(tp : treeptr) : integer;
  4028.  
  4029. var    tq    : treeptr;
  4030.     i    : integer;
  4031.  
  4032. begin
  4033.     tq := typeof(tp^.tof);
  4034.     i := clower(tq);
  4035.     (* bits in sets are always numbered from 0, so we (arbitrarily)
  4036.        decide that the base must be in the first 6 words to avoid
  4037.        unnecessary waste of space *)
  4038.     if (i < 0) or (i >= 6 * (setbits+1))  then
  4039.         error(esetbase);
  4040.     csetsize := csetwords(crange(tq)) + 1
  4041. end;
  4042.  
  4043. (*    Determine if tp is declared in the procedure it is used in.    *)
  4044. function islocal(tp : treeptr) : boolean;
  4045.  
  4046. var    tq    : treeptr;
  4047.  
  4048. begin
  4049.     tq := tp^.tsym^.lsymdecl;
  4050.     while not (tq^.tt in [nproc, nfunc, npgm]) do
  4051.         tq := tq^.tup;
  4052.     while not (tp^.tt in [nproc, nfunc, npgm]) do
  4053.         tp := tp^.tup;
  4054.     islocal := tp = tq
  4055. end;
  4056.  
  4057. (*    Perform necessary transformations on tree and identifiers    *)
  4058. (*    before generating code.                        *)
  4059. procedure transform;
  4060.  
  4061.  
  4062.     (*    Rename function when used as a variable.        *)
  4063.     procedure renamf(tp : treeptr);
  4064.  
  4065.     var    ip, iq    : symptr;
  4066.         tq, tv    : treeptr;
  4067.  
  4068.         (*    This procedure recursively descends the tree    *)
  4069.         (*    and replaces function-assignments with variable    *)
  4070.         (*    assignments.                    *)
  4071.         procedure crtnvar(tp : treeptr);
  4072.  
  4073.         begin
  4074.             while tp <> nil do
  4075.                 begin
  4076.                 case tp^.tt of
  4077.                   npgm:
  4078.                     crtnvar(tp^.tsubsub);
  4079.                   nfunc,
  4080.                   nproc:
  4081.                     begin
  4082.                     crtnvar(tp^.tsubsub);
  4083.                     crtnvar(tp^.tsubstmt)
  4084.                     end;
  4085.                   nbegin:
  4086.                     crtnvar(tp^.tbegin);
  4087.                   nif:
  4088.                     begin
  4089.                     crtnvar(tp^.tthen);
  4090.                     crtnvar(tp^.telse)
  4091.                     end;
  4092.                   nwhile:
  4093.                     crtnvar(tp^.twhistmt);
  4094.                   nrepeat:
  4095.                     crtnvar(tp^.treptstmt);
  4096.                   nfor:
  4097.                     crtnvar(tp^.tforstmt);
  4098.                   ncase:
  4099.                     begin
  4100.                     crtnvar(tp^.tcaslst);
  4101.                     crtnvar(tp^.tcasother)
  4102.                     end;
  4103.                   nchoise:
  4104.                     crtnvar(tp^.tchostmt);
  4105.                   nwith:
  4106.                     crtnvar(tp^.twithstmt);
  4107.                   nlabstmt:
  4108.                     crtnvar(tp^.tstmt);
  4109.                   nassign:
  4110.                     begin
  4111.                     (* revoke calls in assignment lhs, (mis-
  4112.                        parsed due to ambiguous syntax) *)
  4113.                     if tp^.tlhs^.tt = ncall then
  4114.                         begin
  4115.                         tp^.tlhs := tp^.tlhs^.tcall;
  4116.                         tp^.tlhs^.tup := tp
  4117.                         end;
  4118.                     (* function name -> variable name *)
  4119.                     tv := tp^.tlhs;
  4120.                     if tv^.tt = nid then
  4121.                         if tv^.tsym = ip then
  4122.                             tv^.tsym := iq
  4123.                     end;
  4124.                   nbreak,
  4125.                   npush,
  4126.                   npop,
  4127.                   ngoto,
  4128.                   nempty,
  4129.                   ncall:
  4130.                     (* no op *)
  4131.                 end;(* case *)
  4132.                 tp := tp^.tnext
  4133.                 end
  4134.         end;
  4135.  
  4136.     begin    (* renamf *)
  4137.         while tp <> nil do
  4138.             begin
  4139.             case tp^.tt of
  4140.               npgm,
  4141.               nproc:
  4142.                 renamf(tp^.tsubsub);
  4143.               nfunc:
  4144.                 begin
  4145.                 (* create a variable to hold return value *)
  4146.                 tq := mknode(nvar);
  4147.                 tq^.tattr := aregister;
  4148.                 tq^.tup := tp;
  4149.                 tq^.tidl := newid(mkvariable('R'));
  4150.                 tq^.tidl^.tup := tq;
  4151.                 tq^.tbind := tp^.tfuntyp;
  4152.                 (* put it FIRST among variables, see esubr() *)
  4153.                 tq^.tnext := tp^.tsubvar;
  4154.                 tp^.tsubvar := tq;
  4155.  
  4156.                 iq := tq^.tidl^.tsym;
  4157.                 ip := tp^.tsubid^.tsym;
  4158.                 crtnvar(tp^.tsubsub);
  4159.                 crtnvar(tp^.tsubstmt);
  4160.                 (* process inner functions *)
  4161.                 renamf(tp^.tsubsub)
  4162.                 end;
  4163.             end;(* case *)
  4164.             tp := tp^.tnext
  4165.             end
  4166.     end;    (* renamf *)
  4167.  
  4168.     (*    This procedure rearranges the tree such that multiple    *)
  4169.     (*    vardeclarations don't have (structured) types attached    *)
  4170.     (*    to them. If such a declararation is found, a new name    *)
  4171.     (*    is created and the type is moved to the type section.    *)
  4172.     procedure extract(tp : treeptr);
  4173.  
  4174.     var    vp    : treeptr;
  4175.  
  4176.         (*    Create a declaration for tp, enter in pp type-    *)
  4177.         (*    list and return an identifier referencing it.    *)
  4178.         function xtrit(tp, pp : treeptr; last : boolean) : treeptr;
  4179.  
  4180.         var    np, rp    : treeptr;
  4181.             ip    : idptr;
  4182.  
  4183.         begin
  4184.             (* create new declaration *)
  4185.             np := mknode(ntype);
  4186.             ip := mkvariable('T');
  4187.             np^.tidl := newid(ip);
  4188.             np^.tidl^.tup := np;
  4189.  
  4190.             (* create substitute id *)
  4191.             rp := oldid(ip, lidentifier);
  4192.             rp^.tup := tp^.tup;
  4193.             rp^.tnext := tp^.tnext;
  4194.  
  4195.             (* steal type description *)
  4196.             np^.tbind := tp;
  4197.             tp^.tup := np;
  4198.             tp^.tnext := nil;
  4199.  
  4200.             (* add new declaration to tree *)
  4201.             np^.tup := pp;
  4202.             if last and (pp^.tsubtype <> nil) then
  4203.                 begin
  4204.                 pp := pp^.tsubtype;
  4205.                 while pp^.tnext <> nil do
  4206.                     pp := pp^.tnext;
  4207.                 pp^.tnext := np
  4208.                 end
  4209.             else begin
  4210.                 np^.tnext := pp^.tsubtype;
  4211.                 pp^.tsubtype := np;
  4212.                 end;
  4213.  
  4214.             xtrit := rp;
  4215.         end;
  4216.  
  4217.         (*    Extract anonymous enumeration types.        *)
  4218.         function xtrenum(tp, pp : treeptr) : treeptr;
  4219.  
  4220.             (*    Name record-types referenced by ptrs.    *)
  4221.             procedure nametype(tp : treeptr);
  4222.  
  4223.             begin
  4224.                 tp := typeof(tp);
  4225.                 if tp^.tt = nrecord then
  4226.                     if tp^.tuid = nil then
  4227.                         tp^.tuid := mkvariable('S');
  4228.             end;
  4229.  
  4230.         begin
  4231.             if tp <> nil then
  4232.                 begin
  4233.                 case tp^.tt of
  4234.                   nfield,
  4235.                   ntype,
  4236.                   nvar:
  4237.                     tp^.tbind :=
  4238.                         xtrenum(tp^.tbind, pp);
  4239.  
  4240.                   nscalar:
  4241.                     if tp^.tup^.tt <> ntype then
  4242.                         tp := xtrit(tp, pp, false);
  4243.  
  4244.                   narray:
  4245.                     begin
  4246.                     tp^.taindx := xtrenum(tp^.taindx, pp);
  4247.                     tp^.taelem := xtrenum(tp^.taelem, pp);
  4248.                     end;
  4249.                   nrecord:
  4250.                     begin
  4251.                     tp^.tflist := xtrenum(tp^.tflist, pp);
  4252.                     tp^.tvlist := xtrenum(tp^.tvlist, pp);
  4253.                     end;
  4254.                   nvariant:
  4255.                     tp^.tvrnt := xtrenum(tp^.tvrnt, pp);
  4256.                   nfileof:
  4257.                     tp^.tof := xtrenum(tp^.tof, pp);
  4258.  
  4259.                   nptr:
  4260.                     nametype(tp^.tptrid);
  4261.  
  4262.                   nid,
  4263.                   nsubrange,
  4264.                   npredef,
  4265.                   nempty,
  4266.                   nsetof:
  4267.                     (* no op *)
  4268.                 end;(* case *)
  4269.                 tp^.tnext := xtrenum(tp^.tnext, pp)
  4270.                 end;
  4271.             xtrenum := tp
  4272.         end;
  4273.  
  4274.     begin    (* extract *)
  4275.         while tp <> nil do
  4276.             begin
  4277.             (* tp points to a program/procedure/function node *)
  4278.             tp^.tsubtype := xtrenum(tp^.tsubtype, tp);
  4279.             tp^.tsubvar := xtrenum(tp^.tsubvar, tp);
  4280.             vp := tp^.tsubvar;
  4281.             while vp <> nil do
  4282.                 begin
  4283.                 (* variables of structured unnamed types *)
  4284.                 if vp^.tbind^.tt in [nscalar, narray,
  4285.                             nrecord, nfileof] then
  4286.                     vp^.tbind := xtrit(vp^.tbind, tp, true);
  4287.                 vp := vp^.tnext
  4288.                 end;
  4289.             extract(tp^.tsubsub);
  4290.             tp := tp^.tnext
  4291.             end
  4292.     end;    (* extract *)
  4293.  
  4294.     (*    This procedure moves all local constants and types    *)
  4295.     (*    used in nested procedures to the outermost declaration    *)
  4296.     (*    level so that nested procedures may be extracted.    *)
  4297.     procedure global(tp, dp : treeptr; depend : boolean);
  4298.  
  4299.     label    555;
  4300.  
  4301.     var    ip    : treeptr;
  4302.         dep    : boolean;
  4303.  
  4304.         (*    Mark all declared identifiers as unused.    *)
  4305.         procedure markdecl(xp : treeptr);
  4306.  
  4307.         begin
  4308.             while xp <> nil do
  4309.                 begin
  4310.                 case xp^.tt of
  4311.                   nid:
  4312.                     xp^.tsym^.lused := false;
  4313.                   nconst:
  4314.                     markdecl(xp^.tidl);
  4315.                   ntype,
  4316.                   nvar,
  4317.                   nvalpar,
  4318.                   nvarpar,
  4319.                   nfield:
  4320.                     begin
  4321.                     markdecl(xp^.tidl);
  4322.                     if xp^.tbind^.tt <> nid then
  4323.                         markdecl(xp^.tbind)
  4324.                     end;
  4325.                   nscalar:
  4326.                     markdecl(xp^.tscalid);
  4327.                   nrecord:
  4328.                     begin
  4329.                     markdecl(xp^.tflist);
  4330.                     markdecl(xp^.tvlist)
  4331.                     end;
  4332.                   nvariant:
  4333.                     markdecl(xp^.tvrnt);
  4334.                   nconfarr:
  4335.                     if xp^.tcelem^.tt <> nid then
  4336.                         markdecl(xp^.tcelem);
  4337.                   narray:
  4338.                     if xp^.taelem^.tt <> nid then
  4339.                         markdecl(xp^.taelem);
  4340.                   nsetof,
  4341.                   nfileof:
  4342.                     if xp^.tof^.tt <> nid then
  4343.                         markdecl(xp^.tof);
  4344.                   nparproc,
  4345.                   nparfunc:
  4346.                     markdecl(xp^.tparid);
  4347.                   nptr,
  4348.                   nsubrange:
  4349.                     (* no op *)
  4350.                 end;(* case *)
  4351.                 xp := xp^.tnext
  4352.                 end
  4353.         end;    (* markdecl *)
  4354.  
  4355.         (*    Move all marked declarations to global scope.    *)
  4356.         function movedecl(tp : treeptr) : treeptr;
  4357.  
  4358.         var    ip, np    : treeptr;
  4359.             sp    : symptr;
  4360.             move    : boolean;
  4361.  
  4362.         begin
  4363.             if tp <> nil then
  4364.                 begin
  4365.                 move := false;
  4366.                 case tp^.tt of
  4367.                   nconst,
  4368.                   ntype:
  4369.                     ip := tp^.tidl
  4370.                 end;(* case *)
  4371.                 while ip <> nil do
  4372.                     begin
  4373.                     if ip^.tsym^.lused then
  4374.                         begin
  4375.                         move := true;
  4376.                         sp := ip^.tsym;
  4377.                         if sp^.lid^.inref > 1 then
  4378.                             sp^.lid :=
  4379.                             mkrename('M', sp^.lid);
  4380.                         ip := nil
  4381.                         end
  4382.                     else
  4383.                         ip := ip^.tnext
  4384.                     end;
  4385.                 if move then
  4386.                     begin
  4387.                     np := tp^.tnext;
  4388.                     tp^.tnext := nil;
  4389.                     ip := tp;
  4390.                     while ip^.tt <> npgm do
  4391.                         ip := ip^.tup;
  4392.                     tp^.tup := ip;
  4393.                     case tp^.tt of
  4394.                       nconst:
  4395.                         begin
  4396.                         if ip^.tsubconst = nil then
  4397.                             ip^.tsubconst := tp
  4398.                         else begin
  4399.                             ip := ip^.tsubconst;
  4400.                             while ip^.tnext <> nil
  4401.                                 do ip := ip^.tnext;
  4402.                             ip^.tnext := tp
  4403.                              end
  4404.                         end;
  4405.                       ntype:
  4406.                         begin
  4407.                         if ip^.tsubtype = nil then
  4408.                             ip^.tsubtype := tp
  4409.                         else begin
  4410.                             ip := ip^.tsubtype;
  4411.                             while ip^.tnext <> nil
  4412.                                 do ip := ip^.tnext;
  4413.                             ip^.tnext := tp
  4414.                              end
  4415.                         end
  4416.                     end;(* case *)
  4417.                     (* tp is moved, drop it and process
  4418.                        remainder of declarationlist *)
  4419.                     tp := movedecl(np)
  4420.                     end
  4421.                 else
  4422.                     tp^.tnext := movedecl(tp^.tnext)
  4423.                 end;
  4424.             movedecl := tp
  4425.         end;    (* movedecl *)
  4426.  
  4427.         (*    This procedure lifts out variables/parameters    *)
  4428.         (*    used in nested procedures/functions.        *)
  4429.         procedure movevars(tp, vp : treeptr);
  4430.  
  4431.         label    555;
  4432.  
  4433.         var    ep, dp, np    : treeptr;
  4434.             ip        : idptr;
  4435.             sp        : symptr;
  4436.  
  4437.             (*    Move a variable    declaration to global    *)
  4438.             (*    var declaration lists.            *)
  4439.             procedure moveglob(tp, dp : treeptr);
  4440.  
  4441.             begin
  4442.                 while tp^.tt <> npgm do
  4443.                     tp := tp^.tup;
  4444.                 dp^.tup := tp;
  4445.                 dp^.tnext := tp^.tsubvar;
  4446.                 tp^.tsubvar := dp
  4447.             end;
  4448.  
  4449.             (*    Create nodes for saving a global    *)
  4450.             (*    pointer variable.            *)
  4451.             function stackop(decl, glob, loc : treeptr) : treeptr;
  4452.  
  4453.             var    op, ip, dp, tp    : treeptr;
  4454.  
  4455.             begin
  4456.                 (* create a new variable to hold old value
  4457.                    of the global variable during a call *)
  4458.                 ip := newid(mkvariable('F'));
  4459.                 case vp^.tt of
  4460.                   nvarpar,
  4461.                   nvalpar,
  4462.                   nvar:
  4463.                     begin
  4464.                     dp := mknode(nvarpar);
  4465.                     dp^.tattr := areference;
  4466.                     dp^.tidl := ip;
  4467.                     (* use same type as the global var *)
  4468.                     dp^.tbind := decl^.tbind
  4469.                     end;
  4470.                   nparproc,
  4471.                   nparfunc:
  4472.                     begin
  4473.                     dp := mknode(vp^.tt);
  4474.                     dp^.tparid := ip;
  4475.                     dp^.tparparm := nil;
  4476.                     dp^.tpartyp := vp^.tpartyp
  4477.                     end
  4478.                 end;(* case *)
  4479.                 ip^.tup := dp;
  4480.  
  4481.                 (* add variable to declarationlists *)
  4482.                 tp := decl;
  4483.                 while not (tp^.tt in [nproc, nfunc, npgm]) do
  4484.                     tp := tp^.tup;
  4485.                 dp^.tup := tp;
  4486.                 if tp^.tsubvar = nil then
  4487.                     tp^.tsubvar := dp
  4488.                 else begin
  4489.                     tp := tp^.tsubvar;
  4490.                     while tp^.tnext <> nil do
  4491.                         tp := tp^.tnext;
  4492.                     tp^.tnext := dp
  4493.                      end;
  4494.                 dp^.tnext := nil;
  4495.  
  4496.                 (* create an assignment saving value *)
  4497.                 op := mknode(npush);
  4498.                 op^.tglob := glob;
  4499.                 op^.tloc := loc;
  4500.                 op^.ttmp := ip;
  4501.                 stackop := op
  4502.             end;
  4503.  
  4504.             (*    Take a "push" node, create "pop" node    *)
  4505.             (*    and add both to tree.            *)
  4506.             procedure addcode(tp, push : treeptr);
  4507.  
  4508.             var    pop    : treeptr;
  4509.  
  4510.             begin
  4511.                 pop := mknode(npop);
  4512.                 (* share variables with "push"-node *)
  4513.                 pop^.tglob := push^.tglob;
  4514.                 pop^.ttmp := push^.ttmp;
  4515.                 pop^.tloc := nil;
  4516.  
  4517.                 (* add npush to head of statement list *)
  4518.                 push^.tnext := tp^.tsubstmt;
  4519.                 tp^.tsubstmt := push;
  4520.                 push^.tup := tp;
  4521.  
  4522.                 (* add npop to end of statement list *)
  4523.                 while push^.tnext <> nil do
  4524.                     push := push^.tnext;
  4525.                 push^.tnext := pop;
  4526.                 pop^.tup := tp
  4527.             end;
  4528.  
  4529.         begin    (* movevars *)
  4530.             while vp <> nil do
  4531.                 begin
  4532.                 case vp^.tt of
  4533.                   nvar,
  4534.                   nvalpar,
  4535.                   nvarpar:
  4536.                     dp := vp^.tidl;
  4537.                   nparproc,
  4538.                   nparfunc:
  4539.                     begin
  4540.                     dp := vp^.tparid;
  4541.                     if dp^.tsym^.lused then
  4542.                         begin
  4543.                         (* create a var declaration *)
  4544.                         ep := mknode(vp^.tt);
  4545.                         ep^.tparparm := nil;
  4546.                         ep^.tpartyp := vp^.tpartyp;
  4547.                         np := newid(mkrename('G',
  4548.                                 dp^.tsym^.lid));
  4549.                         ep^.tparid := np;
  4550.                         np^.tup := ep;
  4551.                         (* swap id's and symbols *)
  4552.                         sp := np^.tsym;
  4553.                         ip := sp^.lid;
  4554.                         np^.tsym^.lid := dp^.tsym^.lid;
  4555.                         dp^.tsym^.lid := ip;
  4556.                         np^.tsym := dp^.tsym;
  4557.                         dp^.tsym := sp;
  4558.                         np^.tsym^.lsymdecl := np;
  4559.                         dp^.tsym^.lsymdecl := dp;
  4560.                         (* make declaration global *)
  4561.                         moveglob(tp, ep);
  4562.                         (* add save/restore-code *)
  4563.                         addcode(tp, stackop(vp, np, dp))
  4564.                         end;
  4565.                     goto 555
  4566.                     end
  4567.                 end;(* case *)
  4568.                 while dp <> nil do
  4569.                     begin
  4570.                     if dp^.tsym^.lused then
  4571.                         begin
  4572.                         (* create a varpar declaration,
  4573.                            (nvarpar will cause emit to
  4574.                            treat the new identifier
  4575.                            as a pointer) *)
  4576.                         ep := mknode(nvarpar);
  4577.                         ep^.tattr := areference;
  4578.                         np := newid(mkrename('G',
  4579.                                 dp^.tsym^.lid));
  4580.                         ep^.tidl := np;
  4581.                         np^.tup := ep;
  4582.                         ep^.tbind := vp^.tbind;
  4583.                         if ep^.tbind^.tt = nid then
  4584.                             ep^.tbind^.tsym^.lused
  4585.                                 := true;
  4586.                         (* swap id's and symbols *)
  4587.                         sp := np^.tsym;
  4588.                         ip := sp^.lid;
  4589.                         np^.tsym^.lid := dp^.tsym^.lid;
  4590.                         dp^.tsym^.lid := ip;
  4591.                         np^.tsym := dp^.tsym;
  4592.                         dp^.tsym := sp;
  4593.                         np^.tsym^.lsymdecl := np;
  4594.                         dp^.tsym^.lsymdecl := dp;
  4595.                         (* note that dp is referenced *)
  4596.                         dp^.tup^.tattr := aextern;
  4597.                         (* make declaration global *)
  4598.                         moveglob(tp, ep);
  4599.                         (* add save/restore-code *)
  4600.                         addcode(tp, stackop(vp, np, dp))
  4601.                         end;
  4602.                     dp := dp^.tnext
  4603.                     end;
  4604.             555:
  4605.                 vp := vp^.tnext
  4606.                 end
  4607.         end;    (* movevars *)
  4608.  
  4609.         (*    Break out a local variable and set the register    *)
  4610.         (*    attribute.                    *)
  4611.         procedure registervar(tp : treeptr);
  4612.  
  4613.         var    vp, xp    : treeptr;
  4614.  
  4615.         begin
  4616.             vp := idup(tp);
  4617.             tp := tp^.tsym^.lsymdecl;
  4618.             (* vp points to nvar node *)
  4619.             if (vp^.tidl <> tp) or (tp^.tnext <> nil) then
  4620.                 begin
  4621.                 (* tp is not alone in list of identifiers,
  4622.                    create a new nvar-node and hook up tp *)
  4623.                 xp := mknode(nvar);
  4624.                 xp^.tattr := anone;
  4625.                 xp^.tidl := tp;
  4626.                 tp^.tup := xp;
  4627.                 (* enter new nvar node among declarations *)
  4628.                 xp^.tup := vp^.tup;
  4629.                 xp^.tbind := vp^.tbind; (* borrow type *)
  4630.                 xp^.tnext := vp^.tnext;
  4631.                 vp^.tnext := xp;
  4632.                 (* break tp out of list of identifiers *)
  4633.                 if vp^.tidl = tp then
  4634.                     vp^.tidl := tp^.tnext
  4635.                 else begin
  4636.                     vp := vp^.tidl;
  4637.                     while vp^.tnext <> tp do
  4638.                         vp := vp^.tnext;
  4639.                     vp^.tnext := tp^.tnext
  4640.                      end;
  4641.                 tp^.tnext := nil
  4642.                 end;
  4643.             (* tp is alone in this declaration, set attribute *)
  4644.             if tp^.tup^.tattr = anone then
  4645.                 tp^.tup^.tattr := aregister
  4646.         end;    (* registervar *)
  4647.  
  4648.         (*    Check static declarationlevel for a label    *)
  4649.         (*    used in a non-local goto.            *)
  4650.         procedure cklevel(tp : treeptr);
  4651.  
  4652.         begin
  4653.             tp := tp^.tsym^.lsymdecl;
  4654.             while not(tp^.tt in [npgm, nproc, nfunc]) do
  4655.                 tp := tp^.tup;
  4656.             if tp^.tstat > maxlevel then
  4657.                 maxlevel := tp^.tstat
  4658.         end;
  4659.  
  4660.     begin    (* global *)
  4661.         while tp <> nil do
  4662.             begin
  4663.             case tp^.tt of
  4664.               nproc,
  4665.               nfunc:
  4666.                 begin
  4667.                 (* procid/parameters/const/type/var not used *)
  4668.                 markdecl(tp^.tsubid);
  4669.                 markdecl(tp^.tsubpar);
  4670.                 markdecl(tp^.tsubconst);
  4671.                 markdecl(tp^.tsubtype);
  4672.                 markdecl(tp^.tsubvar);
  4673.  
  4674.                 (* mark those used in nested subroutines *)
  4675.                 global(tp^.tsubsub, tp, false);
  4676.                 global(tp^.tsubvar, tp, false);
  4677.                 global(tp^.tsubtype, tp, false);
  4678.  
  4679.                 (* move out variables used in inner scope *)
  4680.                 movevars(tp, tp^.tsubpar);
  4681.                 movevars(tp, tp^.tsubvar);
  4682.                 (* move out const/type used in inner scope *)
  4683.                 tp^.tsubtype := movedecl(tp^.tsubtype);
  4684.                 tp^.tsubconst := movedecl(tp^.tsubconst);
  4685.  
  4686.                 (* mark identifiers used in this subroutine *)
  4687.                 global(tp^.tsubstmt, tp, true);
  4688.                 global(tp^.tsubpar, tp, false);
  4689.                 global(tp^.tsubvar, tp, false);
  4690.                 global(tp^.tsubtype, tp, false);
  4691.                 global(tp^.tfuntyp, tp, false);
  4692.                 end;
  4693.  
  4694.               npgm:
  4695.                 begin
  4696.                 markdecl(tp^.tsubconst);
  4697.                 markdecl(tp^.tsubtype);
  4698.                 markdecl(tp^.tsubvar);
  4699.                 global(tp^.tsubsub, tp, false);
  4700.                 global(tp^.tsubstmt, tp, true)
  4701.                 end;
  4702.  
  4703.               nconst,
  4704.               ntype,
  4705.               nvar,
  4706.               nfield,
  4707.               nvalpar,
  4708.               nvarpar:
  4709.                 begin
  4710.                 ip := tp^.tidl;
  4711.                 dep := depend;
  4712.                 while (ip <> nil) and not dep do
  4713.                     begin
  4714.                     (* for all used identifiers, propagate
  4715.                        the use to their bindings *)
  4716.                     if ip^.tsym^.lused then
  4717.                         dep := true;
  4718.                     ip := ip^.tnext
  4719.                     end;
  4720.                 global(tp^.tbind, dp, dep);
  4721.                 end;
  4722.               nparproc,
  4723.               nparfunc:
  4724.                 begin
  4725.                 global(tp^.tparparm, dp, depend);
  4726.                 global(tp^.tpartyp, dp, depend)
  4727.                 end;
  4728.               nsubrange:
  4729.                 begin
  4730.                 global(tp^.tlo, dp, depend);
  4731.                 global(tp^.thi, dp, depend)
  4732.                 end;
  4733.               nvariant:
  4734.                 begin
  4735.                 global(tp^.tselct, dp, depend);
  4736.                 global(tp^.tvrnt, dp, depend)
  4737.                 end;
  4738.               nrecord:
  4739.                 begin
  4740.                 global(tp^.tflist, dp, depend);
  4741.                 global(tp^.tvlist, dp, depend)
  4742.                 end;
  4743.               nconfarr:
  4744.                 begin
  4745.                 global(tp^.tcindx, dp, depend);
  4746.                 global(tp^.tcelem, dp, depend)
  4747.                 end;
  4748.               narray:
  4749.                 begin
  4750.                 global(tp^.taindx, dp, depend);
  4751.                 global(tp^.taelem, dp, depend)
  4752.                 end;
  4753.               nfileof,
  4754.               nsetof:
  4755.                 global(tp^.tof, dp, depend);
  4756.               nptr:
  4757.                 global(tp^.tptrid, dp, depend);
  4758.               nscalar:
  4759.                 global(tp^.tscalid, dp, depend);
  4760.               nbegin:
  4761.                 global(tp^.tbegin, dp, depend);
  4762.               nif:
  4763.                 begin
  4764.                 global(tp^.tifxp, dp, depend);
  4765.                 global(tp^.tthen, dp, depend);
  4766.                 global(tp^.telse, dp, depend)
  4767.                 end;
  4768.               nwhile:
  4769.                 begin
  4770.                 global(tp^.twhixp, dp, depend);
  4771.                 global(tp^.twhistmt, dp, depend)
  4772.                 end;
  4773.               nrepeat:
  4774.                 begin
  4775.                 global(tp^.treptstmt, dp, depend);
  4776.                 global(tp^.treptxp, dp, depend)
  4777.                 end;
  4778.               nfor:
  4779.                 begin
  4780.                 ip := idup(tp^.tforid);
  4781.                 if ip^.tup^.tt in [nproc, nfunc] then
  4782.                     registervar(tp^.tforid);
  4783.                 global(tp^.tforid, dp, depend);
  4784.                 global(tp^.tfrom, dp, depend);
  4785.                 global(tp^.tto, dp, depend);
  4786.                 global(tp^.tforstmt, dp, depend)
  4787.                 end;
  4788.               ncase:
  4789.                 begin
  4790.                 global(tp^.tcasxp, dp, depend);
  4791.                 global(tp^.tcaslst, dp, depend);
  4792.                 global(tp^.tcasother, dp, depend)
  4793.                 end;
  4794.               nchoise:
  4795.                 begin
  4796.                 global(tp^.tchocon, dp, depend);
  4797.                 global(tp^.tchostmt, dp, depend);
  4798.                 end;
  4799.               nwith:
  4800.                 begin
  4801.                 global(tp^.twithvar, dp, depend);
  4802.                 global(tp^.twithstmt, dp, depend)
  4803.                 end;
  4804.               nwithvar:
  4805.                 begin
  4806.                 ip := typeof(tp^.texpw);
  4807.                 if ip^.tuid = nil then
  4808.                     ip^.tuid := mkvariable('S');
  4809.                 global(tp^.texpw, dp, depend);
  4810.                 end;
  4811.               nlabstmt:
  4812.                 global(tp^.tstmt, dp, depend);
  4813.               neq, nne, nlt, nle, ngt, nge:
  4814.                 begin
  4815.                 global(tp^.texpl, dp, depend);
  4816.                 global(tp^.texpr, dp, depend);
  4817.                 ip := typeof(tp^.texpl);
  4818.                 if (ip = typnods[tstring]) or
  4819.                             (ip^.tt = narray) then
  4820.                     usecomp := true;
  4821.                 ip := typeof(tp^.texpr);
  4822.                 if (ip = typnods[tstring]) or
  4823.                             (ip^.tt = narray) then
  4824.                     usecomp := true
  4825.                 end;
  4826.               nin, nor, nplus, nminus,
  4827.               nand, nmul, ndiv, nmod, nquot,
  4828.               nformat, nrange:
  4829.                 begin
  4830.                 global(tp^.texpl, dp, depend);
  4831.                 global(tp^.texpr, dp, depend)
  4832.                 end;
  4833.  
  4834.               nassign:
  4835.                 begin
  4836.                 global(tp^.tlhs, dp, depend);
  4837.                 global(tp^.trhs, dp, depend)
  4838.                 end;
  4839.  
  4840.               nnot,
  4841.               numinus,
  4842.               nuplus,
  4843.               nderef:
  4844.                 global(tp^.texps, dp, depend);
  4845.               nset:
  4846.                 global(tp^.texps, dp, depend);
  4847.               nindex:
  4848.                 begin
  4849.                 global(tp^.tvariable, dp, depend);
  4850.                 global(tp^.toffset, dp, depend)
  4851.                 end;
  4852.               nselect:
  4853.                 global(tp^.trecord, dp, depend);
  4854.               ncall:
  4855.                 begin
  4856.                 global(tp^.tcall, dp, depend);
  4857.                 global(tp^.taparm, dp, depend)
  4858.                 end;
  4859.               nid:
  4860.                 begin
  4861.                 (* find declaration point *)
  4862.                 ip := idup(tp);
  4863.                 if ip = nil then
  4864.                     goto 555;
  4865.                 (* ip points to nconst/ntype/nvar/nproc/nfunc/
  4866.                    nvalpar/nvarpar/nparproc or nparfunc node,
  4867.                    move to beginning of enclosing scope *)
  4868.                 repeat
  4869.                     ip := ip^.tup;
  4870.                     if ip = nil then
  4871.                         goto 555
  4872.                     (* stop only for locally declared items,
  4873.                        for global or predefined identifiers
  4874.                        we will have gone to label 555 *)
  4875.                 until    ip^.tt in [npgm, nproc, nfunc];
  4876.                 if dp = ip then
  4877.                     begin
  4878.                     (* identifier used here, mark it used *)
  4879.                     if depend then
  4880.                         tp^.tsym^.lused := true
  4881.                     end
  4882.                 else begin
  4883.                     (* identifier declared in enclosing
  4884.                        scope, mark it used *)
  4885.                     tp^.tsym^.lused := true
  4886.                      end;
  4887.             555:
  4888.                 end;
  4889.               ngoto:
  4890.                 if not islocal(tp^.tlabel) then
  4891.                     begin
  4892.                     tp^.tlabel^.tsym^.lgo := true;
  4893.                     usejmps := true;
  4894.                     cklevel(tp^.tlabel)
  4895.                     end;
  4896.  
  4897.               nbreak,
  4898.               npush,
  4899.               npop,
  4900.               npredef,
  4901.               nempty,
  4902.               nchar,
  4903.               ninteger,
  4904.               nreal,
  4905.               nstring,
  4906.               nnil:
  4907.             end;(* case *)
  4908.             tp := tp^.tnext
  4909.             end
  4910.     end;    (* global *)
  4911.  
  4912.     (*    Rename identifiers identical to C keywords.        *)
  4913.     procedure renamc;
  4914.  
  4915.     var    ip    : idptr;
  4916.         cn    : cnames;
  4917.  
  4918.     begin
  4919.         (* rename identifiers that mustn't be redefined
  4920.            if C and Pascal semantix are to be preserved *)
  4921.         for cn := cabort to cwrite do
  4922.             begin
  4923.             ip := mkrename('C', ctable[cn]);
  4924.             ctable[cn]^.istr := ip^.istr
  4925.             end
  4926.     end;
  4927.  
  4928.     (*    Rename subroutines declared in other subroutines such    *)
  4929.     (*    that they can be moved to a global scope without name-    *)
  4930.     (*    clashes.                        *)
  4931.     procedure renamp(tp : treeptr; on : boolean);
  4932.  
  4933.     var    sp    : symptr;
  4934.  
  4935.     begin
  4936.         (* tp points to subroutine-list *)
  4937.         while tp <> nil do
  4938.             begin
  4939.             renamp(tp^.tsubsub, true);
  4940.             if on and (tp^.tsubstmt <> nil) then
  4941.                 begin
  4942.                 (* change name of subroutine by prefixing
  4943.                    a unique name *)
  4944.                 sp := tp^.tsubid^.tsym;
  4945.                 if sp^.lid^.inref > 1 then
  4946.                     sp^.lid := mkrename('P', sp^.lid)
  4947.                 end;
  4948.             tp := tp^.tnext
  4949.             end
  4950.     end;
  4951.  
  4952.     (*    Add initialization-code for file-variables.        *)
  4953.     procedure initcode(tp : treeptr);
  4954.  
  4955.     var    ti, tq, tu, tv    : treeptr;
  4956.  
  4957.         (*    Determine if a type contains a file.        *)
  4958.         function filevar(tp : treeptr) : boolean;
  4959.  
  4960.         var    fv    : boolean;
  4961.             tq    : treeptr;
  4962.  
  4963.         begin
  4964.             case tp^.tt of
  4965.               npredef:
  4966.                 fv := tp = typnods[ttext];
  4967.               nfileof:
  4968.                 fv := true;
  4969.               nconfarr:
  4970.                 fv := filevar(typeof(tp^.tcelem));
  4971.               narray:
  4972.                 fv := filevar(typeof(tp^.taelem));
  4973.               nrecord:
  4974.                 begin
  4975.                 fv := false;
  4976.                 tq := tp^.tvlist;
  4977.                 while tq <> nil do
  4978.                     begin
  4979.                     if filevar(tq^.tvrnt) then
  4980.                         error(evrntfile);
  4981.                     tq := tq^.tnext
  4982.                     end;
  4983.                 tq := tp^.tflist;
  4984.                 while tq <> nil do
  4985.                     begin
  4986.                     if filevar(typeof(tq^.tbind)) then
  4987.                         begin
  4988.                         fv := true;
  4989.                         tq := nil
  4990.                         end
  4991.                     else
  4992.                         tq := tq^.tnext
  4993.                     end
  4994.                 end;
  4995.               nptr:
  4996.                 begin
  4997.                 fv := false;
  4998.                 if not tp^.tptrflag then
  4999.                     begin
  5000.                     tp^.tptrflag := true;
  5001.                     if filevar(typeof(tp^.tptrid)) then
  5002.                         error(evarfile);
  5003.                     tp^.tptrflag := false
  5004.                     end
  5005.                 end;
  5006.               nsubrange,
  5007.               nscalar,
  5008.               nsetof:
  5009.                 fv := false
  5010.             end;
  5011.             filevar := fv
  5012.         end;
  5013.  
  5014.         (*    Create code for initialization of files.    *)
  5015.         function fileinit(ti, tq : treeptr; opn : boolean) : treeptr;
  5016.  
  5017.         var    tx, ty, tz    : treeptr;
  5018.  
  5019.         begin
  5020.             (* create 1 statement initializing "ti" *)
  5021.             case tq^.tt of
  5022.               narray:
  5023.                 begin
  5024.                 (* create declaration for a loopvariable *)
  5025.                 tz := newid(mkvariable('I'));
  5026.                 ty := mknode(nvar);
  5027.                 ty^.tattr := aregister;
  5028.                 ty^.tidl := tz;
  5029.                 ty^.tbind := typeof(tq^.taindx);
  5030.                 tz := tq;
  5031.                 while not(tz^.tt in [nproc, nfunc, npgm]) do
  5032.                     tz := tz^.tup;
  5033.                 linkup(tz, ty);
  5034.                 if tz^.tsubvar = nil then
  5035.                     tz^.tsubvar := ty
  5036.                 else begin
  5037.                     tz := tz^.tsubvar;
  5038.                     while tz^.tnext <> nil do
  5039.                         tz := tz^.tnext;
  5040.                     tz^.tnext := ty
  5041.                      end;
  5042.                 ty := ty^.tidl;
  5043.                 (* create a loop initializing tq *)
  5044.                 tz := mknode(nindex);
  5045.                 tz^.tvariable := ti;
  5046.                 tz^.toffset := ty;
  5047.                 tz := fileinit(tz, tq^.taelem, opn);
  5048.                 tx := mknode(nfor);
  5049.                 tx^.tforid := ty;
  5050.                 ty := typeof(tq^.taindx);
  5051.                 if ty^.tt = nsubrange then
  5052.                     begin
  5053.                     tx^.tfrom := ty^.tlo;
  5054.  
  5055.                     tx^.tto := ty^.thi
  5056.                     end
  5057.                 else if ty^.tt = nscalar then
  5058.                     begin
  5059.                     ty := ty^.tscalid;
  5060.                     tx^.tfrom := ty;
  5061.                     while ty^.tnext <> nil do
  5062.                         ty := ty^.tnext;
  5063.                     tx^.tto := ty
  5064.                     end
  5065.                 else if ty = typnods[tchar] then
  5066.                     begin
  5067.                     currsym.st := schar;
  5068.                     currsym.vchr := chr(minchar);
  5069.                     tx^.tfrom := mklit;
  5070.                     currsym.st := schar;
  5071.                     currsym.vchr := chr(maxchar);
  5072.                     tx^.tto := mklit
  5073.                     end
  5074.                 else if ty = typnods[tinteger] then
  5075.                     begin
  5076.                     currsym.st := sinteger;
  5077.                     currsym.vint := -maxint;
  5078.                     tx^.tfrom := mklit;
  5079.                     currsym.st := sinteger;
  5080.                     currsym.vint := maxint;
  5081.                     tx^.tto := mklit
  5082.                     end
  5083.                 else
  5084.                     fatal(etree);
  5085.                 tx^.tforstmt := tz;
  5086.                 tx^.tincr := true
  5087.                 end;
  5088.               npredef,
  5089.               nfileof:
  5090.                 if opn then
  5091.                     begin
  5092.                     (* create file-struct initialization *)
  5093.                     ty := mknode(nselect);
  5094.                     ty^.trecord := ti;
  5095.                     ty^.tfield :=
  5096.                         oldid(defnams[dzfp]^.lid,
  5097.                                 lforward);
  5098.                     tx := mknode(nassign);
  5099.                     tx^.tlhs := ty;
  5100.                     currsym.st := sinteger;
  5101.                     currsym.vint := 0;
  5102.                     tx^.trhs := mklit
  5103.                     end
  5104.                 else begin
  5105.                     (* create file-struct wrapup *)
  5106.                     tx := mknode(ncall);
  5107.                     tx^.tcall := 
  5108.                         oldid(defnams[dclose]^.lid,
  5109.                                 lidentifier);
  5110.                     tx^.taparm := ti
  5111.                      end;
  5112.               nrecord:
  5113.                 begin
  5114.                 ty := nil;
  5115.                 tq := tq^.tflist;
  5116.                 while tq <> nil do
  5117.                     begin
  5118.                     if filevar(typeof(tq^.tbind)) then
  5119.                         begin
  5120.                         tz := tq^.tidl;
  5121.                         while tz <> nil do
  5122.                             begin
  5123.                             tx := mknode(nselect);
  5124.                             tx^.trecord := ti;
  5125.                             tx^.tfield := tz;
  5126.                             tx := fileinit(tx,
  5127.                                 typeof(tq^.tbind),
  5128.                                 opn);
  5129.                             tx^.tnext := ty;
  5130.                             ty := tx;
  5131.                             tz := tz^.tnext
  5132.                             end
  5133.                         end;
  5134.                     tq := tq^.tnext
  5135.                     end;
  5136.                 tx := mknode(nbegin);
  5137.                 tx^.tbegin := ty
  5138.                 end;
  5139.             end;(* case *)
  5140.             fileinit := tx
  5141.         end;
  5142.  
  5143.     begin    (* initcode *)
  5144.         while tp <> nil do
  5145.             begin
  5146.             initcode(tp^.tsubsub);
  5147.             tv := tp^.tsubvar;
  5148.             while tv <> nil do
  5149.                 begin
  5150.                 tq := typeof(tv^.tbind);
  5151.                 if filevar(tq) then
  5152.                     begin
  5153.                     ti := tv^.tidl;
  5154.                     while ti <> nil do
  5155.                         begin
  5156.                         tu := fileinit(ti, tq, true);
  5157.                         linkup(tp, tu);
  5158.                         tu^.tnext := tp^.tsubstmt;
  5159.                         tp^.tsubstmt := tu;
  5160.                         while tu^.tnext <> nil do
  5161.                             tu := tu^.tnext;
  5162.                         tu^.tnext := fileinit(ti, tq,
  5163.                                     false);
  5164.                         linkup(tp, tu^.tnext);
  5165.                         ti := ti^.tnext
  5166.                         end
  5167.                     end;
  5168.                 tv := tv^.tnext;
  5169.                 end;
  5170.             tp := tp^.tnext
  5171.             end
  5172.     end;    (* initcode *)
  5173.  
  5174. begin    (* transform *)
  5175.     renamc;
  5176.     renamp(top^.tsubsub, false);
  5177.     extract(top);
  5178.     renamf(top);
  5179.     initcode(top^.tsubsub);
  5180.     global(top, top, false)
  5181. end;    (* transform *)
  5182.  
  5183. (*    Emit C-code for program or module.                *)
  5184. procedure emit;
  5185.  
  5186. const    include    = '# include ';
  5187.     define    = '# define ';
  5188.     undef    = '# undef ';
  5189.     ifdef    = '# ifdef ';
  5190.     ifndef    = '# ifndef ';
  5191.     elsif    = '# else';
  5192.     endif    = '# endif';
  5193.     static    = 'static ';
  5194.     xtern    = 'extern ';
  5195.     typdef    = 'typedef ';
  5196.     registr    = 'register ';
  5197.     usigned    = 'unsigned ';
  5198.     indstep    = 2;
  5199.  
  5200. var    conflag,
  5201.     setused,
  5202.     dropset    : boolean;
  5203.     indnt    : integer;
  5204.  
  5205.     procedure increment;
  5206.     begin
  5207.         indnt := indnt + indstep
  5208.     end;
  5209.  
  5210.     procedure decrement;
  5211.     begin
  5212.         indnt := indnt - indstep
  5213.     end;
  5214.  
  5215.     (*    Write tabs/blanks to properly (?) indent C-code.    *) 
  5216.     procedure indent;
  5217.  
  5218.     var    i    : integer;
  5219.  
  5220.     begin
  5221.         i := indnt;
  5222.         (* limit indent to an integral number of tabs *)
  5223.         if i > 60 then
  5224.             i := i div tabwidth * tabwidth;
  5225.         while i >= tabwidth do
  5226.             begin
  5227.             write(tab1);
  5228.             i := i - tabwidth
  5229.             end;
  5230.         while i > 0 do
  5231.             begin
  5232.             write(space);
  5233.             i := i - 1
  5234.             end;
  5235.     end;
  5236.  
  5237.     (*    Determine if tp must be cast to an integer before being    *)
  5238.     (*    used in an arithmetic expression.            *)
  5239.     function arithexpr(tp : treeptr) : boolean;
  5240.  
  5241.     begin
  5242.         tp := typeof(tp);
  5243.         if tp^.tt = nsubrange then
  5244.             if tp^.tup^.tt = nconfarr then
  5245.                 tp := typeof(tp^.tup^.tindtyp)
  5246.             else
  5247.                 tp := typeof(tp^.tlo);
  5248.         arithexpr := (tp = typnods[tinteger]) or
  5249.                 (tp = typnods[tchar]) or
  5250.                     (tp = typnods[treal])
  5251.     end;
  5252.  
  5253.     (* Check if a type is represented in C as unsigned short or *)
  5254.     (* char, and thus should be cast to int in expressions to   *)
  5255.     (* preserve Pascal semantics                    *)
  5256.     function needsintcast(tp : treeptr) : boolean;
  5257.  
  5258.     begin
  5259.         tp := typeof(tp);
  5260.         if tp^.tt <> nsubrange then
  5261.             needsintcast := false
  5262.         else if clower(tp) < 0 then
  5263.             needsintcast := false
  5264.         else
  5265.             needsintcast := cupper(tp) <= 65535;
  5266.     end;
  5267.  
  5268.     procedure eexpr(tp : treeptr);                forward;
  5269.     procedure etypedef(tp : treeptr);            forward;
  5270.  
  5271.     (*    Emit code to select a record member.    *)
  5272.     procedure eselect(tp : treeptr);
  5273.  
  5274.     begin
  5275.         eexpr(tp);
  5276.         write('.');
  5277.     end;
  5278.  
  5279.     (*    Emit code for call to a predefined function/procedure.    *)
  5280.     procedure epredef(ts, tp : treeptr);
  5281.  
  5282.     label    444, 555;
  5283.  
  5284.     var    tq,
  5285.         tv, tx    : treeptr;
  5286.         td    : predefs;
  5287.         nelems    : integer;
  5288.         ch    : char;
  5289.         txtfile    : boolean;
  5290.  
  5291.         (*    Determine a format-code for fprintf.        *)
  5292.         (*    Update nelems as a sideeffect.            *)
  5293.         function typeletter(tp : treeptr) : char;
  5294.  
  5295.         label    999;
  5296.  
  5297.         var    tq    : treeptr;
  5298.  
  5299.         begin
  5300.             tq := tp;
  5301.             if tq^.tt = nformat then
  5302.                 begin
  5303.                 if tq^.texpl^.tt = nformat then
  5304.                     begin
  5305.                     typeletter := 'f';
  5306.                     goto 999
  5307.                     end;
  5308.                 tq := tp^.texpl
  5309.                 end;
  5310.             tq := typeof(tq);
  5311.             if tq^.tt = nsubrange then
  5312.                 tq := typeof(tq^.tlo);
  5313.             if tq = typnods[tstring] then
  5314.                 typeletter := 's'
  5315.             else if tq = typnods[tinteger] then
  5316.                 typeletter := 'd'
  5317.             else if tq = typnods[tchar] then
  5318.                 typeletter := 'c'
  5319.             else if tq = typnods[treal] then
  5320.                 if tp^.tt = nformat then
  5321.                     typeletter := 'e'
  5322.                 else
  5323.                     typeletter := 'g'
  5324.             else if tq = typnods[tboolean] then
  5325.                 begin
  5326.                 typeletter := 'b';
  5327.                 nelems := 6
  5328.                 end
  5329.             else if tq^.tt = narray then
  5330.                 begin
  5331.                 typeletter := 'a';
  5332.                 nelems := crange(tq^.taindx)
  5333.                 end
  5334.             else if tq^.tt = nconfarr then
  5335.                 begin
  5336.                 typeletter := 'v';
  5337.                 nelems := 0
  5338.                 end
  5339.             else
  5340.                 fatal(etree);
  5341.         999:
  5342.         end;    (* typeletter *)
  5343.  
  5344.         procedure etxt(tp : treeptr);
  5345.  
  5346.         var    w    : toknbuf;
  5347.             c    : char;
  5348.             i    : toknidx;
  5349.  
  5350.         begin
  5351.             case tp^.tt of
  5352.               nid:
  5353.                 begin
  5354.                 tp := idup(tp);
  5355.                 if tp^.tt = nconst then
  5356.                     etxt(tp^.tbind)
  5357.                 else
  5358.                     fatal(etree)
  5359.                 end;
  5360.               nstring:
  5361.                 begin
  5362.                 (* printf format string *)
  5363.                 gettokn(tp^.tsym^.lstr, w);
  5364.                 i := 1;
  5365.                 while w[i] <> chr(null) do
  5366.                     begin
  5367.                     c := w[i];
  5368.                     if (c = cite) or (c = bslash) then
  5369.                         write(bslash)
  5370.                     else if c = percent then
  5371.                         write(percent);
  5372.                     write(c);
  5373.                     i := i + 1
  5374.                     end
  5375.                 end;
  5376.               nchar:
  5377.                 begin
  5378.                 (* single character in printf format *)
  5379.                 c := tp^.tsym^.lchar;
  5380.                 if (c = cite) or (c = bslash) then
  5381.                     write(bslash)
  5382.                 else if c = percent then
  5383.                     write(percent);
  5384.                 write(c)
  5385.                 end;
  5386.             end;(* case *)
  5387.         end;    (* etxt *)
  5388.  
  5389.         (*    Emit format for fprintf.            *)
  5390.         procedure eformat(tq : treeptr);
  5391.  
  5392.         var    tx    : treeptr;
  5393.             i    : integer;
  5394.  
  5395.         begin
  5396.             case typeletter(tq) of
  5397.               'a':
  5398.                 begin
  5399.                 write(percent);
  5400.                 if tq^.tt = nformat then
  5401.                     if tq^.texpr^.tt = ninteger then
  5402.                         eexpr(tq^.texpr)
  5403.                     else
  5404.                         write('*');
  5405.                 write('.', nelems:1, 's')
  5406.                 end;
  5407.               'b':
  5408.                 begin
  5409.                 write(percent);
  5410.                 if tq^.tt = nformat then
  5411.                     begin
  5412.                     if tq^.texpr^.tt = ninteger then
  5413.                         eexpr(tq^.texpr)
  5414.                     else
  5415.                         write('*')
  5416.                     end;
  5417.                 write('s')
  5418.                 end;
  5419.               'c':
  5420.                 if tq^.tt = nchar then
  5421.                     etxt(tq)
  5422.                 else begin
  5423.                     write(percent);
  5424.                     if tq^.tt = nformat then
  5425.                         if tq^.texpr^.tt = ninteger then
  5426.                             eexpr(tq^.texpr)
  5427.                         else
  5428.                             write('*');
  5429.                     write('c')
  5430.                      end;
  5431.               'd':
  5432.                 begin
  5433.                 write(percent);
  5434.                 if tq^.tt = nformat then
  5435.                     begin
  5436.                     if tq^.texpr^.tt = ninteger then
  5437.                         eexpr(tq^.texpr)
  5438.                     else
  5439.                         write('*')
  5440.                     end
  5441.                 else
  5442.                     write(intlen:1);
  5443.                 write('d')
  5444.                 end;
  5445.               'e':
  5446.                 begin
  5447.                 write(percent, space);
  5448.                 tx := tq^.texpr;
  5449.                 if tx^.tt = ninteger then
  5450.                     begin
  5451.                     i := cvalof(tx);
  5452.                     write(i:1, '.');
  5453.                     i := i - 7;
  5454.                     if i < 1 then
  5455.                         write('1')
  5456.                     else
  5457.                         write(i:1)
  5458.                     end
  5459.                 else
  5460.                     write('*.*');
  5461.                 write('e')
  5462.                 end;
  5463.               'f':
  5464.                 begin
  5465.                 write(percent);
  5466.                 tx := tq^.texpl;
  5467.                 if tx^.texpr^.tt = ninteger then
  5468.                     begin
  5469.                     eexpr(tx^.texpr);
  5470.                     write('.');
  5471.                     tx := tq^.texpr;
  5472.                     if tx^.tt = ninteger then
  5473.                         begin
  5474.                         i := cvalof(tx);
  5475.                         tx := tq^.texpl^.texpr;
  5476.                         if i > cvalof(tx) - 1 then
  5477.                             write('1')
  5478.                         else
  5479.                             write(i:1)
  5480.                         end
  5481.                     else
  5482.                         write('*');
  5483.                     end
  5484.                 else
  5485.                     write('*.*');
  5486.                 write('f')
  5487.                 end;
  5488.               'g':
  5489.                 write(percent, fixlen:1, 'e');
  5490.               's':
  5491.                 if tq^.tt = nstring then
  5492.                     etxt(tq)
  5493.                 else begin
  5494.                     write(percent);
  5495.                     if tq^.tt = nformat then
  5496.                         if tq^.texpr^.tt = ninteger then
  5497.                             eexpr(tq^.texpr)
  5498.                         else
  5499.                             write('*.*');
  5500.                     write('s')
  5501.                      end;
  5502.               'v':
  5503.                 fatal(eprconf)
  5504.             end; (* case *)
  5505.         end;    (* eformat *)
  5506.  
  5507.         (*    Emit parameters to fprintf except format.    *)
  5508.         procedure ewrite(tq : treeptr);
  5509.  
  5510.         var    tx    : treeptr;
  5511.  
  5512.         begin
  5513.             case typeletter(tq) of
  5514.               'a':
  5515.                 begin
  5516.                 write(', ');
  5517.                 tx := tq;
  5518.                 if tq^.tt = nformat then
  5519.                     begin
  5520.                     if tq^.texpr^.tt <> ninteger then
  5521.                         begin
  5522.                           eexpr(tq^.texpr);
  5523.                           write(', ')
  5524.                         end;
  5525.                     tx := tq^.texpl
  5526.                     end;
  5527.                 eexpr(tx);
  5528.                 write('.A')
  5529.                 end;
  5530.               'b':
  5531.                 begin
  5532.                 write(', ');
  5533.                 tx := tq;
  5534.                 if tq^.tt = nformat then
  5535.                     begin
  5536.                     if tq^.texpr^.tt <> ninteger then
  5537.                         begin
  5538.                           eexpr(tq^.texpr);
  5539.                           write(', ')
  5540.                         end;
  5541.                     tx := tq^.texpl
  5542.                     end;
  5543.                 write('Bools[(int)(');
  5544.                 eexpr(tx);
  5545.                 write(')]')
  5546.                 end;
  5547.               'c':
  5548.                 begin
  5549.                 if tq^.tt = nformat then
  5550.                     begin
  5551.                     if tq^.texpr^.tt <> ninteger then
  5552.                         begin
  5553.                         write(', ');
  5554.                         eexpr(tq^.texpr)
  5555.                         end;
  5556.                     write(', ');
  5557.                     eexpr(tq^.texpl)
  5558.                     end
  5559.                 else if tq^.tt <> nchar then
  5560.                     begin
  5561.                     write(', ');
  5562.                     eexpr(tq)
  5563.                     end
  5564.                 end;
  5565.               'd':
  5566.                 begin
  5567.                 write(', ');
  5568.                 tx := tq;
  5569.                 if tq^.tt = nformat then
  5570.                     begin
  5571.                     if tq^.texpr^.tt <> ninteger then
  5572.                         begin
  5573.                         eexpr(tq^.texpr);
  5574.                         write(', ')
  5575.                         end;
  5576.                     tx := tq^.texpl
  5577.                     end;
  5578.                 eexpr(tx)
  5579.                 end;
  5580.               'e':
  5581.                 begin
  5582.                 write(', ');
  5583.                 tx := tq^.texpr;
  5584.                 if tx^.tt <> ninteger then
  5585.                     begin
  5586.                     usemax := true;
  5587.                     eexpr(tx);
  5588.                     write(', Max(');
  5589.                     eexpr(tx);
  5590.                     write(' - 7, 1), ')
  5591.                     end;
  5592.                 eexpr(tq^.texpl)
  5593.                 end;
  5594.               'f':
  5595.                 begin
  5596.                 write(', ');
  5597.                 tx := tq^.texpl;
  5598.                 if tx^.texpr^.tt <> ninteger then
  5599.                     begin
  5600.                     eexpr(tx^.texpr);
  5601.                     write(', ')
  5602.                     end;
  5603.                 if (tx^.texpr^.tt <> ninteger) or
  5604.                     (tq^.texpr^.tt <> ninteger) then
  5605.                     begin
  5606.                     usemax := true;
  5607.                     write('Max((');
  5608.                     eexpr(tx^.texpr);
  5609.                     write(') - (');
  5610.                     eexpr(tq^.texpr);
  5611.                     write(') - 1, 1), ')
  5612.                     end;
  5613.                 eexpr(tq^.texpl^.texpl)
  5614.                 end;
  5615.               'g':
  5616.                 begin
  5617.                 write(', ');
  5618.                 eexpr(tq)
  5619.                 end;
  5620.               's':
  5621.                 begin
  5622.                 if tq^.tt = nformat then
  5623.                     begin
  5624.                     if tq^.texpr^.tt <> ninteger then
  5625.                        begin
  5626.                         write(', ');
  5627.                         eexpr(tq^.texpr);
  5628.                         write(', ');
  5629.                         eexpr(tq^.texpr)
  5630.                        end;
  5631.                     write(', ');
  5632.                     eexpr(tq^.texpl)
  5633.                     end
  5634.                 else if tq^.tt <> nstring then
  5635.                     begin
  5636.                     write(', ');
  5637.                     eexpr(tq)
  5638.                     end
  5639.                 end;
  5640.               'v':
  5641.                 fatal(eprconf)
  5642.             end (* case *)
  5643.         end;    (* ewrite *)
  5644.  
  5645.         (*    Emit size of *tp for call to malloc. CPU    *)
  5646.         (*    There is no safe way to compute the size of a    *)
  5647.         (*    particular variant of a C-union, we assume that    *)
  5648.         (*    the size can be computed by taking the address    *)
  5649.         (*    of the first member and subracting the address    *)
  5650.         (*    of the record and then adding the size of the    *)
  5651.         (*    variant containing the record.            *)
  5652.         procedure enewsize(tp : treeptr);
  5653.  
  5654.         label    555;
  5655.  
  5656.         var    tq, tx, ty    : treeptr;
  5657.             v        : integer;
  5658.  
  5659.             (*    Emit size of union member tq.        *)
  5660.             procedure esubsize(tp, tq : treeptr);
  5661.  
  5662.             label    555, 666;
  5663.  
  5664.             var    tx, ty    : treeptr;
  5665.                 addsize    : boolean;
  5666.  
  5667.             begin
  5668.                 tx := tq^.tvrnt;
  5669.                 ty := tx^.tflist;
  5670.                 if ty = nil then
  5671.                     begin
  5672.                     ty := tx^.tvlist;
  5673.                     while ty <> nil do
  5674.                         begin
  5675.                         if ty^.tvrnt^.tflist <> nil then
  5676.                             begin
  5677.                             ty := ty^.tvrnt^.tflist;
  5678.                             goto 555
  5679.                             end;
  5680.                         ty := ty^.tnext
  5681.                         end;
  5682.                 555:
  5683.                     end;
  5684.                 addsize := true;
  5685.                 if ty = nil then
  5686.                     begin
  5687.                     (* empty variant, try using another *)
  5688.                     addsize := false;
  5689.                     ty := tx^.tup^.tup^.tvlist;
  5690.                     while ty <> nil do
  5691.                         begin
  5692.                         if ty^.tvrnt^.tflist <> nil then
  5693.                             begin
  5694.                             ty := ty^.tvrnt^.tflist;
  5695.                             goto 666
  5696.                             end;
  5697.                         ty := ty^.tnext
  5698.                         end;
  5699.                 666:
  5700.                     end;
  5701.                 if ty = nil then
  5702.                     begin
  5703.                     (* its getting too complicated,
  5704.                         ignore tag value *)
  5705.                     write('sizeof(*');
  5706.                     eexpr(tp);
  5707.                     write(')')
  5708.                     end
  5709.                 else begin
  5710.                     (* compute offset to first member of
  5711.                        the selected union variant *)
  5712.                     write('Unionoffs(');
  5713.                     eexpr(tp);
  5714.                     write(', ');
  5715.                     printid(ty^.tidl^.tsym^.lid);
  5716.                     if addsize then
  5717.                         begin
  5718.                         (* add the size of the selected
  5719.                            union variant *)
  5720.                         write(') + sizeof(');
  5721.                         eexpr(tp);
  5722.                         write('->');
  5723.                         printid(tx^.tuid)
  5724.                         end;
  5725.                     write(')')
  5726.                      end
  5727.             end;
  5728.  
  5729.         begin    (* newsize *)
  5730.             if (tp^.tnext <> nil) and unionnew then
  5731.                 begin
  5732.                 (* tnext points to a tag-value, evaluate it *)
  5733.                 v := cvalof(tp^.tnext);
  5734.                 (* find union type *)
  5735.                 tq := typeof(tp);
  5736.                 tq := typeof(tq^.tptrid);
  5737.                 if tq^.tt <> nrecord then
  5738.                     fatal(etree);
  5739.                 (* find corresponding variant *)
  5740.                 tx := tq^.tvlist;
  5741.                 while tx <> nil do
  5742.                     begin
  5743.                     ty := tx^.tselct;
  5744.                     while ty <> nil do
  5745.                         begin
  5746.                         if v = cvalof(ty) then
  5747.                             goto 555;
  5748.                         ty := ty^.tnext
  5749.                         end;
  5750.                     tx := tx^.tnext
  5751.                     end;
  5752.                 fatal(etag);
  5753.             555:
  5754.                 (* emit size for that variant *)
  5755.                 esubsize(tp, tx)
  5756.                 end
  5757.             else begin
  5758.                 write('sizeof(*');
  5759.                 eexpr(tp);
  5760.                 write(')')
  5761.                  end
  5762.         end;    (* newsize *)
  5763.  
  5764.     begin    (* epredef *)
  5765.         td := ts^.tsubstmt^.tdef;
  5766.         case td of
  5767.           dabs:
  5768.             begin
  5769.             tq := typeof(tp^.taparm);
  5770.             if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
  5771.                 write('abs(')            (* LIB *)
  5772.             else
  5773.                 write('fabs(');            (* LIB *)
  5774.             eexpr(tp^.taparm);
  5775.             write(')')
  5776.             end;
  5777.           dargv:
  5778.             begin
  5779.             write('Argvgt(');
  5780.             eexpr(tp^.taparm);
  5781.             write(', ');
  5782.             eexpr(tp^.taparm^.tnext);
  5783.             write('.A, sizeof(');
  5784.             eexpr(tp^.taparm^.tnext);
  5785.             writeln('.A));')
  5786.             end;
  5787.           dchr:
  5788.             begin
  5789.             tq := typeof(tp^.taparm);
  5790.             if tq^.tt = nsubrange then
  5791.                 if tq^.tup^.tt = nconfarr then
  5792.                     tq := typeof(tq^.tup^.tindtyp)
  5793.                 else
  5794.                     tq := typeof(tq^.tlo);
  5795.             if (tq = typnods[tinteger]) or
  5796.                         (tq = typnods[tchar]) then
  5797.                 eexpr(tp^.taparm)
  5798.             else begin
  5799.                 write('(unsigned char)(');
  5800.                 eexpr(tp^.taparm);
  5801.                 write(')')
  5802.                  end
  5803.             end;
  5804.           ddispose:
  5805.             begin
  5806.             write('free(');                (* LIB *)
  5807.             eexpr(tp^.taparm);
  5808.             writeln(');')
  5809.             end;
  5810.           deof:
  5811.             begin
  5812.             tq := tp^.taparm;
  5813.             if tq <> nil then
  5814.                 begin
  5815.                 tv := typeof(tq);
  5816.                 if tv = typnods[ttext] then
  5817.                     txtfile := true
  5818.                 else if tv^.tt = nfileof then
  5819.                     txtfile := typeof(tv^.tof) =
  5820.                             typnods[tchar]
  5821.                 else
  5822.                     txtfile := true
  5823.                 end
  5824.             else
  5825.                 txtfile := true;
  5826.             if txtfile then
  5827.                 write('Eofx(')
  5828.             else
  5829.                 write('Eof(');
  5830.             if tp^.taparm = nil then
  5831.                 begin
  5832.                 defnams[dinput]^.lused := true;
  5833.                 printid(defnams[dinput]^.lid)
  5834.                 end
  5835.             else
  5836.                 eexpr(tp^.taparm);
  5837.             write(')')
  5838.             end;
  5839.           deoln:
  5840.             begin
  5841.             write('Eoln(');
  5842.             if tp^.taparm = nil then
  5843.                 begin
  5844.                 defnams[dinput]^.lused := true;
  5845.                 printid(defnams[dinput]^.lid)
  5846.                 end
  5847.             else
  5848.                 eexpr(tp^.taparm);
  5849.             write(')');
  5850.             end;
  5851.           dexit:
  5852.             begin
  5853.             write('exit(');                (* OS *)
  5854.             if tp^.taparm = nil then
  5855.                 write('0')
  5856.             else
  5857.                 eexpr(tp^.taparm);
  5858.             writeln(');');
  5859.             end;
  5860.           dbreak,
  5861.           dflush,
  5862.           dprompt:
  5863.             begin
  5864.             write('Flush(');
  5865.             if tp^.taparm = nil then
  5866.                 begin
  5867.                 defnams[doutput]^.lused := true;
  5868.                 printid(defnams[doutput]^.lid)
  5869.                 end
  5870.             else
  5871.                 eexpr(tp^.taparm);
  5872.             writeln(');')
  5873.             end;
  5874.           dpage:
  5875.             begin
  5876.             (* write form-feed character *)
  5877.             write('Putchr(', ffchr, ', '); (* CHAR *)
  5878.             if tp^.taparm = nil then
  5879.                 begin
  5880.                 defnams[doutput]^.lused := true;
  5881.                 printid(defnams[doutput]^.lid)
  5882.                 end
  5883.             else
  5884.                 eexpr(tp^.taparm);
  5885.             writeln(');');
  5886.             end;
  5887.           dput,
  5888.           dget:
  5889.             begin
  5890.             tv := typeof(tp^.taparm);
  5891.             if (tv = typnods[ttext])
  5892.             or ((tv^.tt = nfileof)
  5893.             and (typeof(tv^.tof) = typnods[tchar])) then
  5894.                 if td = dget then
  5895.                     write('Getx')
  5896.                 else
  5897.                     write('Putx')
  5898.             else begin
  5899.                 write(voidcast);
  5900.                 if td = dget then
  5901.                     write('Get')
  5902.                 else
  5903.                     write('Put')
  5904.                  end;
  5905.             write('(');
  5906.             eexpr(tp^.taparm);
  5907.             writeln(');')
  5908.             end;
  5909.           dhalt:
  5910.             writeln('abort();');            (* OS *)
  5911.           dnew:
  5912.             begin
  5913.             eexpr(tp^.taparm);
  5914.             write(' = (');
  5915.             etypedef(typeof(tp^.taparm));
  5916.             write(')malloc((unsigned)(');    (* LIB *)
  5917.             enewsize(tp^.taparm);
  5918.             writeln('));')
  5919.             end;
  5920.           dord:
  5921.             begin
  5922.             write('(unsigned)(');
  5923.             eexpr(tp^.taparm);
  5924.             write(')')
  5925.             end;
  5926.           dread,
  5927.           dreadln:
  5928.             begin
  5929.             txtfile := false;
  5930.             tq := tp^.taparm;
  5931.             write('{');
  5932.             if tq <> nil then
  5933.                 begin
  5934.                 tv := typeof(tq);
  5935.                 if tv = typnods[ttext] then
  5936.                     begin
  5937.                     (* reading from textfile *)
  5938.                     txtfile := true;
  5939.                     tv := tq;
  5940.                     tq := tq^.tnext
  5941.                     end
  5942.                 else if tv^.tt = nfileof then
  5943.                     begin
  5944.                     (* reading from other file *)
  5945.                     txtfile := typeof(tv^.tof) =
  5946.                             typnods[tchar];
  5947.                     tv := tq;
  5948.                     tq := tq^.tnext
  5949.                     end
  5950.                 else begin
  5951.                     (* reading from std-input *)
  5952.                     txtfile := true;
  5953.                     tv := nil
  5954.                      end
  5955.                 end
  5956.             else begin
  5957.                 tv := nil;
  5958.                 txtfile := true
  5959.                  end;
  5960.             if txtfile then
  5961.                 begin
  5962.                 (* check for special case *)
  5963.                 if tq = nil then
  5964.                     goto 444;
  5965.                 if (tq^.tt <> nformat) and
  5966.                         (tq^.tnext = nil) and
  5967.                         (typeletter(tq) = 'c') then
  5968.                     begin
  5969.                     (* read single char *)
  5970.                     eexpr(tq);
  5971.                     write(' = ');
  5972.                     write('Getchr(');
  5973.                     if tv = nil then
  5974.                         printid(defnams[dinput]^.lid)
  5975.                     else
  5976.                         eexpr(tv);
  5977.                     write(')');
  5978.                     if td = dreadln then
  5979.                         write('; ');
  5980.                     goto 444
  5981.                     end;
  5982.                 write('Fscan(');
  5983.                 if tv = nil then
  5984.                     printid(defnams[dinput]^.lid)
  5985.                 else
  5986.                     eexpr(tv);
  5987.                 write('); ');
  5988.                 (* first pass, emit format string *)
  5989.                 while tq <> nil do
  5990.                     begin
  5991.                     write('Scan(', cite);
  5992.                     ch := typeletter(tq);
  5993.                     case ch of
  5994.                       'a':
  5995.                         write(percent, 's');
  5996.                       'c':
  5997.                         write(percent, 'c');
  5998.                       'd':
  5999.                         write(percent, 'ld');
  6000.                       'g':
  6001.                         write(percent, 'le')
  6002.                     end;(* case *)
  6003.                     write(cite, ', ');
  6004.                     case ch of
  6005.                       'a':
  6006.                         begin
  6007.                         eexpr(tq);
  6008.                         write('.A')
  6009.                         end;
  6010.                       'c':
  6011.                         begin
  6012.                         write('&');
  6013.                         eexpr(tq)
  6014.                         end;
  6015.                       'd':
  6016.                         write('&Tmplng');
  6017.                       'g':
  6018.                         write('&Tmpdbl')
  6019.                     end;(* case *)
  6020.                     write(')');
  6021.                     case ch of
  6022.                       'd':
  6023.                         begin
  6024.                         write('; ');
  6025.                         eexpr(tq);
  6026.                         write(' = Tmplng')
  6027.                         end;
  6028.                       'g':
  6029.                         begin
  6030.                         write('; ');
  6031.                         eexpr(tq);
  6032.                         write(' = Tmpdbl')
  6033.                         end;
  6034.                       'a',
  6035.                       'c':
  6036.                         (* no op *)
  6037.                     end;(* case *)
  6038.                     tq := tq^.tnext;
  6039.                     if tq <> nil then
  6040.                         begin
  6041.                         writeln(';');
  6042.                         indent;
  6043.                         write(tab1)
  6044.                         end
  6045.                     end;
  6046.                 write(';');
  6047.                 if td = dreadln then
  6048.                     write('; ');
  6049.             444:
  6050.                 if td = dreadln then
  6051.                     begin
  6052.                     write('Getl((text *)&');
  6053.                     if tv = nil then
  6054.                         printid(defnams[dinput]^.lid)
  6055.                     else
  6056.                         eexpr(tv);
  6057.                     write(')')
  6058.                     end
  6059.                 end
  6060.             else begin
  6061.                 increment;
  6062.                 while tq <> nil do
  6063.                     begin
  6064.                         eexpr(tq);
  6065.                     write(' = ');
  6066.                     write('Buf(');
  6067.                     eexpr(tv);
  6068.                     write('), Get(');
  6069.                     eexpr(tv);
  6070.                     write(')');
  6071.                     tq := tq^.tnext;
  6072.                     if tq <> nil then
  6073.                         begin
  6074.                         writeln('; ');
  6075.                         indent
  6076.                         end
  6077.                     end;
  6078.                 decrement
  6079.                  end;
  6080.             writeln(';}')
  6081.             end;
  6082.           dwrite,
  6083.           dwriteln:
  6084.             begin
  6085.             txtfile := false;
  6086.             tq := tp^.taparm;
  6087.             if tq <> nil then
  6088.                 begin
  6089.                 tv := typeof(tq);
  6090.                 if tv = typnods[ttext] then
  6091.                     begin
  6092.                     (* writing to textfile *)
  6093.                     txtfile := true;
  6094.                     tv := tq;
  6095.                     tq := tq^.tnext
  6096.                     end
  6097.                 else if tv^.tt = nfileof then
  6098.                     begin
  6099.                     (* writing to other file *)
  6100.                     txtfile := typeof(tv^.tof) =
  6101.                             typnods[tchar];
  6102.                     tv := tq;
  6103.                     tq := tq^.tnext
  6104.                     end
  6105.                 else begin
  6106.                     (* writing to std-output *)
  6107.                     txtfile := true;
  6108.                     tv := nil
  6109.                      end
  6110.                 end
  6111.             else begin
  6112.                 tv := nil;
  6113.                 txtfile := true
  6114.                  end;
  6115.             if txtfile then
  6116.                 begin
  6117.                 (* check for special case *)
  6118.                 if tq = nil then
  6119.                     begin
  6120.                     (* writeln whithout parameters *)
  6121.                     if td = dwriteln then
  6122.                         begin
  6123.                         write('Putchr(', nlchr, ', ');
  6124.                         if tv = nil then
  6125.                             printid(
  6126.                               defnams[doutput]^.lid)
  6127.                         else
  6128.                             eexpr(tv);
  6129.                         write(')')
  6130.                         end;
  6131.                     writeln(';');
  6132.                     goto 555
  6133.                     end
  6134.                 else if (tq^.tt <> nformat) and
  6135.                         (tq^.tnext = nil) then
  6136.                     if typeletter(tq) = 'c' then
  6137.                         begin
  6138.                         (* print single char *)
  6139.                         write('Putchr(');
  6140.                         eexpr(tq);
  6141.                         write(', ');
  6142.                         if tv = nil then
  6143.                             printid(
  6144.                               defnams[doutput]^.lid)
  6145.                         else
  6146.                             eexpr(tv);
  6147.                         write(')');
  6148.                         if td = dwriteln then
  6149.                             begin
  6150.                             write(',Putchr(',
  6151.                                 nlchr, ', ');
  6152.                             if tv = nil then
  6153.                              printid(
  6154.                               defnams[doutput]^.lid)
  6155.                             else
  6156.                                 eexpr(tv);
  6157.                             write(')');
  6158.                             end;
  6159.                         writeln(';');
  6160.                         goto 555
  6161.                         end;
  6162.                 tx := nil;
  6163.                 write(voidcast, 'fprintf(');    (* LIB *)
  6164.                 begin
  6165.                     if tv = nil then
  6166.                         printid(defnams[doutput]^.lid)
  6167.                     else
  6168.                         eexpr(tv);
  6169.                     write('.fp, ')
  6170.                      end;
  6171.                 write(cite);
  6172.                 tx := tq;    (* remember 1:st parm *)
  6173.                 (* first pass, emit format string *)
  6174.                 while tq <> nil do
  6175.                     begin
  6176.                     eformat(tq);
  6177.                     tq := tq^.tnext
  6178.                     end;
  6179.                 if (td = dwriteln) then
  6180.                     write('\n');
  6181.                 write(cite);
  6182.                 (* second pass, add parameters *)
  6183.                 tq := tx;
  6184.                 while tq <> nil do
  6185.                     begin
  6186.                     ewrite(tq);
  6187.                     tq := tq^.tnext
  6188.                     end;
  6189.                 write('), Putl(');
  6190.                 if tv = nil then
  6191.                     printid(defnams[doutput]^.lid)
  6192.                 else
  6193.                     eexpr(tv);
  6194.                 if td = dwrite then
  6195.                     write(', 0)')
  6196.                 else
  6197.                     write(', 1)')
  6198.                 end
  6199.             else begin
  6200.                 increment;
  6201.                 tx := typeof(tv);
  6202.                 if tx = typnods[ttext] then
  6203.                     tx := typnods[tchar]
  6204.                 else if tx^.tt = nfileof then
  6205.                     tx := typeof(tx^.tof)
  6206.                 else
  6207.                     fatal(etree);
  6208.                 while tq <> nil do
  6209.                     begin
  6210.                     if (tq^.tt in [nid, nindex, nselect,
  6211.                             nderef]) and
  6212.                         (tx = typeof(tq)) then
  6213.                         begin
  6214.                         write(voidcast, 'Fwrite(');
  6215.                         eexpr(tq)
  6216.                         end
  6217.                     else begin
  6218.                         if tx^.tt = nsetof then
  6219.                             begin
  6220.                             usescpy := true;
  6221.                             write('Setncpy(');
  6222.                             eselect(tv);
  6223.                             write('buf.S, ');
  6224.                             eexpr(tq);
  6225.                             if typeof(tp^.trhs) =
  6226.                                typnods[tset] then
  6227.                                 eexpr(tq)
  6228.                             else begin
  6229.                                 eselect(tq);
  6230.                                 write('S')
  6231.                                  end;
  6232.                             write(', sizeof(');
  6233.                             eexpr(tv);
  6234.                             write('.buf))');
  6235.                             end
  6236.                         else begin
  6237.                             eexpr(tv);
  6238.                             write('.buf = ');
  6239.                             eexpr(tq)
  6240.                              end;
  6241.                         write(', Fwrite(');
  6242.                         eexpr(tv);
  6243.                         write('.buf');
  6244.                          end;
  6245.                     write(', ');
  6246.                     eexpr(tv);
  6247.                     write('.fp)');
  6248.                     tq := tq^.tnext;
  6249.                     if tq <> nil then
  6250.                         begin
  6251.                         writeln(',');
  6252.                         indent
  6253.                         end
  6254.                     end;
  6255.                 decrement
  6256.                  end;
  6257.             writeln(';');
  6258.         555:
  6259.             end;
  6260.           dclose:
  6261.             begin
  6262.             tq := typeof(tp^.taparm);
  6263.             txtfile := tq = typnods[ttext];
  6264.             if (not txtfile) and (tq^.tt = nfileof) then
  6265.                 if typeof(tq^.tof) = typnods[tchar] then
  6266.                     txtfile := true;
  6267.             if txtfile then
  6268.                 write('Closex(')
  6269.             else
  6270.                 write('Close(');
  6271.             eexpr(tp^.taparm);
  6272.             writeln(');');
  6273.             end;
  6274.           dreset,
  6275.           drewrite:
  6276.             begin
  6277.             tq := typeof(tp^.taparm);
  6278.             txtfile := tq = typnods[ttext];
  6279.             if (not txtfile) and (tq^.tt = nfileof) then
  6280.                 if typeof(tq^.tof) = typnods[tchar] then
  6281.                     txtfile := true;
  6282.             if txtfile then
  6283.                 if td = dreset then
  6284.                     write('Resetx(')
  6285.                 else
  6286.                     write('Rewritex(')
  6287.             else
  6288.                 if td = dreset then
  6289.                     write('Reset(')
  6290.                 else
  6291.                     write('Rewrite(');
  6292.             eexpr(tp^.taparm);
  6293.             write(', ');
  6294.             tq := tp^.taparm^.tnext;
  6295.             if tq = nil then
  6296.                 write('NULL, 0')
  6297.                         (*  Should use argv[] parameters if this filename was
  6298.                             given in the program header  *)
  6299.             else begin
  6300.                 tq := typeof(tq);
  6301.                 if tq = typnods[tchar] then
  6302.                     begin
  6303.                     write(cite);
  6304.                     ch := chr(cvalof(tp^.taparm^.tnext));
  6305.                     if (ch = bslash) or (ch = cite) then
  6306.                         write(bslash);
  6307.                     write(ch, cite, ', -1')
  6308.                     end
  6309.                 else if tq = typnods[tstring] then
  6310.                     begin
  6311.                     eexpr(tp^.taparm^.tnext);
  6312.                     write(', -1')
  6313.                     end
  6314.                 else if tq^.tt = narray then
  6315.                      begin
  6316.                     eexpr(tp^.taparm^.tnext);
  6317.                     write('.A, sizeof(');
  6318.                     eexpr(tp^.taparm^.tnext);
  6319.                     write('.A)')
  6320.                      end
  6321.                 else
  6322.                     fatal(etree)
  6323.                  end;
  6324.             writeln(');')
  6325.             end;
  6326.           dseek:
  6327.             begin
  6328.                 write('Seek(');
  6329.             eexpr(tp^.taparm);
  6330.             write(',');
  6331.             eexpr(tp^.taparm^.tnext);
  6332.             write(',');
  6333.             eexpr(tp^.taparm^.tnext^.tnext);
  6334.             writeln(');');
  6335.             defnams[dseek]^.lused := true;
  6336.             end;
  6337.           dtell:
  6338.             begin
  6339.                 write('Tell(');
  6340.             eexpr(tp^.taparm);
  6341.             write(')');
  6342.             defnams[dtell]^.lused := true;
  6343.             end;
  6344.           darctan:
  6345.             begin
  6346.             write('atan(');    (* LIB *)
  6347.             if typeof(tp^.taparm) <> typnods[treal] then
  6348.                 write(dblcast);
  6349.             eexpr(tp^.taparm);
  6350.             write(')')
  6351.             end;
  6352.           dln:
  6353.             begin
  6354.             write('log(');    (* LIB *)
  6355.             if typeof(tp^.taparm) <> typnods[treal] then
  6356.                 write(dblcast);
  6357.             eexpr(tp^.taparm);
  6358.             write(')')
  6359.             end;
  6360.           dexp:
  6361.             begin
  6362.             write('exp(');    (* LIB *)
  6363.             if typeof(tp^.taparm) <> typnods[treal] then
  6364.                 write(dblcast);
  6365.             eexpr(tp^.taparm);
  6366.             write(')')
  6367.             end;
  6368.           dcos,
  6369.           dsin,
  6370.           dsqrt:
  6371.             begin
  6372.             eexpr(tp^.tcall);    (* LIB *)
  6373.             write('(');
  6374.             if typeof(tp^.taparm) <> typnods[treal] then
  6375.                 write(dblcast);
  6376.             eexpr(tp^.taparm);
  6377.             write(')')
  6378.             end;
  6379.           dtan:
  6380.             begin
  6381.             write('atan(');        (* LIB *)
  6382.             if typeof(tp^.taparm) <> typnods[treal] then
  6383.                 write(dblcast);
  6384.             eexpr(tp^.taparm);
  6385.             write(')')
  6386.             end;
  6387.           dsucc,
  6388.           dpred:
  6389.             begin
  6390.             tq := typeof(tp^.taparm);
  6391.             if tq^.tt = nsubrange then
  6392.                 if tq^.tup^.tt = nconfarr then
  6393.                     tq := typeof(tq^.tup^.tindtyp)
  6394.                 else
  6395.                     tq := typeof(tq^.tlo);
  6396.             if (tq = typnods[tinteger]) or
  6397.                         (tq = typnods[tchar]) then
  6398.                 begin
  6399.                 write('((');
  6400.                 eexpr(tp^.taparm);
  6401.                 if td = dpred then
  6402.                     write(')-1)')
  6403.                 else
  6404.                     write(')+1)')
  6405.                 end
  6406.             else begin
  6407.                 (* some sort of scalar type, casting needed *)
  6408.                 write('(');
  6409.                 tq := tq^.tup;
  6410.                 if tq^.tt = ntype then
  6411.                     begin
  6412.                     (* cast only if it is a named type *)
  6413.                     write('(');
  6414.                     printid(tq^.tidl^.tsym^.lid);
  6415.                     write(')')
  6416.                     end;
  6417.                 write('((int)(');
  6418.                 eexpr(tp^.taparm);
  6419.                 if td = dpred then
  6420.                     write(')-1))')
  6421.                 else
  6422.                     write(')+1))')
  6423.                  end
  6424.             end;
  6425.           dodd:
  6426.             begin
  6427.             write('(');
  6428.             printid(defnams[dboolean]^.lid);
  6429.             write(')((');
  6430.             eexpr(tp^.taparm);
  6431.             write(') & 1)')
  6432.             end;
  6433.           dsqr:
  6434.             begin
  6435.             tq := typeof(tp^.taparm);
  6436.             if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
  6437.                 begin
  6438.                 write('((');
  6439.                 eexpr(tp^.taparm);
  6440.                 write(') * (');
  6441.                 eexpr(tp^.taparm);
  6442.                 write('))')
  6443.                 end
  6444.             else begin
  6445.                 write('pow(');    (* LIB *)
  6446.                 if typeof(tp^.taparm) <> typnods[treal] then
  6447.                     write(dblcast);
  6448.                 eexpr(tp^.taparm);
  6449.                 write(', 2.0)')
  6450.                  end
  6451.             end;
  6452.           dround:
  6453.             begin
  6454.             write('Round(');
  6455.             eexpr(tp^.taparm);
  6456.             write(')')
  6457.             end;
  6458.           dtrunc:
  6459.             begin
  6460.             write('Trunc(');
  6461.             eexpr(tp^.taparm);
  6462.             write(')')
  6463.             end;
  6464.           dpack:
  6465.             begin
  6466.             tq := typeof(tp^.taparm);
  6467.             tx := typeof(tp^.taparm^.tnext^.tnext);
  6468.             write('{    ', registr, inttyp, tab1, '_j, _i = ');
  6469.             if not arithexpr(tp^.taparm^.tnext) then
  6470.                 write('(int)');
  6471.             eexpr(tp^.taparm^.tnext);
  6472.             if tx^.tt = narray then
  6473.                 write(' - ', clower(tq^.taindx):1);
  6474.             writeln(';');
  6475.             indent;
  6476.             write('    for (_j = 0; _j < ');
  6477.             if tq^.tt = nconfarr then
  6478.                 begin
  6479.                 write('(int)(');
  6480.                 printid(tx^.tcindx^.thi^.tsym^.lid);
  6481.                 write(')')
  6482.                 end
  6483.             else
  6484.                 write(crange(tx^.taindx):1);
  6485.             writeln('; )');
  6486.             indent;
  6487.             write(tab1);
  6488.             eexpr(tp^.taparm^.tnext^.tnext);
  6489.             write('.A[_j++] = ');
  6490.             eexpr(tp^.taparm);
  6491.             writeln('.A[_i++];');
  6492.             indent;
  6493.             writeln('}')
  6494.             end;
  6495.           dunpack:
  6496.             begin
  6497.             tq := typeof(tp^.taparm);
  6498.             tx := typeof(tp^.taparm^.tnext);
  6499.             write('{   ', registr, inttyp, tab1, '_j, _i = ');
  6500.             if not arithexpr(tp^.taparm^.tnext^.tnext) then
  6501.                 write('(int)');
  6502.             eexpr(tp^.taparm^.tnext^.tnext);
  6503.             if tx^.tt <> nconfarr then
  6504.                 write(' - ', clower(tx^.taindx):1);
  6505.             writeln(';');
  6506.             indent;
  6507.             write('    for (_j = 0; _j < ');
  6508.             if tq^.tt = nconfarr then
  6509.                 begin
  6510.                 write('(int)(');
  6511.                 printid(tq^.tcindx^.thi^.tsym^.lid);
  6512.                 write(')')
  6513.                 end
  6514.             else
  6515.                 write(crange(tq^.taindx):1);
  6516.             writeln('; )');
  6517.             indent;
  6518.             write(tab1);
  6519.             eexpr(tp^.taparm^.tnext);
  6520.             write('.A[_i++] = ');
  6521.             eexpr(tp^.taparm);
  6522.             writeln('.A[_j++];');
  6523.             indent;
  6524.             writeln('}')
  6525.             end;
  6526.         end (* case *)
  6527.     end;    (* epredef *)
  6528.  
  6529.     procedure eaddr(tp : treeptr);
  6530.  
  6531.     begin
  6532.         write('&');
  6533.         if not(tp^.tt in [nid, nselect, nindex, nderef]) then
  6534.             error(evarpar);
  6535.         eexpr(tp)
  6536.     end;
  6537.  
  6538.     (*    Emit code for a subroutine call.            *)
  6539.     procedure ecall(tp : treeptr);
  6540.  
  6541.     var    tf, tq, tx    : treeptr;
  6542.  
  6543.     begin
  6544.         (* find first formal parameter id *)
  6545.         tf := idup(tp^.tcall);
  6546.         case tf^.tt of
  6547.           nproc,
  6548.           nfunc:
  6549.             tf := tf^.tsubpar;
  6550.           nparproc,
  6551.           nparfunc:
  6552.             tf := tf^.tparparm
  6553.         end;(* case *)
  6554.         if tf <> nil then
  6555.             begin
  6556.             case tf^.tt of
  6557.               nvalpar,
  6558.               nvarpar:
  6559.                 tf := tf^.tidl;
  6560.               nparproc,
  6561.               nparfunc:
  6562.                 tf := tf^.tparid
  6563.             end (* case *)
  6564.             end;
  6565.         (* emit called function name *)
  6566.         eexpr(tp^.tcall);
  6567.         write('(');
  6568.         (* emit actual parameters *)
  6569.         tq := tp^.taparm;
  6570.         while tq <> nil do
  6571.             begin
  6572.             if tf^.tup^.tt in [nparfunc, nparproc] then
  6573.                 begin
  6574.                 (* single subroutine-nid converted to ncall *)
  6575.                 if tq^.tt = ncall then
  6576.                     printid(tq^.tcall^.tsym^.lid)
  6577.                 else
  6578.                     printid(tq^.tsym^.lid)
  6579.                 end
  6580.             else begin
  6581.                 tx := typeof(tq);
  6582.                 if tx = typnods[tboolean] then
  6583.                     begin
  6584.                     tx := tq;
  6585.                     while tx^.tt = nuplus do
  6586.                         tx := tx^.texps;
  6587.                     if tx^.tt in [nin .. nor, nand, nnot]
  6588.                                     then
  6589.                         begin
  6590.                         write('(');
  6591.                         printid(defnams[dboolean]^.lid);
  6592.                         write(')(');
  6593.                         eexpr(tq);
  6594.                         write(')')
  6595.                         end
  6596.                     else if tf^.tup^.tt = nvarpar then
  6597.                         eaddr(tq)
  6598.                     else
  6599.                         eexpr(tq)
  6600.                     end
  6601.                 else if tx = typnods[tset] then
  6602.                     begin
  6603.                     write('*((');
  6604.                     etypedef(tf^.tup^.tbind);
  6605.                     write(' *)');
  6606.                     dropset := true;
  6607.                     if align then
  6608.                         begin
  6609.                         usesal := true;
  6610.                         write('SETALIGN(');
  6611.                         eexpr(tq);
  6612.                         write(')')
  6613.                         end
  6614.                     else
  6615.                         eexpr(tq);
  6616.                     dropset := false;
  6617.                     write(')')
  6618.                     end
  6619.                 else if tx = typnods[tstring] then
  6620.                     begin
  6621.                     write('*((');
  6622.                     etypedef(tf^.tup^.tbind);
  6623.                     write(' *)');
  6624.                     if align then
  6625.                         begin
  6626.                         usealig := true;
  6627.                         write('STRALIGN(');
  6628.                         eexpr(tq);
  6629.                         write(')')
  6630.                         end
  6631.                     else
  6632.                         eexpr(tq);
  6633.                     write(')')
  6634.                     end
  6635.                 else if tx = typnods[tnil] then
  6636.                     begin
  6637.                     write('(');
  6638.                     etypedef(tf^.tup^.tbind);
  6639.                     write(')NIL')
  6640.                     end
  6641.                 else if tf^.tup^.tbind^.tt = nconfarr then
  6642.                     begin
  6643.                     write('(struct ');
  6644.                     printid(tf^.tup^.tbind^.tcuid);
  6645.                     write(' *)&');
  6646.                     eexpr(tq);
  6647.                     (* add upper bound of actual value *)
  6648.                     if tq^.tnext = nil then
  6649.                         begin
  6650.                         write(', (');
  6651.                         eexpr(tx^.taindx^.thi);
  6652.                         write(' - ');
  6653.                         eexpr(tx^.taindx^.tlo);
  6654.                         write(' + 1)')
  6655.                         end
  6656.                     end
  6657.                 else begin
  6658.                     if tf^.tup^.tt = nvarpar then
  6659.                         eaddr(tq)
  6660.                     else
  6661.                         eexpr(tq)
  6662.                      end
  6663.                 end;
  6664.             tq := tq^.tnext;
  6665.             if tq <> nil then
  6666.                 begin
  6667.                 write(', ');
  6668.                 (* next formal parameter *)
  6669.                 if tf^.tnext = nil then
  6670.                     begin
  6671.                     tf := tf^.tup^.tnext;
  6672.                     case tf^.tt of
  6673.                       nvalpar,
  6674.                       nvarpar:
  6675.                         tf := tf^.tidl;
  6676.                       nparproc,
  6677.                       nparfunc:
  6678.                         tf := tf^.tparid
  6679.                     end (* case *)
  6680.                     end
  6681.                 else
  6682.                     tf := tf^.tnext;
  6683.                 end;
  6684.             end;
  6685.         write(')')
  6686.     end;    (* ecall *)
  6687.  
  6688.     (*    Emit code for a general expression.            *)
  6689.     procedure eexpr;
  6690.  
  6691.     label    999;
  6692.  
  6693.     var    tq    : treeptr;
  6694.         flag    : boolean;
  6695.  
  6696.         function constset(tp : treeptr) : boolean;
  6697.  
  6698.             function constxps(tp : treeptr) : boolean;
  6699.             begin
  6700.                 case tp^.tt of
  6701.                   nrange:
  6702.                     if constxps(tp^.texpr) then
  6703.                         constxps := constxps(tp^.texpl)
  6704.                     else
  6705.                         constxps := false;
  6706.                   nempty,
  6707.                   ninteger,
  6708.                   nchar:
  6709.                     constxps := true;
  6710.                   nid:
  6711.                     begin
  6712.                     tp := idup(tp);
  6713.                     constxps := (tp^.tt = nconst)
  6714.                             or (tp^.tt = nscalar)
  6715.                     end;
  6716.                   nin, neq, nne, nlt, nle, ngt, nge, nor,
  6717.                   nplus, nminus, nand, nmul, ndiv, nmod,
  6718.                   nquot, nnot, numinus, nuplus, nset,    
  6719.                   nindex, nselect, nderef, ncall,
  6720.                   nreal, nstring, nnil:
  6721.                     constxps := false
  6722.                 end (* case *)
  6723.             end;
  6724.  
  6725.         begin
  6726.             constset := true;
  6727.             while tp <> nil do
  6728.                 if constxps(tp) then
  6729.                     tp := tp^.tnext
  6730.                 else begin
  6731.                     constset := false;
  6732.                     tp := nil
  6733.                     end
  6734.         end;
  6735.  
  6736.     begin    (* eexpr *)
  6737.         if tp^.tt in [nplus, nminus, nmul, nle, nge, neq, nne] then
  6738.             begin
  6739.             tq := typeof(tp^.texpl);
  6740.             if (tq^.tt in [nset, nsetof]) or
  6741.                         (tq = typnods[tset]) then
  6742.                 begin
  6743.                 (* set operations *)
  6744.                 case tp^.tt of
  6745.                   nplus:
  6746.                     begin
  6747.                     setused := true;
  6748.                     useunion := true;
  6749.                     write('Union')
  6750.                     end;
  6751.                   nminus:
  6752.                     begin
  6753.                     setused := true;
  6754.                     usediff := true;
  6755.                     write('Diff')
  6756.                     end;
  6757.                   nmul:
  6758.                     begin
  6759.                     setused := true;
  6760.                     useintr := true;
  6761.                     write('Inter')
  6762.                     end;
  6763.                   neq:
  6764.                     begin
  6765.                     useseq := true;
  6766.                     write('Eq')
  6767.                     end;
  6768.                   nne:
  6769.                     begin
  6770.                     usesne := true;
  6771.                     write('Ne')
  6772.                     end;
  6773.                   nge:
  6774.                     begin
  6775.                     usesge := true;
  6776.                     write('Ge')
  6777.                     end;
  6778.                   nle:
  6779.                     begin
  6780.                     usesle := true;
  6781.                     write('Le')
  6782.                     end
  6783.                 end;(* case *)
  6784.                 if tp^.tt in [nplus, nminus, nmul] then
  6785.                     dropset := false;
  6786.                 write('(');
  6787.                 eexpr(tp^.texpl);
  6788.                 if tq^.tt = nsetof then
  6789.                     write('.S');
  6790.                 write(', ');
  6791.                 eexpr(tp^.texpr);
  6792.                 tq := typeof(tp^.texpr);
  6793.                 if tq^.tt = nsetof then
  6794.                     write('.S');
  6795.                 write(')');
  6796.                 goto 999
  6797.                 end
  6798.             end;
  6799.         if tp^.tt in [neq, nne, ngt, nlt, nge, nle] then
  6800.             begin
  6801.             tq := typeof(tp^.texpl);
  6802.             if tq^.tt = nconfarr then
  6803.                 fatal(ecmpconf);
  6804.             if (tq^.tt in [nstring, narray]) or
  6805.                         (tq = typnods[tstring]) then
  6806.                 begin
  6807.                 write('Cmpstr(');
  6808.                 eexpr(tp^.texpl);
  6809.                 if tq^.tt = narray then
  6810.                     write('.A');
  6811.                 write(', ');
  6812.                 tq := typeof(tp^.texpr);
  6813.                 if tq^.tt = nconfarr then
  6814.                     fatal(ecmpconf);
  6815.                 eexpr(tp^.texpr);
  6816.                 if tq^.tt = narray then
  6817.                     write('.A');
  6818.                 write(')');
  6819.                 case tp^.tt of
  6820.                   neq:
  6821.                     write(' == ');
  6822.                   nne:
  6823.                     write(' != ');
  6824.                   ngt:
  6825.                     write(' > ');
  6826.                   nlt:
  6827.                     write(' < ');
  6828.                   nge:
  6829.                     write(' >= ');
  6830.                   nle:
  6831.                     write(' <= ');
  6832.                 end;(* case *)
  6833.                 write('0');
  6834.                 goto 999
  6835.                 end
  6836.             end;
  6837.         case tp^.tt of
  6838.           neq, nne, nlt, nle,
  6839.           ngt, nge, nor, nand, nplus, nminus,
  6840.           nmul, ndiv, nmod, nquot:
  6841.             begin
  6842.             flag := cprio[tp^.tt] > cprio[tp^.texpl^.tt];
  6843.             if ((tp^.tt in [nlt, nle, ngt, nge]) and
  6844.                     not arithexpr(tp^.texpl))
  6845.             or (needsintcast(tp^.texpl)) then
  6846.                 begin
  6847.                 write('(int)');
  6848.                 flag := true
  6849.                 end;
  6850.             if flag then
  6851.                 write('(');
  6852.             eexpr(tp^.texpl);
  6853.             if flag then
  6854.                 write(')');
  6855.             case tp^.tt of
  6856.               neq:
  6857.                 write(' == ');
  6858.               nne:
  6859.                 write(' != ');
  6860.               nlt:
  6861.                 write(' < ');
  6862.               nle:
  6863.                 write(' <= ');
  6864.               ngt:
  6865.                 write(' > ');
  6866.               nge:
  6867.                 write(' >= ');
  6868.               nor:
  6869.                 write(' || ');
  6870.               nand:
  6871.                 write(' && ');
  6872.               nplus:
  6873.                 write(' + ');
  6874.               nminus:
  6875.                 write(' - ');
  6876.               nmul:
  6877.                 write(' * ');
  6878.               ndiv:
  6879.                 write(' / ');
  6880.               nmod:
  6881.                 write(' % ');
  6882.               nquot:
  6883.                 begin
  6884.                 write(' / ((');
  6885.                 printid(defnams[dreal]^.lid);
  6886.                 write(')')
  6887.                 end
  6888.             end;(* case *)
  6889.             flag := cprio[tp^.tt] > cprio[tp^.texpr^.tt];
  6890.             if ((tp^.tt in [nlt, nle, ngt, nge]) and
  6891.                     not arithexpr(tp^.texpr))
  6892.             or (needsintcast(tp^.texpr)) then
  6893.                 begin
  6894.                 write('(int)');
  6895.                 flag := true
  6896.                 end;
  6897.             if flag then
  6898.                 write('(');
  6899.             eexpr(tp^.texpr);
  6900.             if flag then
  6901.                 write(')');
  6902.             if tp^.tt = nquot then
  6903.                 write(')')
  6904.             end;
  6905.  
  6906.           nuplus, numinus, nnot:
  6907.             begin
  6908.             case tp^.tt of
  6909.               numinus:
  6910.                 write('-');
  6911.               nnot:
  6912.                 write('!');
  6913.               nuplus:
  6914.             end;(* case *)
  6915.             flag := cprio[tp^.tt] >= cprio[tp^.texps^.tt];
  6916.             if flag then
  6917.                 write('(');
  6918.             eexpr(tp^.texps);
  6919.             if flag then
  6920.                 write(')');
  6921.             end;
  6922.           
  6923.           nin:
  6924.             begin
  6925.             usememb := true;
  6926.             write('Member((unsigned)(');
  6927.             eexpr(tp^.texpl);
  6928.             write('), ');
  6929.             dropset := true;    (* no need to save set-expr *)
  6930.             eexpr(tp^.texpr);
  6931.             dropset := false;
  6932.             tq := typeof(tp^.texpr);
  6933.             if tq^.tt = nsetof then
  6934.                 write('.S');
  6935.             write(')')
  6936.             end;
  6937.  
  6938.           nassign:
  6939.             begin
  6940.             tq := typeof(tp^.trhs);
  6941.             if tq = typnods[tstring] then
  6942.                 begin
  6943.                 write(voidcast, 'strncpy((char *)');
  6944.                 eexpr(tp^.tlhs);
  6945.                 write('.A, ');
  6946.                 eexpr(tp^.trhs);
  6947.                 write(', sizeof(');
  6948.                 eexpr(tp^.tlhs);
  6949.                 write('.A))')
  6950.                 end
  6951.             else if tq = typnods[tboolean] then
  6952.                 begin
  6953.                 eexpr(tp^.tlhs);
  6954.                 write(' = ');
  6955.                 tq := tp^.trhs;
  6956.                 while tq^.tt = nuplus do
  6957.                     tq := tq^.texps;
  6958.                 if tq^.tt in [nin .. nor, nand, nnot] then
  6959.                     begin
  6960.                     write('(');
  6961.                     printid(defnams[dboolean]^.lid);
  6962.                     write(')(');
  6963.                     eexpr(tq);
  6964.                     write(')')
  6965.                     end
  6966.                 else
  6967.                     eexpr(tq)
  6968.                 end
  6969.             else if tq = typnods[tnil] then
  6970.                 begin
  6971.                 eexpr(tp^.tlhs);
  6972.                 write(' = (');
  6973.                 etypedef(typeof(tp^.tlhs));
  6974.                 write(')NIL')
  6975.                 end
  6976.             else begin
  6977.                 tq := typeof(tp^.tlhs);
  6978.                 if tq^.tt = nsetof then
  6979.                     begin
  6980.                     usescpy := true;
  6981.                     write('Setncpy(');
  6982.                     eselect(tp^.tlhs);
  6983.                     write('S, ');
  6984.                     dropset := true;
  6985.                     tq := typeof(tp^.trhs);
  6986.                     if tq = typnods[tset] then
  6987.                         eexpr(tp^.trhs)
  6988.                     else begin
  6989.                         eselect(tp^.trhs);
  6990.                         write('S')
  6991.                          end;
  6992.                     dropset := false;
  6993.                     write(', sizeof(');
  6994.                     eselect(tp^.tlhs);
  6995.                     write('S))')
  6996.                     end
  6997.                 else begin
  6998.                     eexpr(tp^.tlhs);
  6999.                     write(' = ');
  7000.                     eexpr(tp^.trhs)
  7001.                      end
  7002.                  end
  7003.             end;
  7004.  
  7005.           ncall:
  7006.             begin
  7007.             tq := idup(tp^.tcall);
  7008.             if (tq^.tt in [nfunc, nproc]) and
  7009.                     (tq^.tsubstmt <> nil) then
  7010.                 if tq^.tsubstmt^.tt = npredef then
  7011.                     epredef(tq, tp)
  7012.                 else
  7013.                     ecall(tp)
  7014.             else
  7015.                 ecall(tp)
  7016.             end;
  7017.  
  7018.           nselect:
  7019.             begin
  7020.             eselect(tp^.trecord);
  7021.             eexpr(tp^.tfield)
  7022.             end;
  7023.           nindex:
  7024.             begin
  7025.             eselect(tp^.tvariable);
  7026.             write('A[');
  7027.             tq := tp^.toffset;
  7028.             if arithexpr(tq) then
  7029.                 eexpr(tq)
  7030.             else begin
  7031.                 write('(int)(');
  7032.                 eexpr(tq);
  7033.                 write(')')
  7034.                  end;
  7035.             tq := typeof(tp^.tvariable);
  7036.             if tq^.tt = narray then
  7037.                 if clower(tq^.taindx) <> 0 then
  7038.                     begin
  7039.                     write(' - ');
  7040.                     tq := typeof(tq^.taindx);
  7041.                     if tq^.tt = nsubrange then
  7042.                         if arithexpr(tq^.tlo) then
  7043.                             eexpr(tq^.tlo)
  7044.                         else begin
  7045.                             write('(int)(');
  7046.                             eexpr(tq^.tlo);
  7047.                             write(')')
  7048.                              end
  7049.                     else 
  7050.                         fatal(etree)
  7051.                     end;
  7052.             write(']')
  7053.             end;
  7054.           nderef:
  7055.             begin
  7056.             tq := typeof(tp^.texps);
  7057.             if (tq^.tt = nfileof) or
  7058.                  ((tq^.tt = npredef) and (tq^.tdef = dtext)) then
  7059.                 begin
  7060.                 (* using a file-variable as pointer *)
  7061.                 if tp^.tisassigndest then
  7062.                     begin
  7063.                     eexpr(tp^.texps);
  7064.                     write('.buf');
  7065.                     end
  7066.                 else
  7067.                     begin
  7068.                     if (tq^.tdef = dtext) then
  7069.                         write('Bufx(')
  7070.                     else
  7071.                         write('Buf(');
  7072.                     eexpr(tp^.texps);
  7073.                     write(')')
  7074.                     end
  7075.                 end
  7076.             else begin
  7077.                 write('(*');
  7078.                 eexpr(tp^.texps);
  7079.                 write(')')
  7080.                  end
  7081.             end;
  7082.           nid:
  7083.             begin
  7084.             (* add pointer-dereference if this id is declared as a
  7085.                var-parameter or as a procedure-parameter *)
  7086.             tq := idup(tp);
  7087.             if tq^.tt = nvarpar then
  7088.                      begin
  7089.                     write('(*');
  7090.                     printid(tp^.tsym^.lid);
  7091.                     write(')')
  7092.                      end
  7093.             else if (tq^.tt = nconst) and conflag then
  7094.                 write(cvalof(tp):1)
  7095.             else if tq^.tt in [nparproc, nparfunc] then
  7096.                 begin
  7097.                 write('(*');
  7098.                 printid(tp^.tsym^.lid);
  7099.                 write(')')
  7100.                 end
  7101.             else
  7102.                 printid(tp^.tsym^.lid);
  7103.             end;
  7104.           nchar:
  7105.             printchr(tp^.tsym^.lchar);
  7106.           ninteger:
  7107.             write(tp^.tsym^.linum:1);
  7108.           nreal:
  7109.             printtok(tp^.tsym^.lfloat);
  7110.           nstring:
  7111.             printstr(tp^.tsym^.lstr);
  7112.           nset:
  7113.             if constset(tp^.texps) then
  7114.                 begin
  7115.                 (* save set expression for initialization *)
  7116.                 write('Conset[', setcnt:1, ']');
  7117.                 setcnt := setcnt + 1;
  7118.                 tq := mknode(nset);
  7119.                 tq^.tnext := setlst;
  7120.                 setlst := tq;
  7121.                 tq^.texps := tp^.texps
  7122.                 end
  7123.             else begin
  7124.                 increment;
  7125.                 flag := dropset;
  7126.                 (* if a set-constructor is used in an
  7127.                    expression involving + - *  it will need to
  7128.                    be saved temporarily (by Saveset) but often
  7129.                    we can simply forget the set-value when we
  7130.                    have finished using it *)
  7131.                 if dropset then
  7132.                     dropset := false
  7133.                 else
  7134.                     write('Saveset(');
  7135.                 write('(Tmpset = Newset(), ');
  7136.                 tq := tp^.texps;
  7137.                 while tq <> nil do
  7138.                     begin
  7139.                     case tq^.tt of
  7140.                       nrange:
  7141.                         begin
  7142.                         usemksub := true;
  7143.                         write(voidcast, 'Mksubr(');
  7144.                         write('(unsigned)(');
  7145.                         eexpr(tq^.texpl);
  7146.                         write('), ');
  7147.                         write('(unsigned)(');
  7148.                         eexpr(tq^.texpr);
  7149.                         write('), Tmpset)')
  7150.                         end;
  7151.                       nin, neq, nne, nlt, nle, ngt, nge,
  7152.                       nor, nand, nmul, ndiv, nmod, nquot,
  7153.                       nplus, nminus, nnot, numinus, nuplus, 
  7154.                       nindex, nselect, nderef, ncall,
  7155.                       ninteger, nchar, nid:
  7156.                         begin
  7157.                         useins := true;
  7158.                         write(voidcast, 'Insmem(');
  7159.                         write('(unsigned)(');
  7160.                         eexpr(tq);
  7161.                         write('), Tmpset)')
  7162.                         end
  7163.                     end;(* case *)
  7164.                     tq := tq^.tnext;
  7165.                     if tq <> nil then
  7166.                         begin
  7167.                         writeln(',');
  7168.                         indent
  7169.                         end
  7170.                     end;
  7171.                 write(', Tmpset)');
  7172.                 if not flag then
  7173.                     begin
  7174.                     write(')');
  7175.                     setused := true
  7176.                     end;
  7177.                 decrement
  7178.                  end;
  7179.           nnil:
  7180.             begin
  7181.             tq := tp;
  7182.             repeat
  7183.                 tq := tq^.tup
  7184.             until    tq^.tt in [neq, nne, ncall, nassign, npgm];
  7185.             if tq^.tt in [neq, nne] then
  7186.                 begin
  7187.                 if typeof(tq^.texpl) = typnods[tnil] then
  7188.                     tq := typeof(tq^.texpr)
  7189.                 else
  7190.                     tq := typeof(tq^.texpl);
  7191.                 if tq^.tt = nptr then
  7192.                     begin
  7193.                     write('(');
  7194.                     etypedef(tq);
  7195.                     write(')')
  7196.                     end
  7197.                 end;
  7198.             write('NIL')
  7199.             end;
  7200.         end;(* case *)
  7201.     999:
  7202.     end;    (* eexpr *)
  7203.  
  7204.     (*    Emit constant definitions.                *)
  7205.     procedure econst(tp : treeptr);
  7206.  
  7207.     var    sp    : symptr;
  7208.  
  7209.     begin
  7210.         while tp <> nil do
  7211.             begin
  7212.             sp := tp^.tidl^.tsym;
  7213.             if sp^.lid^.inref > 1 then
  7214.                 sp^.lid := mkrename('X', sp^.lid);
  7215.             if tp^.tbind^.tt = nstring then
  7216.                 begin
  7217.                 (* string constants emitted as
  7218.                    static local variables *)
  7219.                 indent;
  7220.                 write(static, chartyp, tab1);
  7221.                 printid(sp^.lid);
  7222.                 write('[]    = ');
  7223.                 eexpr(tp^.tbind);
  7224.                 writeln(';')
  7225.                 end
  7226.             else begin
  7227.                 (* all other constants emitted as
  7228.                    preprocessor # defines *)
  7229.                 write(define);
  7230.                 printid(sp^.lid);
  7231.                 write(space);
  7232.                 eexpr(tp^.tbind);
  7233.                 writeln
  7234.                 end;
  7235.             tp := tp^.tnext
  7236.             end
  7237.     end;    (* econst *)
  7238.  
  7239.     (*    Undefine constants.                    *)
  7240.     procedure edconst(tp : treeptr);
  7241.  
  7242.     var    sp    : symptr;
  7243.  
  7244.     begin
  7245.         while tp <> nil do
  7246.             begin
  7247.             sp := tp^.tidl^.tsym;
  7248.             if tp^.tbind^.tt <> nstring then
  7249.                 begin
  7250.                 (* all non-strings are emitted as
  7251.                    preprocessor # defines *)
  7252.                 write(undef);
  7253.                 printid(sp^.lid);
  7254.                 writeln
  7255.                 end;
  7256.             tp := tp^.tnext
  7257.             end
  7258.     end;    (* edconst *)
  7259.  
  7260.  
  7261.     (*    Emit a typedef.                        *)
  7262.     procedure etypedef;
  7263.  
  7264.         (*    Workhorse for etypedef, this procedure also    *)
  7265.         (*    renames all fields in record-unions when    *)
  7266.         (*    necessary.                    *)
  7267.         procedure etdef(uid : idptr; tp : treeptr);
  7268.  
  7269.         var    i    : integer;
  7270.             tq    : treeptr;
  7271.  
  7272.             (*    Emit definition for an integer subrange    *)
  7273.             (*    using data from worddefs set up during    *)
  7274.             (*    initialization.                *)
  7275.             procedure etrange(tp : treeptr);
  7276.  
  7277.             label    999;
  7278.  
  7279.             var    lo, hi    : integer;
  7280.                 i    : 1 .. maxmachdefs;
  7281.  
  7282.             begin
  7283.                 lo := clower(tp);
  7284.                 hi := cupper(tp);
  7285.                 (* scan CPU word definitions for a type
  7286.                    enclosing wanted range *)
  7287.                 for i := 1 to nmachdefs do
  7288.                     with machdefs[i] do
  7289.                     if (lo >= lolim) and (hi <= hilim) then
  7290.                         begin
  7291.                         (* found it, print type name *)
  7292.                         printtok(typstr);
  7293.                         goto 999
  7294.                         end;
  7295.                 fatal(erange);
  7296.             999:
  7297.             end;
  7298.  
  7299.             (*    Print last component of identifier.    *)
  7300.             procedure printsuf(ip : idptr);
  7301.  
  7302.             var    w    : toknbuf;
  7303.                 i, j    : toknidx;
  7304.  
  7305.             begin
  7306.                 gettokn(ip^.istr, w);
  7307.                 i := 1;
  7308.                 j := i;
  7309.                 while w[i] <> chr(null) do
  7310.                     begin
  7311.                     if w[i] = '.' then
  7312.                         j := i;
  7313.                     i := i + 1
  7314.                     end;
  7315.                 if w[j] = '.' then
  7316.                     j := j + 1;
  7317.                 while w[j] <> chr(null) do
  7318.                     begin
  7319.                     write(w[j]);
  7320.                     j := j + 1
  7321.                     end
  7322.             end;
  7323.  
  7324.         begin    (* etdef *)
  7325.             case tp^.tt of
  7326.               nid:
  7327.                 (* Could we test this in a simpler way? *)
  7328.                     if tp^.tsym^.lsymdecl
  7329.                     = typnods[tchar]^.tup^.tidl then
  7330.                       write(chartyp)
  7331.                 else
  7332.                     printid(tp^.tsym^.lid);
  7333.               nptr:
  7334.                 begin
  7335.                 tq := typeof(tp^.tptrid);
  7336.                 if tq^.tt = nrecord then
  7337.                     begin
  7338.                     write('struct ');
  7339.                     printid(tq^.tuid)
  7340.                     end
  7341.                 else
  7342.                     printid(tp^.tptrid^.tsym^.lid);
  7343.                 write(' *');
  7344.                 end;
  7345.               nscalar:
  7346.                 begin
  7347.                 write('enum { ');
  7348.                 increment;
  7349.                 tp := tp^.tscalid;
  7350.  
  7351.                 (* avoid bug in C-compiler:
  7352.                        enums are mixed in same namespace *)
  7353.                 if tp^.tsym^.lid^.inref > 1 then
  7354.                     tp^.tsym^.lid :=
  7355.                         mkrename('E', tp^.tsym^.lid);
  7356.                 printid(tp^.tsym^.lid);
  7357.                 i := 1;
  7358.                 while tp^.tnext <> nil do
  7359.                     begin
  7360.                     if i >= 4 then
  7361.                         begin
  7362.                         writeln(',');
  7363.                         indent;
  7364.                         i := 1
  7365.                         end
  7366.                     else begin
  7367.                         write(', ');
  7368.                         i := i + 1
  7369.                          end;
  7370.                     tp := tp^.tnext;
  7371.                     if tp^.tsym^.lid^.inref > 1 then
  7372.                         tp^.tsym^.lid :=
  7373.                         mkrename('E', tp^.tsym^.lid);
  7374.                     printid(tp^.tsym^.lid)
  7375.                     end;
  7376.                 decrement;
  7377.                 write(' } ')
  7378.                 end;
  7379.               nsubrange:
  7380.                 begin
  7381.                 tq := typeof(tp^.tlo);
  7382.                 if tq = typnods[tinteger] then
  7383.                     etrange(tp)
  7384.                 else begin
  7385.                     if tq^.tup^.tt = ntype then
  7386.                         tq := tq^.tup^.tidl;
  7387.                     etdef(nil, tq)
  7388.                      end
  7389.                 end;
  7390.               nfield:
  7391.                 begin
  7392.                 etdef(nil, tp^.tbind);
  7393.                 write(tab1);
  7394.                 tp := tp^.tidl;
  7395.                 if uid <> nil then
  7396.                     tp^.tsym^.lid :=
  7397.                         mkconc('.', uid, tp^.tsym^.lid);
  7398.                 printsuf(tp^.tsym^.lid);
  7399.                 i := 1;
  7400.                 while tp^.tnext <> nil do
  7401.                     begin
  7402.                     if i >= 4 then
  7403.                         begin
  7404.                         writeln(',');
  7405.                         indent;
  7406.                         write(tab1);
  7407.                         i := 1
  7408.                         end
  7409.                     else begin
  7410.                         write(', ');
  7411.                         i := i + 1
  7412.                          end;
  7413.                     tp := tp^.tnext;
  7414.                     if uid <> nil then
  7415.                         tp^.tsym^.lid :=
  7416.                         mkconc('.', uid, tp^.tsym^.lid);
  7417.                     printsuf(tp^.tsym^.lid);
  7418.                     end;
  7419.                 writeln(';');
  7420.                 end;
  7421.               nrecord:
  7422.                 begin
  7423.                 write('struct ');
  7424.                 if tp^.tuid = nil then
  7425.                     tp^.tuid := uid
  7426.                 else if uid = nil then
  7427.                     printid(tp^.tuid);
  7428.                 writeln(' {');
  7429.                 increment;
  7430.                 if (tp^.tflist = nil) and
  7431.                             (tp^.tvlist = nil) then
  7432.                     begin
  7433.                     (* C doesn't allow empty structures *)
  7434.                     indent;
  7435.                     writeln(inttyp, tab1, 'dummy;')
  7436.                     end;
  7437.                 tq := tp^.tflist;
  7438.                 while tq <> nil do
  7439.                     begin
  7440.                     indent;
  7441.                     etdef(uid, tq);
  7442.                     tq := tq^.tnext
  7443.                     end;
  7444.                 if tp^.tvlist <> nil then
  7445.                     begin
  7446.                     indent;
  7447.                     writeln('union {');
  7448.                     increment;
  7449.                     tq := tp^.tvlist;
  7450.                     while tq <> nil do
  7451.                         begin
  7452.                         if (tq^.tvrnt^.tflist <> nil) or
  7453.                          (tq^.tvrnt^.tvlist <> nil) then
  7454.                             begin
  7455.                             indent;
  7456.                             if uid = nil then
  7457.                                 etdef(mkvrnt,
  7458.                                 tq^.tvrnt)
  7459.                             else
  7460.                                 etdef(mkconc('.',
  7461.                                    uid, mkvrnt),
  7462.                                 tq^.tvrnt);
  7463.                             writeln(';')
  7464.                             end;
  7465.                         tq := tq^.tnext
  7466.                         end;
  7467.                     decrement;
  7468.                     indent;
  7469.                     writeln('} U;');
  7470.                     end;
  7471.                 decrement;
  7472.                 indent;
  7473.                 if tp^.tup^.tt = nvariant then
  7474.                     begin
  7475.                     write('} ');
  7476.                     printsuf(tp^.tuid)
  7477.                     end
  7478.                 else
  7479.                     write('}');
  7480.                 end;
  7481.               nconfarr:
  7482.                 begin
  7483.                 write('struct ');
  7484.                 printid(tp^.tcuid);
  7485.                 write(' { ');
  7486.                 etdef(nil, tp^.tcelem);
  7487.                 write(tab1, 'A[]; }')
  7488.                 end;
  7489.               narray:
  7490.                 begin
  7491.                 write('struct { ');
  7492.                 etdef(nil, tp^.taelem);
  7493.                 write(tab1, 'A[');
  7494.                 tq := typeof(tp^.taindx);
  7495.                 if tq^.tt = nsubrange then
  7496.                     begin
  7497.                     if arithexpr(tq^.thi) then
  7498.                         begin
  7499.                         eexpr(tq^.thi);
  7500.                         if cvalof(tq^.tlo) <> 0 then
  7501.                             begin
  7502.                             write(' - ');
  7503.                             eexpr(tq^.tlo)
  7504.                             end
  7505.                         end
  7506.                     else begin
  7507.                         write('(int)(');
  7508.                         eexpr(tq^.thi);
  7509.                         if cvalof(tq^.tlo) <> 0 then
  7510.                             begin
  7511.                             write(') - (int)(');
  7512.                             eexpr(tq^.tlo)
  7513.                             end;
  7514.                         write(')')
  7515.                          end;
  7516.                     write(' + 1')
  7517.                     end
  7518.                 else
  7519.                     write(crange(tp^.taindx):1);
  7520.                 write(']; }')
  7521.                 end;
  7522.               nfileof:
  7523.                 begin
  7524.                 writeln('struct {');
  7525.                 indent;
  7526.                 writeln(tab1, 'FILE', tab1, '*fp;');
  7527.                 indent;
  7528.                 writeln(inttyp, tab1, 'bufvalid, eoln, eof, ',
  7529.                     'writable;');
  7530.                 indent;
  7531.                 etdef(nil, tp^.tof);
  7532.                 writeln(tab1, 'buf;');
  7533.                 indent;
  7534.                 writeln(inttyp, tab1, 'auxbuf;');
  7535.                 indent;
  7536.                 write('} ')
  7537.                 end;
  7538.               nsetof:
  7539.                 write('struct { ', setwtyp, tab1, 'S[',
  7540.                             csetsize(tp):1, ']; }');
  7541.               npredef:
  7542.                 begin
  7543.                 case tp^.tobtyp of
  7544.                   tboolean:
  7545.                     printid(defnams[dboolean]^.lid);
  7546.                   tchar:
  7547.                     write(chartyp);
  7548.                   tinteger:
  7549.                     printid(defnams[dinteger]^.lid);
  7550.                   treal:
  7551.                     printid(defnams[dreal]^.lid);
  7552.                   tstring:
  7553.                     write(chartyp, ' *');
  7554.                   ttext:
  7555.                     write('text');
  7556.                   tnil,
  7557.                   tset,
  7558.                   terror:
  7559.                     fatal(etree);
  7560.                   tnone:
  7561.                     write(voidtyp);
  7562.                 end (* case *)
  7563.                 end;
  7564.               nempty:
  7565.                 write(voidtyp);
  7566.             end;(* case *)
  7567.         end;    (* etdef *)
  7568.     begin
  7569.         etdef(nil, tp)
  7570.     end;    (* etypedef *)
  7571.  
  7572.     (*    Emit code for type declarations.            *)
  7573.     procedure etype(tp : treeptr);
  7574.  
  7575.     var    sp    : symptr;
  7576.  
  7577.     begin
  7578.         while tp <> nil do
  7579.             begin
  7580.             (* if identifier used more than once we rename the type
  7581.                to avoid typedef'ing an identifier twice *)
  7582.             sp := tp^.tidl^.tsym;
  7583.             if sp^.lid^.inref > 1 then
  7584.                 sp^.lid := mkrename('Y', sp^.lid);
  7585.             indent;
  7586.             write(typdef);
  7587.             etypedef(tp^.tbind);
  7588.             write(tab1);
  7589.             printid(sp^.lid);
  7590.             writeln(';');
  7591.             tp := tp^.tnext
  7592.             end
  7593.     end;
  7594.  
  7595.     (*    Emit code for variable declarations.            *)
  7596.     procedure evar(tp : treeptr);
  7597.  
  7598.     label    555;
  7599.  
  7600.     var    tq    : treeptr;
  7601.         i    : integer;
  7602.  
  7603.     begin
  7604.         while tp <> nil do
  7605.             begin
  7606.             indent;
  7607.             case tp^.tt of
  7608.               nvar,
  7609.               nvalpar,
  7610.               nvarpar:
  7611.                 begin
  7612.                 if tp^.tattr = aregister then
  7613.                     write(registr);
  7614.                 etypedef(tp^.tbind)
  7615.                 end;
  7616.               nparproc,
  7617.               nparfunc:
  7618.                 begin
  7619.                 if tp^.tt = nparproc then
  7620.                     write(voidtyp)
  7621.                 else
  7622.                     etypedef(tp^.tpartyp);
  7623.                 tq := tp^.tparid;
  7624.                 write(tab1, '(*');
  7625.                 printid(tq^.tsym^.lid);
  7626.                 write(')()');
  7627.                 goto 555
  7628.                 end
  7629.             end;(* case *)
  7630.             write(tab1);
  7631.             tq := tp^.tidl;
  7632.             i := 1;
  7633.             repeat
  7634.                 if tp^.tt = nvarpar then
  7635.                     write('*');
  7636.                 printid(tq^.tsym^.lid);
  7637.                 tq := tq^.tnext;
  7638.                 if tq <> nil then
  7639.                     begin
  7640.                     if i >= 6 then
  7641.                         begin
  7642.                         i := 1;
  7643.                         writeln(',');
  7644.                         indent;
  7645.                         write(tab1)
  7646.                         end
  7647.                     else begin
  7648.                         i := i + 1;
  7649.                         write(', ')
  7650.                          end
  7651.  
  7652.                     end
  7653.             until    tq = nil;
  7654.         555:
  7655.             writeln(';');
  7656.             if tp^.tt = nvarpar then
  7657.                 if tp^.tbind^.tt = nconfarr then
  7658.                     begin
  7659.                     indent;
  7660.                     etypedef(tp^.tbind^.tindtyp);
  7661.                     write(tab1);
  7662.                     tq := tp^.tbind^.tcindx^.thi;
  7663.                     printid(tq^.tsym^.lid);
  7664.                     writeln(';')
  7665.                     end;
  7666.             tp := tp^.tnext
  7667.             end
  7668.     end;    (* evar *)
  7669.  
  7670.     (*    Emit code for a statment.                *)
  7671.     procedure estmt(tp : treeptr);
  7672.  
  7673.     var    tq    : treeptr;
  7674.         locid1,
  7675.         locid2    : idptr;
  7676.         stusd    : boolean;
  7677.         opc1,
  7678.         opc2    : char;
  7679.  
  7680.         (*    Emit typename for with-variable.        *)
  7681.         procedure ewithtype(tp : treeptr);
  7682.  
  7683.         var    tq    : treeptr;
  7684.  
  7685.         begin
  7686.             tq := typeof(tp);
  7687.             write('struct ');
  7688.             printid(tq^.tuid)
  7689.         end;
  7690.  
  7691.         (*    Emit code for a case-choise.        *)
  7692.         procedure echoise(tp : treeptr);
  7693.  
  7694.         var    tq    : treeptr;
  7695.             i    : integer;
  7696.  
  7697.         begin
  7698.             while tp <> nil do
  7699.                 begin
  7700.                 tq := tp^.tchocon;
  7701.                 i := 0;
  7702.                 indent;
  7703.                 while tq <> nil do
  7704.                     begin
  7705.                     write('  case ');
  7706.                     conflag := true;
  7707.                     eexpr(tq);
  7708.                     conflag := false;
  7709.                     write(':');
  7710.                     i := i + 1;
  7711.                     tq := tq^.tnext;
  7712.                     if (tq = nil) or (i mod 4 = 0) then
  7713.                         begin
  7714.                         writeln;
  7715.                         if tq <> nil then
  7716.                             indent;
  7717.                         i := 0
  7718.                         end
  7719.                     end;
  7720.                 increment;
  7721.                 if tp^.tchostmt^.tt = nbegin then
  7722.                     estmt(tp^.tchostmt^.tbegin)
  7723.                 else
  7724.                     estmt(tp^.tchostmt);
  7725.                 indent;
  7726.                 writeln('break ;');
  7727.                 decrement;
  7728.                 tp := tp^.tnext;
  7729.                 if tp <> nil then
  7730.                     if tp^.tchocon = nil then
  7731.                         tp := nil
  7732.                 end
  7733.         end;    (* echoise *)
  7734.  
  7735.         (*    Rename all accessible record-fields to include    *)
  7736.         (*    pointer name.                    *)
  7737.         procedure cenv(ip : idptr; dp : declptr);
  7738.  
  7739.         var    tp    : treeptr;
  7740.             sp    : symptr;
  7741.             np    : idptr;
  7742.             h    : hashtyp;
  7743.  
  7744.         begin
  7745.             with dp^ do
  7746.               for h := 0 to hashmax - 1 do
  7747.                 begin
  7748.                 sp := ddecl[h];
  7749.                 while sp <> nil do
  7750.                     begin
  7751.                     if sp^.lt = lfield  then
  7752.                         begin
  7753.                         np := sp^.lid;
  7754.                         tp := sp^.lsymdecl^.tup^.tup;
  7755.                         if (tp^.tup^.tt = nvariant) and
  7756.                             (tp^.tuid <> nil) then
  7757.                             np := mkconc('.',
  7758.                                 tp^.tuid, np);
  7759.                         np := mkconc('>', ip, np);
  7760.                         sp^.lid := np
  7761.                         end;
  7762.                     sp := sp^.lnext
  7763.                     end
  7764.                 end
  7765.         end;    (* cenv *)
  7766.  
  7767.         (*    Emit identifiers for push/pop of global ptrs.    *)
  7768.         procedure eglobid(tp : treeptr);
  7769.  
  7770.         var    j    : toknidx;
  7771.             w    : toknbuf;
  7772.  
  7773.         begin
  7774.             gettokn(tp^.tsym^.lid^.istr, w);
  7775.             j := 1;
  7776.             if w[1] = '*' then
  7777.                 j := 2;
  7778.             while w[j] <> chr(null) do
  7779.                 begin
  7780.                 write(w[j]);
  7781.                 j := j + 1
  7782.                 end
  7783.         end;
  7784.  
  7785.     begin    (* estmt *)
  7786.         while tp <> nil do
  7787.             begin
  7788.             case tp^.tt of
  7789.               nbegin:
  7790.                 begin
  7791.                 if tp^.tup^.tt in [nbegin, nrepeat,
  7792.                         nproc, nfunc, npgm] then
  7793.                     indent;
  7794.                 writeln('{');
  7795.                 increment;
  7796.                 estmt(tp^.tbegin);
  7797.                 decrement;
  7798.                 indent;
  7799.                 write('}');
  7800.                 if tp^.tup^.tt <> nif then
  7801.                     writeln
  7802.                 end;
  7803.               nrepeat:
  7804.                 begin
  7805.                 indent;
  7806.                 writeln('do {');
  7807.                 increment;
  7808.                 estmt(tp^.treptstmt);
  7809.                 decrement;
  7810.                 indent;
  7811.                 write('} while (!(');
  7812.                 eexpr(tp^.treptxp);
  7813.                 writeln('));')
  7814.                 end;
  7815.               nwhile:
  7816.                 begin
  7817.                 indent;
  7818.                 write('while (');
  7819.                 increment;
  7820.                 eexpr(tp^.twhixp);
  7821.                 stusd := setused;
  7822.                 if tp^.twhistmt^.tt = nbegin then
  7823.                     begin
  7824.                     decrement;
  7825.                     write(') ');
  7826.                     estmt(tp^.twhistmt)
  7827.                     end
  7828.                 else begin
  7829.                     writeln(')');
  7830.                     estmt(tp^.twhistmt);
  7831.                     decrement
  7832.                      end;
  7833.                 setused := stusd or setused
  7834.                 end;
  7835.               nfor:
  7836.                 begin
  7837.                 indent;
  7838.                 if tp^.tincr then
  7839.                     begin
  7840.                     opc1 := '+';    (* increment variable *)
  7841.                     opc2 := '<'    (* test for <= *)
  7842.                     end
  7843.                 else begin
  7844.                     opc1 := '-';    (* decrement variable *)
  7845.                     opc2 := '>';    (* test for >= *)
  7846.                      end;
  7847.                 if not lazyfor then
  7848.                     begin
  7849.                     locid1 := mkvariable('B');
  7850.                     locid2 := mkvariable('B');
  7851.                     writeln('{');
  7852.                     increment;
  7853.                     indent;
  7854.                     tq := idup(tp^.tforid);
  7855.                     etypedef(tq^.tbind);
  7856.                     tq := typeof(tq^.tbind);
  7857.                     write(tab1);
  7858.                     printid(locid1);
  7859.                     write(' = ');
  7860.                     eexpr(tp^.tfrom);
  7861.                     writeln(',');
  7862.                     indent;
  7863.                     write(tab1);
  7864.                     printid(locid2);
  7865.                     write(' = ');
  7866.                     eexpr(tp^.tto);
  7867.                     writeln(';');
  7868.                     writeln;
  7869.                     indent;
  7870.                     write('if (');
  7871.                     if tq^.tt = nscalar then
  7872.                         begin
  7873.                         write('(int)(');
  7874.                         printid(locid1);
  7875.                         write(')')
  7876.                         end
  7877.                     else
  7878.                         printid(locid1);
  7879.                     write(' ', opc2, '= ');
  7880.                     if tq^.tt = nscalar then
  7881.                         begin
  7882.                         write('(int)(');
  7883.                         printid(locid2);
  7884.                         write(')')
  7885.                         end
  7886.                     else
  7887.                         printid(locid2);
  7888.                     writeln(')');
  7889.                     increment;
  7890.                     indent;
  7891.                     tp^.tfrom := newid(locid1);
  7892.                     tp^.tfrom^.tup := tp
  7893.                     end;
  7894.                 write('for (');
  7895.                 increment;
  7896.                 eexpr(tp^.tforid);
  7897.                 tq := typeof(tp^.tforid);
  7898.                 write(' = ');
  7899.                 eexpr(tp^.tfrom);
  7900.                 write('; ');
  7901.                 if lazyfor then
  7902.                     begin
  7903.                     if tq^.tt = nscalar then
  7904.                         begin
  7905.                         write('(int)(');
  7906.                         eexpr(tp^.tforid);
  7907.                         write(')')
  7908.                         end
  7909.                     else
  7910.                         eexpr(tp^.tforid);
  7911.                     write(' ', opc2, '= ');
  7912.                     if tq^.tt = nscalar then
  7913.                         begin
  7914.                         write('(int)(');
  7915.                         eexpr(tp^.tto);
  7916.                         write(')')
  7917.                         end
  7918.                     else
  7919.                         eexpr(tp^.tto)
  7920.                     end;
  7921.                 write('; ');
  7922.                 eexpr(tp^.tforid);
  7923.                 if tq^.tt = nscalar then
  7924.                     begin
  7925.                     write(' = (');
  7926.                     eexpr(tq^.tup^.tidl);
  7927.                     write(')((int)(');
  7928.                     eexpr(tp^.tforid);
  7929.                     write(')', opc1, '1)')
  7930.                     end
  7931.                 else
  7932.                     write(opc1, opc1);
  7933.                 if not lazyfor then
  7934.                     begin
  7935.                     if tp^.tforstmt^.tt <> nbegin then
  7936.                         begin
  7937.                         (* create compund stmt *)
  7938.                         tq := mknode(nbegin);
  7939.                         tq^.tbegin := tp^.tforstmt;
  7940.                         tq^.tbegin^.tup := tq;
  7941.                         tp^.tforstmt := tq;
  7942.                         tq^.tup := tp
  7943.                         end;
  7944.                     (* find end of loop *)
  7945.                     tq := tp^.tforstmt^.tbegin;
  7946.                     while tq^.tnext <> nil do
  7947.                         tq := tq^.tnext;
  7948.                     (* add break stmt *)
  7949.                     tq^.tnext := mknode(nbreak);
  7950.                     tq := tq^.tnext;
  7951.                     tq^.tup := tp^.tforstmt;
  7952.                     tq^.tbrkid := tp^.tforid;
  7953.                     tq^.tbrkxp := newid(locid2);
  7954.                     tq^.tbrkxp^.tup := tq
  7955.                     end;
  7956.                 if tp^.tforstmt^.tt = nbegin then
  7957.                     begin
  7958.                     decrement;
  7959.                     write(') ');
  7960.                     estmt(tp^.tforstmt)
  7961.                     end
  7962.                 else begin
  7963.                     writeln(')');
  7964.                     estmt(tp^.tforstmt);
  7965.                     decrement
  7966.                      end;
  7967.                 if not lazyfor then
  7968.                     begin
  7969.                     decrement;
  7970.                     decrement;
  7971.                     indent;
  7972.                     writeln('}')
  7973.                     end
  7974.                 end;
  7975.               nif:
  7976.                 begin
  7977.                 indent;
  7978.                 write('if (');
  7979.                 increment;
  7980.                 eexpr(tp^.tifxp);
  7981.                 stusd := setused;
  7982.                 setused := false;
  7983.                 if tp^.tthen^.tt = nbegin then
  7984.                     begin
  7985.                     decrement;
  7986.                     write(') ');
  7987.                     estmt(tp^.tthen);
  7988.                     if tp^.telse <> nil then
  7989.                         write(space)
  7990.                     else
  7991.                         writeln
  7992.                     end
  7993.                 else begin
  7994.                     writeln(')');
  7995.                     estmt(tp^.tthen);
  7996.                     decrement;
  7997.                     if tp^.telse <> nil then
  7998.                         indent
  7999.                      end;
  8000.                 if tp^.telse <> nil then
  8001.                     begin
  8002.                     write('else');
  8003.                     if tp^.telse^.tt = nbegin then
  8004.                         begin
  8005.                         write(space);
  8006.                         estmt(tp^.telse);
  8007.                         writeln
  8008.                         end
  8009.                     else begin
  8010.                         increment;
  8011.                         writeln;
  8012.                         estmt(tp^.telse);
  8013.                         decrement
  8014.                          end;
  8015.                     end;
  8016.                 setused := stusd or setused
  8017.                 end;
  8018.               ncase:
  8019.                 begin
  8020.                 indent;
  8021.                 write('switch ((int)(');
  8022.                 increment;
  8023.                 eexpr(tp^.tcasxp);
  8024.                 writeln(')) {');
  8025.                 decrement;
  8026.                 echoise(tp^.tcaslst);
  8027.                 indent;
  8028.                 writeln('  default:');
  8029.                 increment;
  8030.                 if tp^.tcasother = nil then
  8031.                     begin
  8032.                     indent;
  8033.                     writeln('PTCerror(PTC_E_CASE, ',
  8034.                         '__LINE__, 0, 0, 0);')
  8035.                     end
  8036.                 else
  8037.                     estmt(tp^.tcasother);
  8038.                 decrement;
  8039.                 indent;
  8040.                 writeln('}')
  8041.                 end;
  8042.               nwith:
  8043.                 begin
  8044.                 indent;
  8045.                 writeln('{');
  8046.                 increment;
  8047.                 tq := tp^.twithvar;
  8048.                 while tq <> nil do
  8049.                     begin
  8050.                     indent;
  8051.                     write(registr);
  8052.                     ewithtype(tq^.texpw);
  8053.                     write(' *');
  8054.                     locid1 := mkvariable('W');
  8055.                     printid(locid1);
  8056.                     write(' = ');
  8057.                     eaddr(tq^.texpw);
  8058.                     writeln(';');
  8059.                     cenv(locid1, tq^.tenv);
  8060.                     tq := tq^.tnext
  8061.                     end;
  8062.                 writeln;
  8063.                 if tp^.twithstmt^.tt = nbegin then
  8064.                     estmt(tp^.twithstmt^.tbegin)
  8065.                 else
  8066.                     estmt(tp^.twithstmt);
  8067.                 decrement;
  8068.                 indent;
  8069.                 writeln('}')
  8070.                 end;
  8071.               ngoto:
  8072.                 begin
  8073.                 indent;
  8074.                 if islocal(tp^.tlabel) then
  8075.                     writeln('goto L',
  8076.                         tp^.tlabel^.tsym^.lno:1, ';')
  8077.                 else begin
  8078.                     tq := idup(tp^.tlabel);
  8079.                     writeln('longjmp(J[',    (* LIB *)
  8080.                         tq^.tstat:1, '].jb, ',
  8081.                         tp^.tlabel^.tsym^.lno:1, ');')
  8082.                      end
  8083.                 end;
  8084.               nlabstmt:
  8085.                 begin
  8086.                 decrement;
  8087.                 indent;
  8088.                 writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
  8089.                 increment;
  8090.                 estmt(tp^.tstmt)
  8091.                 end;
  8092.               nassign:
  8093.                 begin
  8094.                 indent;
  8095.                 eexpr(tp);
  8096.                 writeln(';')
  8097.                 end;
  8098.               ncall:
  8099.                 begin
  8100.                 indent;
  8101.                 tq := idup(tp^.tcall);
  8102.                 if (tq^.tt in [nfunc, nproc]) and
  8103.                         (tq^.tsubstmt <> nil) then
  8104.                     if tq^.tsubstmt^.tt = npredef then
  8105.                         epredef(tq, tp)
  8106.                     else begin
  8107.                         ecall(tp);
  8108.                         writeln(';')
  8109.                          end
  8110.                 else begin
  8111.                     ecall(tp);
  8112.                     writeln(';')
  8113.                      end
  8114.                 end;
  8115.               npush:
  8116.                 begin
  8117.                 indent;
  8118.                 eglobid(tp^.ttmp);
  8119.                 write(' = ');
  8120.                 eglobid(tp^.tglob);
  8121.                 writeln(';');
  8122.                 indent;
  8123.                 eglobid(tp^.tglob);
  8124.                 write(' = ');
  8125.                 if tp^.tloc^.tt = nid then
  8126.                     begin
  8127.                     tq := idup(tp^.tloc);
  8128.                     if tq^.tt in [nparproc, nparfunc] then
  8129.                         printid(tp^.tloc^.tsym^.lid)
  8130.                     else
  8131.                         eaddr(tp^.tloc)
  8132.                     end
  8133.                 else
  8134.                     eaddr(tp^.tloc);
  8135.                 writeln(';')
  8136.                 end;
  8137.               npop:
  8138.                 begin
  8139.                 indent;
  8140.                 eglobid(tp^.tglob);
  8141.                 write(' = ');
  8142.                 eglobid(tp^.ttmp);
  8143.                 writeln(';')
  8144.                 end;
  8145.               nbreak:
  8146.                 begin
  8147.                 indent;
  8148.                 write('if (');
  8149.                 eexpr(tp^.tbrkid);
  8150.                 write(' == ');
  8151.                 eexpr(tp^.tbrkxp);
  8152.                 writeln(') break;')
  8153.                 end;
  8154.               nempty:
  8155.                 if not (tp^.tup^.tt in [npgm, nproc, nfunc,
  8156.                         nchoise, nbegin, nrepeat]) then
  8157.                     begin
  8158.                     indent;
  8159.                     writeln(';')
  8160.                     end
  8161.             end;(* case *)
  8162.             if setused and
  8163.                 (tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
  8164.                         nbegin, nchoise, nwith]) then
  8165.                 begin
  8166.                 indent;
  8167.                 writeln('Claimset();');
  8168.                 setused := false
  8169.                 end;
  8170.             tp := tp^.tnext
  8171.             end
  8172.     end;    (* estmt *)
  8173.  
  8174.     (*    Emit initialization for non-local gotos.        *)
  8175.     procedure elabel(tp : treeptr);
  8176.  
  8177.     var    tq    : treeptr;
  8178.         i    : integer;
  8179.  
  8180.     begin
  8181.         i := 0;
  8182.         tq := tp^.tsublab;
  8183.         while tq <> nil do
  8184.             begin
  8185.             if tq^.tsym^.lgo then
  8186.                 i := i + 1;
  8187.             tq := tq^.tnext
  8188.             end;
  8189.         if i =1 then
  8190.             begin
  8191.             tq := tp^.tsublab;
  8192.             while not tq^.tsym^.lgo do
  8193.                 tq := tq^.tnext;
  8194.             indent;
  8195.             writeln('if (',
  8196.                 'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
  8197.             writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
  8198.             end
  8199.         else if i > 1 then
  8200.             begin
  8201.             indent;
  8202.             writeln('switch (',
  8203.                 'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
  8204.             indent;
  8205.             writeln('  case 0:');
  8206.             indent;
  8207.             writeln(tab1, 'break;');
  8208.             tq := tp^.tsublab;
  8209.             while tq <> nil do
  8210.                 begin
  8211.                 if tq^.tsym^.lgo then
  8212.                     begin
  8213.                     (* label used in non-local goto *)
  8214.                     indent;
  8215.                     writeln('  case ',
  8216.                             tq^.tsym^.lno:1, ':');
  8217.                     indent;
  8218.                     writeln(tab1, 'goto L',
  8219.                             tq^.tsym^.lno:1, ';')
  8220.                     end;
  8221.                 tq := tq^.tnext
  8222.                 end;
  8223.             indent;
  8224.             writeln('  default:');
  8225.             indent;
  8226.             writeln(tab1, 
  8227.                 'PTCerror(PTC_E_CASE, __LINE__, 0, 0, 0);');
  8228.             indent;
  8229.             writeln('}')
  8230.             end
  8231.     end;    (* elabel *)
  8232.  
  8233.     (*    Emit declaration for lower bound of conformant array.    *)
  8234.     procedure econf(tp : treeptr);
  8235.  
  8236.     var    tq    : treeptr;
  8237.  
  8238.     begin
  8239.         while tp <> nil do
  8240.             begin
  8241.             if tp^.tt = nvarpar then
  8242.                 if tp^.tbind^.tt = nconfarr then
  8243.                     begin
  8244.                     indent;
  8245.                     etypedef(tp^.tbind^.tindtyp);
  8246.                     write(tab1);
  8247.                     tq := tp^.tbind^.tcindx^.tlo;
  8248.                     printid(tq^.tsym^.lid);
  8249.                     write(' = (');
  8250.                     etypedef(tp^.tbind^.tindtyp);
  8251.                     writeln(')0;')
  8252.                     end;
  8253.             tp := tp^.tnext
  8254.             end
  8255.     end;    (* econf *)
  8256.  
  8257.     (*    Emit code for subroutines.                *)
  8258.     procedure esubr(tp : treeptr);
  8259.  
  8260.     label    999;
  8261.  
  8262.     var    tq, ti    : treeptr;
  8263.  
  8264.     begin
  8265.         while tp <> nil do
  8266.             begin
  8267.             (* emit nested subroutines *)
  8268.             if tp^.tsubsub <> nil then
  8269.                 begin
  8270.                 (* emit forward declaration of this subroutine
  8271.                    in case of recursion *)
  8272. (*
  8273.                 etypedef(tp^.tfuntyp);
  8274.                 write(space);
  8275.                 printid(tp^.tsubid^.tsym^.lid);
  8276.                 write('(');
  8277.                 writeln('); /* Need parameter types for recursion */');
  8278. *)
  8279.                 esubr(tp^.tsubsub)
  8280.                 end;
  8281.             (* emit this subroutine *)
  8282.             if tp^.tsubstmt = nil then
  8283.                 begin
  8284.                 (* forward/external decl *)
  8285. (*
  8286.                 if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
  8287.                     write(xtern);
  8288.                 etypedef(tp^.tfuntyp);
  8289.                 write(space);
  8290.                 printid(tp^.tsubid^.tsym^.lid);
  8291.                 write('(');
  8292.                 writeln('); /* Need parameter types for forward/external */');
  8293. *)
  8294.                 goto 999
  8295.                 end;
  8296.             write(space);
  8297.             etypedef(tp^.tfuntyp);
  8298.             writeln;
  8299.             printid(tp^.tsubid^.tsym^.lid);
  8300.             write('(');
  8301.             tq := tp^.tsubpar;
  8302.             while tq <> nil do
  8303.                 begin
  8304.                 case tq^.tt of
  8305.                   nvarpar,
  8306.                   nvalpar:
  8307.                     begin
  8308.                     ti := tq^.tidl;
  8309.                     while ti <> nil do
  8310.                         begin
  8311.                         printid(ti^.tsym^.lid);
  8312.                         ti := ti^.tnext;
  8313.                         if ti <> nil then
  8314.                             write(', ');
  8315.                         end;
  8316.                     if tq^.tbind^.tt = nconfarr then
  8317.                         begin
  8318.                         (* add upper bound parameter *)
  8319.                         ti := tq^.tbind^.tcindx^.thi;
  8320.                         write(', ');
  8321.                         printid(ti^.tsym^.lid)
  8322.                         end;
  8323.                     end;
  8324.                   nparproc,
  8325.                   nparfunc:
  8326.                     begin
  8327.                     ti := tq^.tparid;
  8328.                     printid(ti^.tsym^.lid)
  8329.                     end
  8330.                 end;(* case *)
  8331.                 tq := tq^.tnext;
  8332.                 if tq <> nil then
  8333.                     write(', ');
  8334.                 end;
  8335.             writeln(')');
  8336.             increment;
  8337.             evar(tp^.tsubpar);
  8338.             writeln('{');
  8339.             econf(tp^.tsubpar);
  8340.             econst(tp^.tsubconst);
  8341.             etype(tp^.tsubtype);
  8342.             evar(tp^.tsubvar);
  8343.  
  8344.             if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
  8345.                     (tp^.tsubvar <> nil) then
  8346.                 writeln;
  8347.             elabel(tp);
  8348.             estmt(tp^.tsubstmt);
  8349.             if tp^.tt = nfunc then
  8350.                 begin
  8351.                 (* return value in the FIRST variable,
  8352.                    see renamf() above *)
  8353.                 indent;
  8354.                 write('return ');
  8355.                 printid(tp^.tsubvar^.tidl^.tsym^.lid);
  8356.                 writeln(';');
  8357.                 end;
  8358.             decrement;
  8359.             edconst(tp^.tsubconst);
  8360.             writeln('}');
  8361.         999:
  8362.             writeln;
  8363.             tp := tp^.tnext
  8364.             end
  8365.     end;    (* esubr *)
  8366.  
  8367.     function use(d : predefs) : boolean;
  8368.  
  8369.     begin
  8370.         use := defnams[d]^.lused
  8371.     end;
  8372.  
  8373.     (*    Emit code for main program.                *)
  8374.     procedure eprogram(tp : treeptr);
  8375.  
  8376.         (*    Symbol that sp refers to is renamed if it has    *)
  8377.         (*    been redefined in source program.        *)
  8378.         procedure capital(sp : symptr);
  8379.  
  8380.         var    tb    : toknbuf;
  8381.  
  8382.         begin
  8383.             if sp^.lid^.inref > 1 then
  8384.                 begin
  8385.                 gettokn(sp^.lid^.istr, tb);
  8386.                 tb[1] := uppercase(tb[1]);
  8387.                 sp^.lid := saveid(tb)
  8388.                 end
  8389.         end;
  8390.  
  8391.     begin    (* eprogram *)
  8392.         if tp^.tsubid <> nil then
  8393.             begin
  8394.             (* program heading was seen *)
  8395.             writeln('/', '*');
  8396.             write('**    Code derived from program ');
  8397.             printid(tp^.tsubid^.tsym^.lid);
  8398.             writeln;
  8399.             writeln('**    Translated by ptc ', rcsrevision);
  8400.             writeln('**    ', rcsid);
  8401.             writeln('*', '/');
  8402.             end;
  8403.         (* there aren't many programs that don't do I/O... *)
  8404.         writeln(include, '<stdio.h>');
  8405.         (* or string operations, so we might as well include these *)
  8406.         writeln(include, '<string.h>');
  8407.         writeln(include, '<stdlib.h>');
  8408.         writeln(include, '<ctype.h>');
  8409.         writeln(include, '"<ptc$dir>.ptcmain.h"');
  8410.         if use(dexp) or use(dln) or use(dsqr) or use(dsin) or
  8411.            use(dcos) or use(dtan) or use(darctan) or use(dsqrt) or
  8412.            use(dabs) or use(dtrunc) or use(dround) then
  8413.             writeln(include, '<math.h>');
  8414.         if use(dinput) or use(doutput) or use(derroutput) then
  8415.             begin
  8416.             if use(dinput) then
  8417.                 begin
  8418.                 if tp^.tsubid = nil then
  8419.                     write(xtern);
  8420.                 write('text', tab1);
  8421.                 printid(defnams[dinput]^.lid);
  8422.                 if tp^.tsubid <> nil then
  8423.                     write(' = { stdin, 0, 0, 0, 0}');
  8424.                 writeln(';')
  8425.                 end;
  8426.             if use(doutput) then
  8427.                 begin
  8428.                 if tp^.tsubid = nil then
  8429.                     write(xtern);
  8430.                 write('text', tab1);
  8431.                 printid(defnams[doutput]^.lid);
  8432.                 if tp^.tsubid <> nil then
  8433.                     write(' = { stdout, 0, 0, 0, 1}');
  8434.                 writeln(';')
  8435.                 end;
  8436.             if use(derroutput) then
  8437.                 begin
  8438.                 if tp^.tsubid = nil then
  8439.                     write(xtern);
  8440.                 write('text', tab1);
  8441.                 printid(defnams[derroutput]^.lid);
  8442.                 if tp^.tsubid <> nil then
  8443.                     write(' = { stderr, 0, 0, 0, 1 }');
  8444.                 writeln(';')
  8445.                 end
  8446.             end;
  8447.         if use(dread) or use(dreadln) then
  8448.             begin
  8449.             writeln(static, 'FILE', tab1, '*Tmpfil;');
  8450.             writeln(static, 'long', tab1, 'Tmplng;');
  8451.             writeln(static, 'double', tab1, 'Tmpdbl;');
  8452.             end;
  8453.         if usejmps then
  8454.             begin
  8455.             writeln(include, '<setjmp.h>');    (* LIB *)
  8456.             writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
  8457.                             (maxlevel+1):1, '];')
  8458.             end;
  8459.         if use(dinteger) or use(dmaxint) or 
  8460.             use(dboolean) or use(dfalse) or use(dtrue) or
  8461.                 use(deof) or use(deoln) or use(dexp) or
  8462.                 use(dln) or use(dsqr) or use(dsin) or
  8463.                 use(dcos) or use(dtan) or use(darctan) or
  8464.                 use(dsqrt) or use(dreal) then
  8465.             begin
  8466.             writeln('/', '*');
  8467.             writeln('**    Definitions for standard types');
  8468.             writeln('*', '/')
  8469.             end;
  8470.         if use(dboolean) or use(dfalse) or use(dtrue) or
  8471.             use(deof) or use(deoln) or usesets then
  8472.             begin
  8473.             capital(defnams[dboolean]);
  8474.             write(typdef, chartyp, tab1);
  8475.             printid(defnams[dboolean]^.lid);
  8476.             writeln(';');
  8477.             capital(defnams[dfalse]);
  8478.             write(define);
  8479.             printid(defnams[dfalse]^.lid);
  8480.             write(' (');
  8481.             printid(defnams[dboolean]^.lid);
  8482.             writeln(')0');
  8483.             capital(defnams[dtrue]);
  8484.             write(define);
  8485.             printid(defnams[dtrue]^.lid);
  8486.             write(' (');
  8487.             printid(defnams[dboolean]^.lid);
  8488.             writeln(')1');
  8489.             writeln(static, plainchartyp, tab1,
  8490.                 '*Bools[] = { "false", "true" };')
  8491.             end;
  8492.         capital(defnams[dinteger]);
  8493.         if use(dinteger) then
  8494.             begin
  8495.             write(typdef, inttyp, tab1);
  8496.             printid(defnams[dinteger]^.lid);
  8497.             writeln(';')
  8498.             end;
  8499.         if use(dmaxint) then
  8500.             writeln(define, 'maxint', tab1, maxint:1);
  8501.         capital(defnams[dreal]);
  8502.         if use(dreal) then
  8503.             begin
  8504.             write(typdef, realtyp, tab1);
  8505.             printid(defnams[dreal]^.lid);
  8506.             writeln(';')
  8507.             end;
  8508.         if use(dnew) then
  8509.             begin
  8510.             writeln(ifndef, 'Unionoffs');
  8511.             writeln(define, 'Unionoffs(p, m) ',
  8512.                 '(((long)(&(p)->m))-((long)(p)))');    (* CPU *)
  8513.             writeln(endif)
  8514.             end;
  8515.         if usesets then
  8516.             begin
  8517.             writeln(define, 'Claimset() ',
  8518.                 voidcast, 'Currset(0, (', setptyp, ')0)');
  8519.             writeln(define, 'Newset() ',
  8520.                     'Currset(1, (', setptyp, ')0)');
  8521.             writeln(define, 'Saveset(s) Currset(2, s)');
  8522.             writeln(define, 'setbits ', setbits:1);
  8523.             writeln(typdef, wordtype, tab1, setwtyp, ';');
  8524.             writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
  8525.             printid(defnams[dboolean]^.lid);
  8526.             writeln(tab1, 'Member(unsigned int m, setptr sp),');
  8527.             writeln(tab1, 'Le(setptr p1, setptr p2),');
  8528.             writeln(tab1, 'Ge(setptr p1, setptr p2),');
  8529.             writeln(tab1, 'Eq(setptr p1, setptr p2),');
  8530.             writeln(tab1, 'Ne(setptr p1, setptr p2);');
  8531.             writeln(setptyp, tab1, 'Union(setptr p1, setptr p2);');
  8532.             writeln(setptyp, tab1, 'Diff(setptr p1, setptr p2);');
  8533.             writeln(setptyp, tab1, 'Insmem(unsigned int m, setptr sp);');
  8534.             writeln(setptyp, tab1, 'Mksubr(unsigned int lo, unsigned int hi, setptr sp);');
  8535.             writeln(setptyp, tab1, 'Currset(int n, setptr sp);');
  8536.             writeln(setptyp, tab1, 'Inter(setptr p1, setptr p2);');
  8537.             writeln(static, setptyp, tab1, 'Tmpset;');
  8538.             writeln(setptyp, tab1, 'Conset[];');
  8539.             writeln(voidtyp, tab1, 'Setncpy(setptr S1, setptr S2, unsigned int N);')
  8540.             end;
  8541.         if align then                    (* CPU *)
  8542.             begin
  8543.             writeln(ifndef, 'SETALIGN');
  8544.             writeln(define, 'SETALIGN(x) Alignset((unsigned int *)(x))');
  8545.             writeln('struct Set { ', wordtype, tab1, 'S[',
  8546.                     maxsetrange:1, '+1]; } *Alignset(register unsigned int *Sp);');
  8547.             writeln(endif);
  8548.             writeln(ifndef, 'STRALIGN');
  8549.             writeln(define, 'STRALIGN(x) Alignstr((unsigned char *)(x))');
  8550.             writeln('struct String { char    A[',
  8551.                     maxtoknlen:1, '+1]; } *Alignstr(register unsigned char *Cp);');
  8552.             writeln(endif)
  8553.             end;
  8554.         if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
  8555.             (tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
  8556.             begin
  8557.             writeln('/', '*');
  8558.             writeln('**    Start of program definitions');
  8559.             writeln('*', '/');
  8560.             end;
  8561.         econst(tp^.tsubconst);
  8562.         etype(tp^.tsubtype);
  8563.         evar(tp^.tsubvar);
  8564.         if tp^.tsubsub <> nil then
  8565.             writeln;
  8566.         writeln('#ptcheader');
  8567.         esubr(tp^.tsubsub);
  8568.         if tp^.tsubid <> nil then
  8569.             begin
  8570.             (* program heading was seen *)
  8571.             writeln(inttyp, tab1, 'argc;');
  8572.             writeln(chartyp, tab1, '**argv;');
  8573.             writeln;
  8574.             writeln('int main(_ac, _av)');    (* OS *)
  8575.             writeln(inttyp, tab1, '_ac;');
  8576.             writeln(chartyp, tab1, '*_av[];');
  8577.             writeln('{');
  8578.             writeln;
  8579.             increment;
  8580.             indent;
  8581.             writeln('argc = _ac;');
  8582.             indent;
  8583.             writeln('argv = _av;');
  8584.             elabel(tp);
  8585.             estmt(tp^.tsubstmt);
  8586.             indent;
  8587.             writeln('exit(0);');
  8588.             indent;
  8589.             writeln('/', '* NOTREACHED *', '/');
  8590.             decrement;
  8591.             writeln('}');
  8592.             edconst(tp^.tsubconst);
  8593.             end
  8594.     end;    (* eprogram *)
  8595.  
  8596.     (*    Emit definitions for constant sets    *)
  8597.     procedure econset(tp : treeptr; len : integer);
  8598.  
  8599.     var    i    : integer;
  8600.  
  8601.         function size(tp : treeptr) : integer;
  8602.  
  8603.         var    r, x    : integer;
  8604.  
  8605.         begin
  8606.             r := 0;
  8607.             while tp <> nil do
  8608.                 begin
  8609.                 if tp^.tt = nrange then
  8610.                     x := cvalof(tp^.texpr)
  8611.                 else if tp^.tt = nempty then
  8612.                     x := 0
  8613.                 else
  8614.                     x := cvalof(tp);
  8615.                 if x > r then
  8616.                     r := x;
  8617.                 tp := tp^.tnext
  8618.                 end;
  8619.             size := csetwords(r+1)
  8620.         end;
  8621.  
  8622.         (*    Emit bits in a constant set    *)
  8623.         procedure ebits(tp : treeptr);
  8624.  
  8625.         type    bitset    = set of 0 .. setbits;
  8626.  
  8627.         var    sets    : array [ 0 .. maxsetrange ] of bitset;
  8628.             s, m, n    : integer;
  8629.  
  8630.             procedure eword(s : bitset);
  8631.  
  8632.             const    bitshex    = 4;    (* nr of bits in a hex-digit *)
  8633.  
  8634.             var    n, i    : integer;
  8635.                 x    : 0 .. setbits;
  8636.  
  8637.             begin
  8638.                 n := 0;
  8639.                 while n <= setbits do
  8640.                     n := n + bitshex;
  8641.                 n := n - bitshex;
  8642.                 while n >= 0 do
  8643.                     begin
  8644.                     (* compute 1 hexdigit *)
  8645.                     x := 0;
  8646.                     for i := 0 to bitshex - 1 do
  8647.                         if (n + i) in s then
  8648.                             case i of
  8649.                               0:    x := x + 1;
  8650.                               1:    x := x + 2;
  8651.                               2:    x := x + 4;
  8652.                               3:    x := x + 8
  8653.                             end;(* case *)
  8654.                     (* print it *)
  8655.                     write(hexdig[x]);
  8656.                     n := n - bitshex
  8657.                     end
  8658.             end;
  8659.  
  8660.         begin
  8661.             s := size(tp);
  8662.             for n := 0 to s - 1 do
  8663.                 sets[n] := [];
  8664.             while tp <> nil do
  8665.                 begin
  8666.                 if tp^.tt = nrange then
  8667.                     for m := cvalof(tp^.texpl) to
  8668.                             cvalof(tp^.texpr) do
  8669.                         begin
  8670.                         n := m div (setbits+1);
  8671.                         sets[n] := sets[n] +
  8672.                             [m mod (setbits+1)]
  8673.                         end
  8674.                 else if tp^.tt <> nempty then
  8675.                     begin
  8676.                     m := cvalof(tp);
  8677.                     n := m div (setbits+1);
  8678.                     sets[n] := sets[n] +
  8679.                         [m mod (setbits+1)]
  8680.                     end;
  8681.                 tp := tp^.tnext
  8682.                 end;
  8683.             write(tab1, s:1);
  8684.             for n := 0 to s - 1 do
  8685.                 begin
  8686.                 write(',');
  8687.                 if n mod 6 = 0 then
  8688.                     writeln;
  8689.                 write(tab1, '0x');
  8690.                 eword(sets[n]);
  8691.                 end;
  8692.             writeln
  8693.         end;
  8694.  
  8695.     begin
  8696.         i := 0;
  8697.         while tp <> nil do
  8698.             begin
  8699.             writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
  8700.             ebits(tp^.texps);
  8701.             writeln('};');
  8702.             i := i + 1;
  8703.             tp := tp^.tnext
  8704.             end;
  8705.         writeln(setwtyp, tab1, '*Conset[] = {');
  8706.         for i := len - 1 downto 1 do
  8707.             begin
  8708.             write(tab1, 'Q', i:1, ',');
  8709.             if i mod 6 = 5 then
  8710.                 writeln
  8711.             end;
  8712.         writeln(tab1, 'Q0');
  8713.         writeln('};');
  8714.     end;
  8715.  
  8716. begin    (* emit *)
  8717.     indnt := 0;
  8718.     varno := 0;
  8719.     conflag := false;
  8720.     setused := false;
  8721.     dropset := false;
  8722.     eprogram(top);
  8723.     if setcnt > 0 then
  8724.         econset(setlst, setcnt);
  8725.     if useunion then
  8726.         begin
  8727.         writeln;
  8728.         writeln((* static, *) setptyp);
  8729.         writeln('Union(p1, p2)');
  8730.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8731.         writeln('{');
  8732.         writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
  8733.         writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
  8734.         writeln(tab4, 'p3 = sp;');
  8735.         writeln;
  8736.         writeln(tab1, 'j = *p1;');
  8737.         writeln(tab1, '*p3 = j;');
  8738.         writeln(tab1, 'if (j > *p2)');
  8739.         writeln(tab2, 'j = *p2;');
  8740.         writeln(tab1, 'else');
  8741.         writeln(tab2, '*p3 = *p2;');
  8742.         writeln(tab1, 'k = *p1 - *p2;');
  8743.         writeln(tab1, 'p1++, p2++, p3++;');
  8744.         writeln(tab1, 'for (i = 0; i < j; i++)');
  8745.         writeln(tab2, '*p3++ = (*p1++ | *p2++);');
  8746.         writeln(tab1, 'while (k > 0) {');
  8747.         writeln(tab2, '*p3++ = *p1++;');
  8748.         writeln(tab2, 'k--;');
  8749.         writeln(tab1, '}');
  8750.         writeln(tab1, 'while (k < 0) {');
  8751.         writeln(tab2, '*p3++ = *p2++;');
  8752.         writeln(tab2, 'k++;');
  8753.         writeln(tab1, '}');
  8754.         writeln(tab1, 'return (Saveset(sp));');
  8755.         writeln('}')
  8756.         end;
  8757.     if usediff then
  8758.         begin
  8759.         writeln;
  8760.         writeln((* static, *) setptyp);
  8761.         writeln('Diff(p1, p2)');
  8762.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8763.         writeln('{');
  8764.         writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
  8765.         writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
  8766.         writeln(tab4, 'p3 = sp;');
  8767.         writeln;
  8768.         writeln(tab1, 'j = *p1;');
  8769.         writeln(tab1, '*p3 = j;');
  8770.         writeln(tab1, 'if (j > *p2)');
  8771.         writeln(tab2, 'j = *p2;');
  8772.         writeln(tab1, 'k = *p1 - *p2;');
  8773.         writeln(tab1, 'p1++, p2++, p3++;');
  8774.         writeln(tab1, 'for (i = 0; i < j; i++)');
  8775.         writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
  8776.         writeln(tab1, 'while (k > 0) {');
  8777.         writeln(tab2, '*p3++ = *p1++;');
  8778.         writeln(tab2, 'k--;');
  8779.         writeln(tab1, '}');
  8780.         writeln(tab1, 'return (Saveset(sp));');
  8781.         writeln('}')
  8782.         end;
  8783.     if useintr then
  8784.         begin
  8785.         writeln;
  8786.         writeln((* static, *) setptyp);
  8787.         writeln('Inter(p1, p2)');
  8788.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8789.         writeln('{');
  8790.         writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
  8791.         writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
  8792.         writeln(tab4, 'p3 = sp;');
  8793.         writeln;
  8794.         writeln(tab1, 'if ((j = *p1) > *p2)');
  8795.         writeln(tab2, 'j = *p2;');
  8796.         writeln(tab1, '*p3 = j;');
  8797.         writeln(tab1, 'p1++, p2++, p3++;');
  8798.         writeln(tab1, 'for (i = 0; i < j; i++)');
  8799.         writeln(tab2, '*p3++ = (*p1++ & *p2++);');
  8800.         writeln(tab1, 'return (Saveset(sp));');
  8801.         writeln('}')
  8802.         end;
  8803.     if usememb then
  8804.         begin
  8805.         writeln;
  8806.         (* write(static); *)
  8807.         printid(defnams[dboolean]^.lid);
  8808.         writeln;
  8809.         writeln('Member(m, sp)');
  8810.         writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
  8811.         writeln(tab1, registr, setptyp, tab1, 'sp;');
  8812.         writeln('{');
  8813.         writeln(tab1, registr, usigned, inttyp,
  8814.                     tab1, 'i = m / (setbits+1) + 1;');
  8815.         writeln;
  8816.         writeln(tab1, 'if ((i <= *sp) &&',
  8817.                     ' (sp[i] & (1 << (m % (setbits+1)))))');
  8818.         write(tab2, 'return (');
  8819.         printid(defnams[dtrue]^.lid);
  8820.         writeln(');');
  8821.         write(tab1, 'return (');
  8822.         printid(defnams[dfalse]^.lid);
  8823.         writeln(');');
  8824.         writeln('}')
  8825.         end;
  8826.     if useseq or usesne then
  8827.         begin
  8828.         writeln;
  8829.         (* write(static); *)
  8830.         printid(defnams[dboolean]^.lid);
  8831.         writeln;
  8832.         writeln('Eq(p1, p2)');
  8833.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8834.         writeln('{');
  8835.         writeln(tab1, registr, inttyp, tab1, 'i, j;');
  8836.         writeln;
  8837.         writeln(tab1, 'i = *p1++;');
  8838.         writeln(tab1, 'j = *p2++;');
  8839.         writeln(tab1, 'while (i != 0 && j != 0) {');
  8840.         writeln(tab2, 'if (*p1++ != *p2++)');
  8841.         write(tab3, 'return (');
  8842.         printid(defnams[dfalse]^.lid);
  8843.         writeln(');');
  8844.         writeln(tab2, 'i--, j--;');
  8845.         writeln(tab1, '}');
  8846.         writeln(tab1, 'while (i != 0) {');
  8847.         writeln(tab2, 'if (*p1++ != 0)');
  8848.         write(tab3, 'return (');
  8849.         printid(defnams[dfalse]^.lid);
  8850.         writeln(');');
  8851.         writeln(tab2, 'i--;');
  8852.         writeln(tab1, '}');
  8853.         writeln(tab1, 'while (j != 0) {');
  8854.         writeln(tab2, 'if (*p2++ != 0)');
  8855.         write(tab3, 'return (');
  8856.         printid(defnams[dfalse]^.lid);
  8857.         writeln(');');
  8858.         writeln(tab2, 'j--;');
  8859.         writeln(tab1, '}');
  8860.         write(tab1, 'return (');
  8861.         printid(defnams[dtrue]^.lid);
  8862.         writeln(');');
  8863.         writeln('}')
  8864.         end;
  8865.     if usesne then
  8866.         begin
  8867.         writeln;
  8868.         (* write(static); *)
  8869.         printid(defnams[dboolean]^.lid);
  8870.         writeln;
  8871.         writeln('Ne(p1, p2)');
  8872.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8873.         writeln('{');
  8874.         write(tab1, 'return (!Eq(p1, p2));');
  8875.         writeln('}')
  8876.         end;
  8877.     if usesle then
  8878.         begin
  8879.         writeln;
  8880.         (* write(static); *)
  8881.         printid(defnams[dboolean]^.lid);
  8882.         writeln;
  8883.         writeln('Le(p1, p2)');
  8884.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8885.         writeln('{');
  8886.         writeln(tab1, registr, inttyp, tab1, 'i, j;');
  8887.         writeln;
  8888.         writeln(tab1, 'i = *p1++;');
  8889.         writeln(tab1, 'j = *p2++;');
  8890.         writeln(tab1, 'while (i != 0 && j != 0) {');
  8891.         writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
  8892.         write(tab3, 'return (');
  8893.         printid(defnams[dfalse]^.lid);
  8894.         writeln(');');
  8895.         writeln(tab2, 'i--, j--;');
  8896.         writeln(tab1, '}');
  8897.         writeln(tab1, 'while (i != 0) {');
  8898.         writeln(tab2, 'if (*p1++ != 0)');
  8899.         write(tab3, 'return (');
  8900.         printid(defnams[dfalse]^.lid);
  8901.         writeln(');');
  8902.         writeln(tab2, 'i--;');
  8903.         writeln(tab1, '}');
  8904.         write(tab1, 'return (');
  8905.         printid(defnams[dtrue]^.lid);
  8906.         writeln(');');
  8907.         writeln('}')
  8908.         end;
  8909.     if usesge then
  8910.         begin
  8911.         writeln;
  8912.         (* write(static); *)
  8913.         printid(defnams[dboolean]^.lid);
  8914.         writeln;
  8915.         writeln('Ge(p1, p2)');
  8916.         writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
  8917.         writeln('{');
  8918.         writeln(tab1, registr, inttyp, tab1, 'i, j;');
  8919.         writeln;
  8920.         writeln(tab1, 'i = *p1++;');
  8921.         writeln(tab1, 'j = *p2++;');
  8922.         writeln(tab1, 'while (i != 0 && j != 0) {');
  8923.         writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
  8924.         writeln(tab3, 'return (false);');
  8925.         writeln(tab2, 'i--, j--;');
  8926.         writeln(tab1, '}');
  8927.         writeln(tab1, 'while (j != 0) {');
  8928.         writeln(tab2, 'if (*p2++ != 0)');
  8929.         write(tab3, 'return (');
  8930.         printid(defnams[dfalse]^.lid);
  8931.         writeln(');');
  8932.         writeln(tab2, 'j--;');
  8933.         writeln(tab1, '}');
  8934.         write(tab1, 'return (');
  8935.         printid(defnams[dtrue]^.lid);
  8936.         writeln(');');
  8937.         writeln('}')
  8938.         end;
  8939.     if usemksub then
  8940.         begin
  8941.         writeln;
  8942.         writeln((* static, *) setptyp);
  8943.         writeln('Mksubr(lo, hi, sp)');
  8944.         writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
  8945.         writeln(tab1, registr, setptyp, tab1, 'sp;');
  8946.         writeln('{');
  8947.         writeln(tab1, registr, inttyp, tab1, 'i, k;');
  8948.         writeln;
  8949.         writeln(tab1, 'if (hi < lo)');
  8950.         writeln(tab2, 'return (sp);');
  8951.         writeln(tab1, 'i = hi / (setbits+1) + 1;');
  8952.         writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
  8953.         writeln(tab2, 'sp[k] = 0;');
  8954.         writeln(tab1, 'if (*sp < i)');
  8955.         writeln(tab2, '*sp = i;');
  8956.         writeln(tab1, 'for (k = lo; k <= hi; k++)');
  8957.         writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
  8958.                         '(1 << (k % (setbits+1)));');
  8959.         writeln(tab1, 'return (sp);');
  8960.         writeln('}')
  8961.         end;
  8962.     if useins then
  8963.         begin
  8964.         writeln;
  8965.         writeln((* static, *) setptyp);
  8966.         writeln('Insmem(m, sp)');
  8967.         writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
  8968.         writeln(tab1, registr, setptyp, tab1, 'sp;');
  8969.         writeln('{');
  8970.         writeln(tab1, registr, inttyp, tab1, 'i,');
  8971.         writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
  8972.         writeln;
  8973.         writeln(tab1, 'if (*sp < j)');
  8974.         writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
  8975.         writeln(tab3, 'sp[i] = 0;');
  8976.         writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
  8977.         writeln(tab1, 'return (sp);');
  8978.         writeln('}')
  8979.         end;
  8980.     if usesets then
  8981.         begin
  8982.         writeln;
  8983.         writeln(ifndef, 'SETSPACE');
  8984.         writeln(define, 'SETSPACE 256');
  8985.         writeln(endif);
  8986.         writeln((* static, *) setptyp);
  8987.         writeln('Currset(n,sp)');
  8988.         writeln(tab1, inttyp, tab1, 'n;');
  8989.         writeln(tab1, setptyp, tab1, 'sp;');
  8990.         writeln('{');
  8991.         writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
  8992.         writeln(tab1, static, setptyp, tab1, 'Top = Space;');
  8993.         writeln;
  8994.         writeln(tab1, 'switch (n) {');
  8995.         writeln(tab1, '  case 0:');
  8996.         writeln(tab2, 'Top = Space;');
  8997.         writeln(tab2, 'return (0);');
  8998.         writeln(tab1, '  case 1:');
  8999.         writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
  9000.                             maxsetrange:1, ') {');
  9001.         writeln(tab3,
  9002.             voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
  9003.         writeln(tab3, 'exit(1);');
  9004.         writeln(tab2, '}');
  9005.         writeln(tab2, '*Top = 0;');
  9006.         writeln(tab2, 'return (Top);');
  9007.         writeln(tab1, '  case 2:');
  9008.         writeln(tab2, 'if (Top <= &sp[*sp])');
  9009.         writeln(tab3, 'Top = &sp[*sp + 1];');
  9010.         writeln(tab2, 'return (sp);');
  9011.         writeln(tab1, '}');
  9012.         writeln(tab1, '/', '* NOTREACHED *', '/');
  9013.         writeln('}')
  9014.         end;
  9015.     if usescpy then
  9016.         begin
  9017.         writeln;
  9018.         writeln((* static, *) voidtyp);
  9019.         writeln('Setncpy(S1, S2, N)');
  9020.         writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
  9021.         writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
  9022.         writeln('{');
  9023.         writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
  9024.         writeln;
  9025.         writeln(tab1, 'N /= sizeof(', setwtyp, ');');
  9026.         writeln(tab1, '*S1++ = --N;');
  9027.         writeln(tab1, 'm = *S2++;');
  9028.         writeln(tab1, 'while (m != 0 && N != 0) {');
  9029.         writeln(tab2, '*S1++ = *S2++;');
  9030.         writeln(tab2, '--N;');
  9031.         writeln(tab2, '--m;');
  9032.         writeln(tab1, '}');
  9033.         writeln(tab1, 'while (N-- != 0)');
  9034.         writeln(tab2, '*S1++ = 0;');
  9035.         writeln('}')
  9036.         end;
  9037.     if usesal then
  9038.         begin
  9039.         writeln;
  9040.         writeln('struct Set *');
  9041.         writeln('Alignset(Sp)');
  9042.         writeln(tab1, registr, wordtype, tab1, '*Sp;');
  9043.         writeln('{');
  9044.         writeln(tab1, static, 'struct Set', tab1, 'tmp;');
  9045.         writeln(tab1, registr, wordtype, tab1, '*tp = tmp.S;');
  9046.         writeln(tab1, registr, inttyp, tab2, 'i = *Sp;');
  9047.         writeln;
  9048.         writeln(tab1, 'while (i-- >= 0)');
  9049.         writeln(tab2, '*tp++ = *Sp++;');
  9050.         writeln(tab1, 'return (&tmp);');
  9051.         writeln('}')
  9052.         end;
  9053.     if usealig then
  9054.         begin
  9055.         writeln;
  9056.         writeln('struct String *');
  9057.         writeln('Alignstr(Cp)');
  9058.         writeln(tab1, registr, chartyp, tab1, '*Cp;');
  9059.         writeln('{');
  9060.         writeln(tab1, static, 'struct String', tab1, 'tmp;');
  9061.         writeln(tab1, registr, chartyp, tab1, '*sp = (', chartyp, '*)tmp.A;');
  9062.         writeln;
  9063.         writeln(tab1, 'while ((*sp++ = *Cp++) != 0)');
  9064.         writeln(tab2, ';');
  9065.         writeln(tab1, 'return (&tmp);');
  9066.         writeln('}')
  9067.         end;
  9068.     if usemax then
  9069.         begin
  9070.         writeln;
  9071.         writeln((* static, *) inttyp);
  9072.         writeln('Max(m, n)');
  9073.         writeln(tab1, inttyp, tab1, 'm, n;');
  9074.         writeln('{');
  9075.         writeln(tab1, 'if (m > n)');
  9076.         writeln(tab2, 'return (m);');
  9077.         writeln(tab1, 'return (n);');
  9078.         writeln('}')
  9079.         end;
  9080. end;    (* emit *)
  9081.  
  9082. (*    Initialize all global structures used in translator.        *)
  9083. procedure initialize;
  9084.  
  9085. var    s    : hashtyp;
  9086.     t    : pretyps;
  9087.     d    : predefs;
  9088.  
  9089.     hx    : packed array [ 1 .. 16 ] of char;
  9090.  
  9091.     (*    Define names in ctable.                    *)
  9092.     procedure defname(cn : cnames; str : keyword);
  9093.  
  9094.     label    999;
  9095.  
  9096.     var    w    : toknbuf;
  9097.         i    : toknidx;
  9098.  
  9099.     begin
  9100.         unpack(str, w, 1);
  9101.         for i := 1 to keywordlen do
  9102.             if w[i] = space then
  9103.                 begin
  9104.                 w[i] := chr(null);
  9105.                 goto 999
  9106.                 end;
  9107.         w[keywordlen+1] := chr(null);
  9108.     999:
  9109.         ctable[cn] := saveid(w)
  9110.     end;
  9111.  
  9112.     (*    Define predefined identifiers.                *)
  9113.     procedure defid(nt : treetyp; did : predefs; str : keyword);
  9114.  
  9115.     label    999;
  9116.  
  9117.     var    w    : toknbuf;
  9118.         i    : toknidx;
  9119.         tp, tq,
  9120.         tv    : treeptr;
  9121.  
  9122.     begin
  9123.         for i := 1 to keywordlen do
  9124.             if str[i] = space then
  9125.                 begin
  9126.                 w[i] := chr(null);
  9127.                 goto 999
  9128.                 end
  9129.             else
  9130.                 w[i] := str[i];
  9131.         w[keywordlen+1] := chr(null);
  9132.     999:
  9133.         tp := newid(saveid(w));
  9134.         defnams[did] := tp^.tsym;
  9135.         if nt in [ntype, nfunc, nproc] then
  9136.             begin
  9137.             (* predefined types, procedures and functions
  9138.                 are marked with a particular node *)
  9139.             tv := mknode(npredef);
  9140.             tv^.tdef := did;
  9141.             tv^.tobtyp := tnone
  9142.             end
  9143.         else
  9144.             tv := nil; (* predefined constants and variables will
  9145.                     eventually be bound to something *)
  9146.         case nt of
  9147.           nscalar:
  9148.             begin
  9149.             tv := mknode(nscalar);
  9150.             tv^.tscalid := nil;
  9151.             tq := mknode(ntype);
  9152.             tq^.tbind := tv;
  9153.             tq^.tidl := tp;
  9154.             tp := tq
  9155.             end;
  9156.           nconst,
  9157.           ntype,
  9158.           nfield,
  9159.           nvar:
  9160.             begin
  9161.             tq := mknode(nt);
  9162.             tq^.tbind := tv;
  9163.             tq^.tidl := tp;
  9164.             tq^.tattr := anone;
  9165.             tp := tq
  9166.             end;
  9167.           nfunc,
  9168.           nproc:
  9169.             begin
  9170.             tq := mknode(nt);
  9171.             tq^.tsubid := tp;
  9172.             tq^.tsubstmt := tv;
  9173.             tq^.tfuntyp := nil;
  9174.             tq^.tsubpar := nil;
  9175.             tq^.tsublab := nil;
  9176.             tq^.tsubconst := nil;
  9177.             tq^.tsubtype := nil;
  9178.             tq^.tsubvar := nil;
  9179.             tq^.tsubsub := nil;
  9180.             tq^.tscope := nil;
  9181.             tq^.tstat := 0;
  9182.             tp := tq
  9183.             end;
  9184.           nid:
  9185.         end;(* case *)
  9186.         deftab[did] := tp
  9187.     end;    (* defid *)
  9188.  
  9189.     (*    Define keywords.                    *)
  9190.     procedure defkey(s : symtyp; w : keyword);
  9191.  
  9192.     var    i    : 1 .. keywordlen;
  9193.  
  9194.     begin
  9195.         for i := 1 to keywordlen do
  9196.             if w[i] = space then
  9197.                 w[i] := chr(null);
  9198.         (* relies on symtyp being sorted *)
  9199.         with keytab[ord(s)] do
  9200.             begin
  9201.             wrd := w;
  9202.             sym := s
  9203.             end;
  9204.     end;
  9205.  
  9206.     procedure fixfp(i : strindx);
  9207.  
  9208.     var    t    : toknbuf;
  9209.  
  9210.     begin
  9211.         gettokn(i, t);
  9212.         t[1] := 'f';
  9213.         puttokn(i, t);
  9214.     end;
  9215.  
  9216.     (*    Add a cpu word type description.            *)
  9217.     (*    Parameters lo and hi gives the range of a machine-    *)
  9218.     (*    dependant integer type. Parameter str gives the corres-    *)
  9219.     (*    ponding C-language type-name.                *)
  9220.     procedure defmach(lo, hi : integer; str : machdefstr);
  9221.  
  9222.     label    999;
  9223.  
  9224.     var    i    : toknidx;
  9225.         w    : toknbuf;
  9226.  
  9227.     begin
  9228.         unpack(str, w, 1);
  9229.         if w[machdeflen] <> space then
  9230.             error(ebadmach);
  9231.         for i := machdeflen - 1 downto 1 do
  9232.             if w[i] <> space then
  9233.                 begin
  9234.                 w[i+1] := chr(null);
  9235.                 goto 999
  9236.                 end;
  9237.         error(ebadmach);
  9238.     999:
  9239.         if nmachdefs >= maxmachdefs then
  9240.             error(emanymachs);
  9241.         nmachdefs := nmachdefs + 1;
  9242.         with machdefs[nmachdefs] do
  9243.             begin
  9244.             lolim := lo;
  9245.             hilim := hi;
  9246.             typstr := savestr(w)
  9247.             end
  9248.     end;
  9249.  
  9250.     procedure initstrstore;
  9251.  
  9252.     var    i    : strbcnt;
  9253.  
  9254.     begin
  9255.         for i := 1 to maxblkcnt do
  9256.             strstor[i] := nil;
  9257.         new(strstor[0]);
  9258.         strstor[0]^[0] := chr(null);
  9259.         strfree := 1;
  9260.         strleft := maxstrblk
  9261.     end;
  9262.  
  9263. begin    (* initialize *)
  9264. { IF-PASCAL
  9265.     rewrite(erroutput, '/dev/tty'); 
  9266. END-IF-PASCAL }
  9267.     lineno := 1;
  9268.     colno := 0;
  9269.     pushed := false;
  9270.  
  9271.     initstrstore;
  9272.  
  9273.     setlst := nil;
  9274.     setcnt := 0;
  9275.     hx := '0123456789ABCDEF';
  9276.     unpack(hx, hexdig, 0);
  9277.  
  9278.     symtab := nil;
  9279.     statlvl := 0;
  9280.     maxlevel := -1;
  9281.     enterscope(nil);
  9282.     varno:= 0;
  9283.  
  9284.     usesets := false;
  9285.     useunion := false;
  9286.     usediff := false;
  9287.     usemksub := false;
  9288.     useintr := false;
  9289.     usesge := false;
  9290.     usesle := false;
  9291.     usesne := false;
  9292.     useseq := false;
  9293.     usememb := false;
  9294.     useins := false;
  9295.     usescpy := false;
  9296.  
  9297.     usecase := false;
  9298.     usejmps := false;
  9299.  
  9300.     usecomp := false;
  9301.     usemax    := false;
  9302.     usealig    := false;
  9303.     usesal    := false;
  9304.  
  9305.     for s := 0 to hashmax do
  9306.         idtab[s] := nil;
  9307.     for d := dabs to dztring do
  9308.         begin
  9309.         deftab[d] := nil;
  9310.         defnams[d] := nil
  9311.         end;
  9312.  
  9313.     (* Pascal keywords *)
  9314.     defkey(sand,    'and       ');
  9315.     defkey(sarray,    'array     ');
  9316.     defkey(sbegin,    'begin     ');
  9317.     defkey(scase,    'case      ');
  9318.     defkey(sconst,    'const     ');
  9319.     defkey(sdiv,    'div       ');
  9320.     defkey(sdo,    'do        ');
  9321.     defkey(sdownto,    'downto    ');
  9322.     defkey(selse,    'else      ');
  9323.     defkey(send,    'end       ');
  9324.     defkey(sextern,    externsym);    (* non-standard *)
  9325.     defkey(sfile,    'file      ');
  9326.     defkey(sfor,    'for       ');
  9327.     defkey(sforward,'forward   ');
  9328.     defkey(sfunc,    'function  ');
  9329.     defkey(sgoto,    'goto      ');
  9330.     defkey(sif,    'if        ');
  9331.     defkey(sinn,    'in        ');
  9332.     defkey(slabel,    'label     ');
  9333.     defkey(smod,    'mod       ');
  9334.     defkey(snil,    'nil       ');
  9335.     defkey(snot,    'not       ');
  9336.     defkey(sof,    'of        ');
  9337.     defkey(sor,    'or        ');
  9338.     defkey(sother2,    anothersym);    (* non-standard *)
  9339.     defkey(sother,    othersym);    (* non-standard *)
  9340.     defkey(spacked,    'packed    ');
  9341.     defkey(sproc,    'procedure ');
  9342.     defkey(spgm,    'program   ');
  9343.     defkey(srecord,    'record    ');
  9344.     defkey(srepeat,    'repeat    ');
  9345.     defkey(sset,    'set       ');
  9346.     defkey(sthen,    'then      ');
  9347.     defkey(sto,    'to        ');
  9348.     defkey(stype,    'type      ');
  9349.     defkey(suntil,    'until     ');
  9350.     defkey(svar,    'var       ');
  9351.     defkey(swhile,    'while     ');
  9352.     defkey(swith,    'with      ');
  9353.     defkey(seof,    dummysym);    (* dummy entry *)
  9354.  
  9355.     (* C language operator priorities *)
  9356.     cprio[nformat]    := 0;
  9357.     cprio[nrange]    := 0;
  9358.     cprio[nin]    := 0;
  9359.     cprio[nset]    := 0;
  9360.     cprio[nassign]    := 0;
  9361.     cprio[nor]    := 1;
  9362.     cprio[nand]    := 2;
  9363.     cprio[neq]    := 3;
  9364.     cprio[nne]    := 3;
  9365.     cprio[nlt]    := 3;
  9366.     cprio[nle]    := 3;
  9367.     cprio[ngt]    := 3;
  9368.     cprio[nge]    := 3;
  9369.     cprio[nplus]    := 4;
  9370.     cprio[nminus]    := 4;
  9371.     cprio[nmul]    := 5;
  9372.     cprio[ndiv]    := 5;
  9373.     cprio[nmod]    := 5;
  9374.     cprio[nquot]    := 5;
  9375.     cprio[nnot]    := 6;
  9376.     cprio[numinus]    := 6;
  9377.     cprio[nuplus]    := 7;
  9378.     cprio[nindex]    := 7;
  9379.     cprio[nselect]    := 7;
  9380.     cprio[nderef]    := 7;
  9381.     cprio[ncall]    := 7;
  9382.     cprio[nid]    := 7;
  9383.     cprio[nchar]    := 7;
  9384.     cprio[ninteger]    := 7;
  9385.     cprio[nreal]    := 7;
  9386.     cprio[nstring]    := 7;
  9387.     cprio[nnil]    := 7;
  9388.  
  9389.     (* Pascal language operator priorities *)
  9390.     pprio[nassign]    := 0;
  9391.     pprio[nformat]    := 0;
  9392.     pprio[nrange]    := 1;
  9393.     pprio[nin]    := 1;
  9394.     pprio[neq]    := 1;
  9395.     pprio[nne]    := 1;
  9396.     pprio[nlt]    := 1;
  9397.     pprio[nle]    := 1;
  9398.     pprio[ngt]    := 1;
  9399.     pprio[nge]    := 1;
  9400.     pprio[nor]    := 2;
  9401.     pprio[nplus]    := 2;
  9402.     pprio[nminus]    := 2;
  9403.     pprio[nand]    := 3;
  9404.     pprio[nmul]    := 3;
  9405.     pprio[ndiv]    := 3;
  9406.     pprio[nmod]    := 3;
  9407.     pprio[nquot]    := 3;
  9408.     pprio[nnot]    := 4;
  9409.     pprio[numinus]    := 4;
  9410.     pprio[nuplus]    := 5;
  9411.     pprio[nset]    := 6;
  9412.     pprio[nindex]    := 6;
  9413.     pprio[nselect]    := 6;
  9414.     pprio[nderef]    := 6;
  9415.     pprio[ncall]    := 6;
  9416.     pprio[nid]    := 6;
  9417.     pprio[nchar]    := 6;
  9418.     pprio[ninteger]    := 6;
  9419.     pprio[nreal]    := 6;
  9420.     pprio[nstring]    := 6;
  9421.     pprio[nnil]    := 6;
  9422.  
  9423.     (* table of C keywords/functions (which Pascal doesn't know about) *)
  9424.     defname(cabort,        'abort     ');    (* OS *)
  9425.     defname(cbreak,        'break     ');
  9426.     defname(ccontinue,    'continue  ');
  9427.     defname(cdefine,    'define    ');
  9428.     defname(cdefault,    'default   ');
  9429.     defname(cdouble,    'double    ');
  9430.     defname(cedata,        'edata     ');    (* OS *)
  9431.     defname(cenum,        'enum      ');
  9432.     defname(cetext,        'etext     ');    (* OS *)
  9433.     defname(cextern,    'extern    ');
  9434.     defname(cfclose,    'fclose    ');    (* LIB *)
  9435.     defname(cfflush,    'fflush    ');    (* LIB *)
  9436.     defname(cfgetc,        'fgetc     ');    (* LIB *)
  9437.     defname(cfloat,        'float     ');
  9438.     defname(cfloor,        'floor     ');    (* OS *)
  9439.     defname(cfprintf,    'fprintf   ');    (* LIB *)
  9440.     defname(cfputc,        'fputc     ');    (* LIB *)
  9441.     defname(cfread,        'fread     ');    (* LIB *)
  9442.     defname(cfscanf,    'fscanf    ');    (* LIB *)
  9443.     defname(cfwrite,    'fwrite    ');    (* LIB *)
  9444.     defname(cgetc,        'getc      ');    (* OS *)
  9445.     defname(cgetpid,    'getpid    ');    (* OS *)
  9446.     defname(cint,        'int       ');
  9447.     defname(cinclude,    'include   ');
  9448.     defname(clong,        'long      ');
  9449.     defname(clog,        'log       ');    (* OS *)
  9450.     defname(cmain,        'main      ');
  9451.     defname(cmalloc,    'malloc    ');    (* LIB *)
  9452.     defname(cprintf,    'printf    ');    (* LIB *)
  9453.     defname(cpower,        'pow       ');    (* OS *)
  9454.     defname(cputc,        'putc      ');    (* LIB *)
  9455.     defname(cread,        'read      ');    (* OS *)
  9456.     defname(creturn,    'return    ');
  9457.     defname(cregister,    'register  ');
  9458.     defname(crewind,    'rewind    ');    (* LIB *)
  9459.     defname(cscanf,        'scanf     ');    (* LIB *)
  9460.     defname(csetbits,    'setbits   ');
  9461.     defname(csetword,    'setword   ');
  9462.     defname(csetptr,    'setptr    ');
  9463.     defname(cshort,        'short     ');
  9464.     defname(csigned,    'signed    ');
  9465.     defname(csizeof,    'sizeof    ');
  9466.     defname(csprintf,    'sprintf   ');    (* LIB *)
  9467.     defname(cstatic,    'static    ');
  9468.     defname(cstdin,        'stdin     ');    (* LIB *)
  9469.     defname(cstdout,    'stdout    ');    (* LIB *)
  9470.     defname(cstderr,    'stderr    ');    (* LIB *)
  9471.     defname(cstrncmp,    'strncmp   ');    (* OS *)
  9472.     defname(cstrncpy,    'strncpy   ');    (* OS *)
  9473.     defname(cstruct,    'struct    ');
  9474.     defname(cswitch,    'switch    ');
  9475.     defname(ctypedef,    'typedef   ');
  9476.     defname(cundef,        'undef     ');
  9477.     defname(cungetc,    'ungetc    ');    (* LIB *)
  9478.     defname(cunion,        'union     ');
  9479.     defname(cunlink,    'unlink    ');    (* OS *)
  9480.     defname(cfseek,        'fseek     ');    (* LIB *)
  9481.     defname(cgetchar,    'getchar   ');    (* LIB *)
  9482.     defname(cputchar,    'putchar   ');    (* LIB *)
  9483.     defname(cunsigned,    'unsigned  ');
  9484.     defname(cwrite,        'write     ');    (* OS *)
  9485.  
  9486.     (* create predefined identifiers *)
  9487.     defid(nfunc,    dabs,        'abs       ');
  9488.     defid(nfunc,    darctan,    'arctan    ');
  9489.     defid(nvar,    dargc,        'argc      ');    (* OS *)
  9490.     defid(nproc,    dargv,        'argv      ');    (* OS *)
  9491. (* Break is a stream-flush command, used by TeXware *)
  9492.     defid(nfunc,    dbreak,        'break     ');    (* OS *)
  9493.     defid(nscalar,    dboolean,    'boolean   ');
  9494.     defid(ntype,    dchar,        'char      ');
  9495.     defid(nfunc,    dchr,        'chr       ');
  9496.     defid(nproc,    dclose,        'close     ');    (* OS *)
  9497.     defid(nfunc,    dcos,        'cos       ');
  9498.     defid(nproc,    ddispose,    'dispose   ');
  9499.     defid(nid,    dfalse,        'false     ');
  9500.     defid(nvar,    derroutput,    'erroutput ');
  9501.     defid(nfunc,    deof,        'eof       ');
  9502.     defid(nfunc,    deoln,        'eoln      ');
  9503.     defid(nproc,    dexit,        'exit      ');    (* OS *)
  9504.     defid(nfunc,    dexp,        'exp       ');
  9505.     defid(nproc,    dflush,        'flush     ');  (* OS *)
  9506.     defid(nproc,    dget,        'get       ');
  9507.     defid(nproc,    dhalt,        'halt      ');    (* OS *)
  9508.     defid(nvar,    dinput,        'input     ');
  9509.     defid(ntype,    dinteger,    'integer   ');
  9510.     defid(nfunc,    dln,        'ln        ');
  9511.     defid(nconst,    dmaxint,    'maxint    ');
  9512.     defid(nproc,    dnew,        'new       ');
  9513.     defid(nfunc,    dodd,        'odd       ');
  9514.     defid(nfunc,    dord,        'ord       ');
  9515.     defid(nvar,    doutput,    'output    ');
  9516.     defid(nproc,    dpack,        'pack      ');
  9517.     defid(nproc,    dpage,        'page      ');
  9518.     defid(nfunc,    dpred,        'pred      ');
  9519.     defid(nproc,    dprompt,    'prompt    '); (* OS *)
  9520.     defid(nproc,    dput,        'put       ');
  9521.     defid(nproc,    dread,        'read      ');
  9522.     defid(nproc,    dreadln,    'readln    ');
  9523.     defid(ntype,    dreal,        'real      ');
  9524.     defid(nproc,    dreset,        'reset     ');
  9525.     defid(nproc,    drewrite,    'rewrite   ');
  9526.     defid(nfunc,    dround,        'round     ');
  9527.     defid(nproc,    dseek,        'seek      ');
  9528.     defid(nfunc,    dsin,        'sin       ');
  9529.     defid(nfunc,    dsqr,        'sqr       ');
  9530.     defid(nfunc,    dsqrt,        'sqrt      ');
  9531.     defid(nfunc,    dsucc,        'succ      ');
  9532.     defid(nfunc,    dtell,        'tell      ');
  9533.     defid(ntype,    dtext,        'text      ');
  9534.     defid(nid,    dtrue,        'true      ');
  9535.     defid(nfunc,    dtrunc,        'trunc     ');
  9536.     defid(nfunc,    dtan,        'tan       ');
  9537.     defid(nproc,    dunpack,    'unpack    ');
  9538.     defid(nproc,    dwrite,        'write     ');
  9539.     defid(nproc,    dwriteln,    'writeln   ');
  9540.  
  9541.     defid(nfield,    dzfp,        '$p        ');    (* for internal use *)
  9542.     defid(ntype,    dztring,    '$ztring   ');
  9543.  
  9544.     (* bind constants and variables *)
  9545.     deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
  9546.     deftab[dfalse]^.tnext := deftab[dtrue];
  9547.     currsym.st := sinteger;
  9548.     currsym.vint := maxint;
  9549.     deftab[dmaxint]^.tbind := mklit;
  9550.     deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
  9551.     deftab[dinput]^.tbind := deftab[dtext]^.tbind;
  9552.     deftab[doutput]^.tbind := deftab[dtext]^.tbind;
  9553.     deftab[derroutput]^.tbind := deftab[dtext]^.tbind;
  9554.  
  9555.     for t := tnone to terror do
  9556.         begin
  9557.         (* for predefined types: set up pointers to "npredef" nodes
  9558.            describing type, fill in constant identifying type *)
  9559.         case t of
  9560.           tboolean:
  9561.             typnods[t] := deftab[dboolean]^.tbind;
  9562.           tchar:
  9563.             typnods[t] := deftab[dchar]^.tbind;
  9564.           tinteger:
  9565.             typnods[t] := deftab[dinteger]^.tbind;
  9566.           treal:
  9567.             typnods[t] := deftab[dreal]^.tbind;
  9568.           ttext:
  9569.             typnods[t] := deftab[dtext]^.tbind;
  9570.           tstring:
  9571.             typnods[t] := deftab[dztring]^.tbind;
  9572.           tnil,
  9573.           tset,
  9574.           tpoly,
  9575.           tnone:
  9576.             typnods[t] := mknode(npredef);
  9577.           terror:
  9578.             (* no op *)
  9579.         end;(* case *)
  9580.         if t in [tchar, tinteger, treal, ttext, tnone, tpoly,
  9581.                         tstring, tnil, tset] then
  9582.             typnods[t]^.tobtyp := t
  9583.         end;
  9584.  
  9585.     (* fix name and type of field "fp" *)
  9586.     fixfp(defnams[dzfp]^.lid^.istr);
  9587.     deftab[dzfp]^.tbind := deftab[dinteger]^.tbind;
  9588.  
  9589.     for d := dabs to dztring do
  9590.         linkup(nil, deftab[d]);
  9591.  
  9592.     deftab[dchr]^.tfuntyp := typnods[tchar];
  9593.  
  9594.     deftab[deof]^.tfuntyp := typnods[tboolean];
  9595.     deftab[deoln]^.tfuntyp := typnods[tboolean];
  9596.     deftab[dodd]^.tfuntyp := typnods[tboolean];
  9597.  
  9598.     deftab[dord]^.tfuntyp := typnods[tinteger];
  9599.     deftab[dround]^.tfuntyp := typnods[tinteger];
  9600.     deftab[dtell]^.tfuntyp := typnods[tinteger];
  9601.     deftab[dtrunc]^.tfuntyp := typnods[tinteger];
  9602.  
  9603.     deftab[darctan]^.tfuntyp := typnods[treal];
  9604.     deftab[dcos]^.tfuntyp := typnods[treal];
  9605.     deftab[dsin]^.tfuntyp := typnods[treal];
  9606.     deftab[dtan]^.tfuntyp := typnods[treal];
  9607.     deftab[dsqrt]^.tfuntyp := typnods[treal];
  9608.     deftab[dexp]^.tfuntyp := typnods[treal];
  9609.     deftab[dln]^.tfuntyp := typnods[treal];
  9610.  
  9611.     deftab[dsqr]^.tfuntyp := typnods[tpoly];
  9612.     deftab[dabs]^.tfuntyp := typnods[tpoly];
  9613.     deftab[dpred]^.tfuntyp := typnods[tpoly];
  9614.     deftab[dsucc]^.tfuntyp := typnods[tpoly];
  9615.  
  9616.     deftab[dargv]^.tfuntyp := typnods[tnone];
  9617.     deftab[dbreak]^.tfuntyp := typnods[tnone];
  9618.     deftab[ddispose]^.tfuntyp := typnods[tnone];
  9619.     deftab[dexit]^.tfuntyp := typnods[tnone];
  9620.     deftab[dflush]^.tfuntyp := typnods[tnone];
  9621.     deftab[dget]^.tfuntyp := typnods[tnone];
  9622.     deftab[dhalt]^.tfuntyp := typnods[tnone];
  9623.     deftab[dnew]^.tfuntyp := typnods[tnone];
  9624.     deftab[dpack]^.tfuntyp := typnods[tnone];
  9625.     deftab[dput]^.tfuntyp := typnods[tnone];
  9626.     deftab[dprompt]^.tfuntyp := typnods[tnone];
  9627.     deftab[dread]^.tfuntyp := typnods[tnone];
  9628.     deftab[dreadln]^.tfuntyp := typnods[tnone];
  9629.     deftab[dreset]^.tfuntyp := typnods[tnone];
  9630.     deftab[drewrite]^.tfuntyp := typnods[tnone];
  9631.     deftab[dseek]^.tfuntyp := typnods[tnone];
  9632.     deftab[dwrite]^.tfuntyp := typnods[tnone];
  9633.     deftab[dwriteln]^.tfuntyp := typnods[tnone];
  9634.     deftab[dunpack]^.tfuntyp := typnods[tnone];
  9635.  
  9636.     (* set up definitions for integer subranges *)
  9637.     nmachdefs := 0;
  9638.     defmach(0,        255,        'unsigned char   '); (* CPU *)
  9639.     defmach(-128,        127,        'char            '); (* CPU *)
  9640.     defmach(0,        65535,        'unsigned short  '); (* CPU *)
  9641.     defmach(-32768,        32767,        'short           '); (* CPU *)
  9642.     defmach(-2147483647,    2147483647,    'long            '); (* CPU *)
  9643. {    defmach(0,        4294967295,    'unsigned long   ');}(* CPU *)
  9644. end;    (* initialize *)
  9645.  
  9646. (*    Action to take when an error is detected.            *)
  9647. procedure error;
  9648.  
  9649. begin
  9650.     prtmsg(m);
  9651. { IF-PASCAL
  9652.     goto 9999;
  9653. END-IF-PASCAL }
  9654. { IF-C }
  9655.     exit(1);
  9656. { END-IF-C }
  9657. end;
  9658.  
  9659. (*    Action to take when a fatal error is detected.            *)
  9660. procedure fatal;
  9661.  
  9662. begin
  9663.     prtmsg(m);
  9664. { IF-PASCAL
  9665.     goto 9999;
  9666. END-IF-PASCAL }
  9667. { IF-C }
  9668.     exit(1);
  9669. { END-IF-C }
  9670. end;
  9671.  
  9672.  
  9673. begin    (* program *)
  9674.     initialize;
  9675.     parse;
  9676.     lineno := 0; lastline := 0;
  9677.     transform;
  9678.     emit;
  9679. 9999:
  9680.     (* the very *)
  9681. end.
  9682.