home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume10 / ptoc / part12 / ptc.p.1
Encoding:
Text File  |  1987-07-28  |  58.0 KB  |  2,502 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(), rewind() 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);
  53.  
  54. label    9999;                (* end of program        *)
  55.  
  56. const    version        = '@(#)ptc.p    1.5  Date 87/05/01';
  57.  
  58.     keytablen    = 38;        (* nr of keywords        *)
  59.     keywordlen    = 10;        (* length of a keyword        *)
  60.     othersym    = 'otherwise '; (* keyword for others        *)
  61.     externsym    = 'external  '; (* keyword for external        *)
  62.     dummysym    = '          '; (* dummy keyword        *)
  63.  
  64.     (* a Pascal set is implemented as an array of "wordtype" where    *)
  65.     (* each element contains bits numbered from 0 to "setbits"    *)
  66.     wordtype    = 'unsigned short';    (* CPU *)
  67.     setbits        = 15;            (* CPU *)
  68.  
  69.     (* a Pascal file is implemented as a struct which (among other    *)
  70.     (* things) contain a flag-field, currently 3 bits are used    *)
  71.     filebits    = 'unsigned short';    (* flags for files    *)
  72.     filefill    = 12;            (* 16 less used 3 bits    *)
  73.  
  74.     maxsetrange    = 15;            (* nr of words in a set    *)
  75.     scalbase    = 0;    (* ordinal value of first scalar member    *)
  76.  
  77.     maxprio        = 7;
  78.  
  79.     maxmachdefs    = 8;    (* max nr of machine integer types    *)
  80.     machdeflen    = 16;    (* max length of machine int type name    *)
  81.  
  82.     (* limit of identifier table, identifiers and strings are saved    *)
  83.     (* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char    *)
  84.     maxstrblk    = 1023;
  85.     maxblkcnt    = 63;
  86.     maxstrstor    = 65535; (* maxstrstor should be ==
  87.                     (maxblkcnt+1) * (maxstrblk+1) - 1 *)
  88.  
  89.     maxtoknlen    = 127;    (* max size of token (i.e. identifier,
  90.                    string or number); must be > keywordlen
  91.                    and should be <= 256, see hashtokn()    *)
  92.  
  93.     hashmax        = 64;    (* size of hashtable - 1        *)
  94.  
  95.     null        = 0;    (* "impossible" character value, CHAR;
  96.                    a char with this value is used as delimiter
  97.                    of strings in "strstor" and in toknbuffers;
  98.                    it is also used as end-of-input marker by
  99.                    the input procedures in lexical analysis *)
  100.  
  101.     minchar        = null;
  102.     maxchar        = 127;    (* greatest possible character, CHAR; limits
  103.                    the number of elements in type "char" *)
  104.  
  105.     (* tmpfilename is used in the generated code to obtain names of
  106.        temporary files for reset/rewrite, the last character is supplied
  107.        by the reset/rewrite routine *)
  108.     tmpfilename    = '"/tmp/ptc%d%c", getpid(), '; (* OS *)
  109.  
  110.     (* some frequently used characters *)
  111.     space        = ' ';
  112.     tab1        = '    ';
  113.     tab2        = '        ';
  114.     tab3        = '            ';
  115.     tab4        = '                ';
  116.     bslash        = '\';
  117.     nlchr        = '''\n''';
  118.     ffchr        = '''\f''';
  119.     nulchr        = '''\0''';
  120.     spchr        = ''' ''';
  121.     quote        = '''';
  122.     cite        = '"';
  123.     xpnent        = 'e';        (* exponent char in output. CPU    *)
  124.     percent        = '%';
  125.     uscore        = '_';
  126.     badchr        = '?';        (* CHAR *)
  127.     okchr        = quote;    (* CHAR *)
  128.  
  129.     tabwidth    = 8;        (* width of a tab-stop. OS    *)
  130.  
  131.     echo        = false;     (* echo input as read        *)
  132.     diffcomm    = false;     (* comment delimiters different    *)
  133.     lazyfor        = false;     (* compile for-stmts a la C    *)
  134.     unionnew    = true;     (* malloc unions for variants    *)
  135.  
  136.     inttyp        = 'int';    (* for predefined functions    *)
  137.     chartyp        = 'char';
  138.     setwtyp        = 'setword';
  139.     setptyp        = 'setptr';
  140.     floattyp    = 'float';
  141.     doubletyp    = 'double';
  142.     dblcast        = '(double)';    (* for predefined functions    *)
  143.  
  144.     realtyp        = doubletyp;    (* user real-vars and functions    *)
  145.  
  146.     voidtyp        = 'void';    (* for procedures         *)
  147.     voidcast    = '(void)';
  148.  
  149.     intlen        = 10;        (* length of written integer    *)
  150.     fixlen        = 20;        (* length of written real    *)
  151.  
  152. type
  153.     hashtyp    = 0 .. hashmax;        (* index to hash-tables    *)
  154.  
  155.     strindx    = 0 .. maxstrstor;    (* index to "strstor"        *)
  156.  
  157.     (* string-table "strstor" is implemented as an array that is grown
  158.        dynamically by adding blocks when needed *)
  159.     strbidx    = 0 .. maxstrblk;
  160.     strblk    = array [ strbidx ] 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    : 0 .. 127;    (* # 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.         dboolean,    dchar,        dchr,        dclose,
  191.         dcos,        ddispose,    deof,        deoln,
  192.         dexit,        dexp,        dfalse,        dflush,
  193.         dget,        dhalt,        dinput,        dinteger,
  194.         dln,        dmaxint,    dmessage,    dnew,
  195.         dodd,        dord,        doutput,    dpage,
  196.         dpack,        dpred,        dput,        dread,
  197.         dreadln,    dreal,        dreset,        drewrite,
  198.         dround,        dsin,        dsqr,        dsqrt,
  199.         dsucc,        dtext,        dtrue,        dtrunc,
  200.         dtan,        dwrite,        dwriteln,    dunpack,
  201.         dzinit,        dztring
  202.     );
  203.  
  204.     (* lexical symbol enumeration *)
  205.     symtyp    = (
  206.         (* keywords and eof are sorted alphabetically ...... *)
  207.         sand,        sarray,        sbegin,        scase,
  208.         sconst,        sdiv,        sdo,        sdownto,
  209.         selse,        send,        sextern,    sfile,
  210.         sfor,        sforward,    sfunc,        sgoto,
  211.         sif,        sinn,        slabel,        smod,
  212.         snil,        snot,        sof,        sor,
  213.         sother,        spacked,    sproc,        spgm,
  214.         srecord,    srepeat,    sset,        sthen,
  215.         sto,        stype,        suntil,        svar,
  216.         swhile,        swith,        seof,
  217.         (* ...... sorted *)
  218.                                 sinteger,
  219.         sreal,        sstring,    schar,        sid,
  220.         splus,        sminus,        smul,        squot,
  221.         sarrow,        slpar,        srpar,        slbrack,
  222.         srbrack,    seq,        sne,        slt,
  223.         sle,        sgt,        sge,        scomma,
  224.         scolon,        ssemic,        sassign,    sdotdot,
  225.         sdot
  226.     );
  227.     symset    = set of symtyp;
  228.  
  229.     (* lexical symbol definition *)
  230.     (* the lexical symbol holds a descriptor and the value of a symbol
  231.        read by the input procedures; note that real values are represented
  232.        as strings saved in "strstor" like ordinary strings to avoid using
  233.        float-variables and float-arithmetic in the translator *)
  234.     lexsym    =
  235.         record
  236.         case st : symtyp of
  237.           sid:        (vid    : idptr);
  238.           schar:    (vchr    : char);
  239.           sinteger:    (vint    : integer);
  240.           sreal:    (vflt    : strindx);
  241.           sstring:    (vstr    : strindx);
  242.         end;
  243.  
  244.     (* enumeration of symnode variants *)
  245.     ltypes = (
  246.         lpredef,    lidentifier,    lfield,        lforward,
  247.         lpointer,    lstring,    llabel,        lforwlab,
  248.         linteger,    lreal,        lcharacter
  249.     );
  250.  
  251.     declptr    = ^ declnode;
  252.     treeptr    = ^ treenode;
  253.     symptr    = ^ symnode;
  254.     (* identifier/literal symbol definition *)
  255.     (* in a given scope an identifier or a label is uniquely represented
  256.        by a "symnode"; in order to have a uniform treatment of all objects
  257.        occurring in the same syntactical positions (and hence in the parse-
  258.        tree) the literal constants are represented in a similar manner *)
  259.     symnode    =
  260.         record
  261.         lsymdecl    : treeptr;    (* symbol decl. point    *)
  262.         lnext        : symptr;    (* symtab chain pointer    *)
  263.         ldecl        : declptr;    (* backptr to symtab    *)
  264.         case lt : ltypes of
  265.           lpredef,            (* a predefined id    *)
  266.           lfield,            (* a record field    *)
  267.           lpointer,            (* a pointer id        *)
  268.           lidentifier,            (* an identifier    *)
  269.           lforward:
  270.             (
  271.             lid    : idptr;    (* ptr to its idnode    *)
  272.             lused    : boolean    (* true if symbol used    *)
  273.             );
  274.           lstring:            (* a string literal     *)
  275.             (
  276.             lstr    : strindx    (* index to "strstor"    *)
  277.             );
  278.           lreal:            (* a real literal    *)
  279.             (
  280.             lfloat    : strindx    (* index to "strstor"    *)
  281.             );
  282.           lforwlab,            (* a declared label    *)
  283.           llabel:            (* label decl & defined    *)
  284.             (
  285.             lno    : integer;    (* label number        *)
  286.             lgo    : boolean    (* non-local usage    *)
  287.             );
  288.           linteger:            (* an integer literal    *)
  289.             (
  290.             linum    : integer    (* its value        *)
  291.             );
  292.           lcharacter:            (* a character literal    *)
  293.             (
  294.             lchar    : char        (* its value        *)
  295.             )
  296.         end;
  297.  
  298.     (* symbol table definition *)
  299.     (* the symbol table consists of symnodes chained along the lnext
  300.        field; the nodes are connected in reverse order of occurence (last
  301.        declared, first in chain) in the slot in the declnode determined
  302.        by the hashfunction; when a new scope is entered a new declnode is
  303.        manufactured and the previous one is hooked to the dprev field, thus
  304.        nested scopes are represented by a list of declnodes *)
  305.     declnode = record
  306.             dprev    : declptr;
  307.             ddecl    : array [ hashtyp ] of symptr
  308.            end;
  309.  
  310.     (* enumeration of nodes in parse tree *)
  311.     (* NOTE: the subrange [ assignment .. nil ]  have priorities *)
  312.     treetyp    = (
  313.         npredef,    npgm,        nfunc,        nproc,
  314.         nlabel,        nconst,        ntype,        nvar,
  315.         nvalpar,    nvarpar,    nparproc,    nparfunc,
  316.         nsubrange,    nvariant,    nfield,        nrecord,
  317.         narray,        nconfarr,    nfileof,    nsetof,
  318.         nbegin,        nptr,        nscalar,    nif,
  319.         nwhile,        nrepeat,    nfor,        ncase,
  320.         nchoise,    ngoto,        nwith,        nwithvar,
  321.         nempty,        nlabstmt,    nassign,    nformat,
  322.         nin,        neq,        nne,        nlt,
  323.         nle,        ngt,        nge,        nor,
  324.         nplus,        nminus,        nand,        nmul,
  325.         ndiv,        nmod,        nquot,        nnot,
  326.         numinus,    nuplus,        nset,        nrange,
  327.         nindex,        nselect,    nderef,        ncall,
  328.         nid,        nchar,        ninteger,    nreal,
  329.         nstring,    nnil,        npush,        npop,
  330.         nbreak
  331.     );
  332.  
  333.     (* enumeration of predefined types *)
  334.     pretyps = (
  335.         tnone,        tboolean,    tchar,        tinteger,
  336.         treal,        tstring,    tnil,        tset,
  337.         ttext,        tpoly,        terror
  338.     );
  339.  
  340.     (* enumeration of some special attributes *)
  341.     attributes = (
  342.         anone, aregister, aextern, areference
  343.     );
  344.  
  345.     (* parse tree definition *)
  346.     (* the sourceprogram is represented by a treestructure built from
  347.        treenodes where each node corresponds to one syntactic form from
  348.        the pascal program *)
  349.     treenode =
  350.         record
  351.         tnext,            (* ptr to next node in a list    *)
  352.         ttype,            (* pointer to nodes type    *)
  353.         tup    : treeptr;    (* ptr to parent node        *) 
  354.         case tt : treetyp of
  355.           npredef:        (* predefined object decl    *)
  356.             (
  357.             tdef:        (* predefined object descr.    *)
  358.                 predefs;
  359.             tobtyp:        (* object type            *)
  360.                 pretyps
  361.             );
  362.           npgm,            (* program declaration        *)
  363.           nproc,        (* procedure declaration    *)
  364.           nfunc:        (* function declaration        *)
  365.             (
  366.             tsubid,        (* subr. identifier (nid)    *)
  367.             tsubpar,    (* parameter list        *)
  368.             tfuntyp,    (* function type (nid)        *)
  369.             tsublab,    (* label decl list (nlabel)    *)
  370.             tsubconst,    (* const decl list (nconst)    *)
  371.             tsubtype,    (* type decl list (ntype)    *)
  372.             tsubvar,    (* var decl list (nvar)        *)
  373.             tsubsub,    (* subr. decl (nproc/nfunc)    *)
  374.             tsubstmt:    (* stmt. list (NOT nbegin)    *)
  375.                 treeptr;
  376.             tstat:        (* static declaration level    *)
  377.                 integer;
  378.             tscope:        (* symbol table for local id's    *)
  379.                  declptr
  380.             );
  381.           nvalpar,        (* value parameter declaration    *)
  382.           nvarpar,        (* var parameter declaration    *)
  383.           nconst,        (* constant declaration        *)
  384.           ntype,        (* type declaration        *)
  385.           nfield,        (* record field declaration    *)
  386.           nvar:            (* var declaration declaration    *)
  387.             (
  388.             tidl,        (* list of declared id's (nid)    *)
  389.             tbind:        (* var/type-type, const-value    *)
  390.                 treeptr;
  391.             tattr:        (* special attributes for vars    *)
  392.                 attributes
  393.             );
  394.           nparproc,        (* parameter procedure        *)
  395.           nparfunc:        (* parameter function        *)
  396.             (
  397.             tparid,        (* parm proc/func id (nid)    *)
  398.             tparparm,    (* parm proc/func parm decl    *)
  399.             tpartyp:    (* parm func type (nid)        *)
  400.                 treeptr
  401.             );
  402.           nptr:            (* pointer constructor        *)
  403.             (
  404.             tptrid:        (* referenced type (nid)    *)
  405.                 treeptr;
  406.             tptrflag:    (* have seen node before    *)
  407.                 boolean
  408.             );
  409.           nscalar:        (* scalar type constructor    *)
  410.             (
  411.             tscalid:    (* list of scalar ids (nid)    *)
  412.                 treeptr
  413.             );
  414.           nfileof,        (* file type constructor    *)
  415.           nsetof:        (* set type constructor        *)
  416.             (
  417.             tof:        (* set/file component type    *)
  418.                 treeptr
  419.             );
  420.           nsubrange:        (* subrange type constructor    *)
  421.             (
  422.             tlo, thi:    (* subrange limits        *)
  423.                 treeptr
  424.             );
  425.           nvariant:        (* record variant constructor    *)
  426.             (
  427.             tselct,        (* selector list (constants)    *)
  428.             tvrnt:        (* variant field decl (nrecord)    *)
  429.                 treeptr
  430.             );
  431.  
  432.         (* the tuid field is used to attach a name to variants since
  433.            C requires all union members to have names *)
  434.           nrecord:        (* record/variant constructor    *)
  435.             (
  436.             tflist,        (* fixed field list (nfield)    *)
  437.             tvlist:        (* variant list (nvariant)    *)
  438.                 treeptr;
  439.             tuid:        (* variant name            *)
  440.                 idptr;
  441.             trscope:    (* symbol table for local id's    *)
  442.                  declptr
  443.             );
  444.           nconfarr:        (* conformant array constructor    *)
  445.             (
  446.             tcindx,        (* index declaration        *)
  447.             tindtyp,    (* conf. arr. index type (nid)    *)
  448.             tcelem:        (* array element type decl    *)
  449.                 treeptr;
  450.             tcuid:        (* variant name            *)
  451.                 idptr
  452.             );
  453.           narray:        (* array type constructor    *)
  454.             (
  455.             taindx,        (* index declaration        *)
  456.             taelem:        (* array element type decl    *)
  457.                 treeptr
  458.             );
  459.           nbegin:        (* begin statement        *)
  460.             (
  461.             tbegin:        (* statement list        *)
  462.                 treeptr
  463.             );
  464.           nlabstmt:        (* labeled statement        *)
  465.             (
  466.             tlabno,        (* label number (nlabel)    *)
  467.             tstmt:        (* statement            *)
  468.                 treeptr
  469.             );
  470.           ngoto:        (* goto statement        *)
  471.             (
  472.             tlabel:        (* label to go to (nlabel)    *)
  473.                 treeptr
  474.             );
  475.  
  476.           nassign:        (* assignment statement        *)
  477.             (
  478.             tlhs,        (* variable            *)
  479.             trhs:        (* value            *)
  480.                 treeptr
  481.             );
  482.  
  483.         (* npush/npop is used in proc/func which have local variables
  484.            used in local proc/funcs; those variables are converted to
  485.            global ptrs initialized to reference the local variable *)
  486.           npush,        (* init code for proc/func    *)
  487.           npop:            (* exit code for proc/func    *)
  488.             (
  489.             tglob,        (* global identifier (nid)    *)
  490.             tloc,        (* local identifier (nid)    *)
  491.             ttmp:        (* temp store for global (nid)    *)
  492.                 treeptr
  493.             );
  494.  
  495.           nbreak:
  496.             (
  497.             tbrkid,        (* for-variable            *)
  498.             tbrkxp:        (* value for break        *)
  499.                 treeptr
  500.             );
  501.  
  502.           ncall:        (* procedure/function call    *)
  503.             (
  504.             tcall,        (* called identifier        *)
  505.             taparm:        (* actual paramters        *)
  506.                 treeptr
  507.             );
  508.           nif:            (* if statement            *)
  509.             (
  510.             tifxp,        (* conditional expression    *)
  511.             tthen,        (* stmt execd if true condition    *)
  512.             telse:        (* stmt execd if true condition    *)
  513.                 treeptr
  514.             );
  515.           nwhile:        (* while statemnet        *)
  516.             (
  517.             twhixp,        (* conditional expression    *)
  518.             twhistmt:    (* stmt execd if true condition    *)
  519.                 treeptr
  520.             );
  521.           nrepeat:        (* repeat statement        *)
  522.             (
  523.             treptstmt,    (* statement list        *)
  524.             treptxp:    (* conditional expression    *)
  525.                 treeptr
  526.             );
  527.           nfor:            (* for statement        *)
  528.             (
  529.             tforid,        (* loop control variable (nid)    *)
  530.             tfrom,        (* initial value        *)
  531.             tto,        (* final value            *)
  532.             tforstmt:    (* stmt execd in loop        *)
  533.                 treeptr;
  534.             tincr:        (* to/downto flag true <==> to    *)
  535.                 boolean
  536.             );
  537.           ncase:        (* case statement        *)
  538.             (
  539.             tcasxp,        (* selecting expression        *)
  540.             tcaslst,    (* list of choises        *)
  541.             tcasother:    (* default action        *)
  542.                 treeptr
  543.             );
  544.           nchoise:        (* a choise in a case-stmt    *)
  545.             (
  546.             tchocon,    (* list of constants        *)
  547.             tchostmt:    (* execd statement        *)
  548.                 treeptr
  549.             );
  550.           nwith:        (* with statment        *)
  551.             (
  552.             twithvar,    (* list of variables (nwithvar)    *)
  553.             twithstmt:    (* statement execd in new scope    *)
  554.                 treeptr
  555.             );
  556.  
  557.         (* the local symbol table holds identifiers, picked from
  558.            the record fields, temporarily declared during parsing
  559.            of remainder of with-statement; these identifiers are
  560.            later converted into fields referenced through a ptr *)
  561.           nwithvar:        (* variable in with statement    *)
  562.             (
  563.             texpw:        (* record variable        *)
  564.                 treeptr;
  565.             tenv:        (* symbol table for local scope    *)
  566.                 declptr
  567.             );
  568.  
  569.           nindex:        (* array indexing expression    *)
  570.             (
  571.             tvariable,    (* indexed variable        *)
  572.             toffset:    (* index expression        *)
  573.                 treeptr
  574.             );
  575.           nselect:        (* record field selection expr    *)
  576.             (
  577.             trecord,    (* record variable        *)
  578.             tfield:        (* selected field (nid)        *)
  579.                 treeptr
  580.             );
  581.  
  582.         (* binary operators or constructors *)
  583.           nrange,        (* .. (set range)    *)
  584.           nformat,        (* :  (write format)    *)
  585.           nin,            (* in            *)
  586.           neq,            (* =            *)
  587.           nne,            (* <>            *)
  588.           nlt,            (* <            *)
  589.           nle,            (* <=            *)
  590.           ngt,            (* >            *)
  591.           nge,            (* >=            *)
  592.           nor,            (* or            *)
  593.           nplus,        (* +            *)
  594.           nminus,        (* -            *)
  595.           nand,            (* and            *)
  596.           nmul,            (* *            *)
  597.           ndiv,            (* div            *)
  598.           nmod,            (* mod            *)
  599.           nquot:        (* /            *)
  600.             (
  601.             texpl,        (* left operand expr    *)
  602.             texpr:        (* right operand expr    *)
  603.                 treeptr
  604.             );
  605.  
  606.         (* unary operators or constructors; note that uplus is
  607.            used to represent any parenthesized expression *)
  608.           nderef,        (* ^ (ptr dereference)    *)
  609.           nnot,            (* not            *)
  610.           nset,            (* [ ] (set constr)    *)
  611.           nuplus,        (* +            *)
  612.           numinus:        (* -            *)
  613.             (
  614.             texps:        (* operand expression    *)
  615.                 treeptr
  616.             );
  617.  
  618.           nid,            (* identifier in decl or stmt    *)
  619.           nreal,        (* literal real (decl or stmt)    *)
  620.           ninteger,        (* literal int ( - " - )    *)
  621.           nchar,        (* literal char ( - " - )    *)
  622.           nstring,        (* literal string ( - " - )    *)
  623.           nlabel:        (* label (decl, defpt or use)    *)
  624.             (
  625.             tsym:
  626.                 symptr
  627.             );
  628.  
  629.           nnil,            (* nil (pointer constant)    *)
  630.           nempty:        (* empty statement        *)
  631.             ( );
  632.         end;
  633.  
  634.     (* "reserved" words and standard identifiers from C, C LIB and
  635.         OS environment excluding those reserved in Pascal *)
  636.     cnames = (
  637.         cabort,        cbreak,        ccontinue,    cdefine,
  638.         cdefault,    cdouble,    cedata,        cenum,
  639.         cetext,        cextern,    cfgetc,        cfclose,
  640.         cfflush,    cfloat,        cfloor,        cfprintf,
  641.         cfputc,        cfread,        cfscanf,    cfwrite,
  642.         cgetc,        cgetpid,    cint,        cinclude,
  643.         clong,        clog,        cmain,        cmalloc,
  644.         cprintf,    cpower,        cputc,        cread,
  645.         creturn,    cregister,    crewind,    cscanf,
  646.         csetbits,    csetword,    csetptr,    cshort,
  647.         csigned,    csizeof,    csprintf,    cstdin,
  648.         cstdout,    cstderr,    cstrncmp,    cstrncpy,
  649.         cstruct,    cstatic,    cswitch,    ctypedef,
  650.         cundef,        cungetc,    cunion,        cunlink,
  651.         cunsigned,    cwrite
  652.     );
  653.  
  654.     (* these are the detected errors. some are user-errors,
  655.        some are internal problems and some are host system errors *)
  656.     errors    = (
  657.         ebadsymbol,    elongstring,    elongtokn,    erange,
  658.         emanytokn,    enotdeclid,    emultdeclid,    enotdecllab,
  659.         emultdecllab,    emuldeflab,    ebadstring,    enulchr,
  660.         ebadchar,    eeofcmnt,    eeofstr,    evarpar,
  661.         enew,        esetbase,    esetsize,    eoverflow,
  662.         etree,        etag,        euprconf,    easgnconf,
  663.         ecmpconf,    econfconf,    evrntfile,    evarfile,
  664.         emanymachs,    ebadmach
  665.     );
  666.  
  667.     machdefstr = packed array [ 1 .. machdeflen ] of char;
  668.  
  669. var
  670.     usemax,            (* program needs max-function        *)
  671.     usejmps,        (* source program uses non-local gotos    *)
  672.     usecase,        (* source program has case-statement    *)
  673.     usesets,        (* source program uses set-operations    *)
  674.     useunion,
  675.     usediff,
  676.     usemksub,
  677.     useintr,
  678.     usesge,
  679.     usesle,
  680.     useseq,
  681.     usesne,
  682.     usememb,
  683.     useins,
  684.     usescpy,
  685.     usecomp,        (* source program uses string-compare    *)
  686.     usefopn,        (* source program uses reset/rewrite    *)
  687.     usescan,
  688.     usegetl,
  689.     usenilp,        (* source program uses nil-pointer     *)
  690.     usebool    : boolean;    (* source program writes boolean-values    *)
  691.  
  692.     top    : treeptr;    (* top of parsetree, result from parse    *)
  693.  
  694.     setlst    : treeptr;    (* list of set-initializations        *)
  695.     setcnt    : integer;    (* counter for setlst length        *)
  696.  
  697.     currsym    : lexsym;    (* current lexical symbol        *)
  698.  
  699.     keytab    : array [ 0 .. keytablen ] of    (* table of keywords    *)
  700.             record
  701.             wrd    : keyword;    (* keyword text        *)
  702.             sym    : symtyp    (* corresponding symbol    *)
  703.             end;
  704.  
  705.     strstor    : array [ strbcnt ] of strptr;    (* store for strings    *)
  706.     strfree    : strindx;            (* first free position    *)
  707.     strleft    : strbidx;            (* room in last blk    *)
  708.  
  709.     idtab    : array [ hashtyp ] of idptr;    (* hashed table of id's    *)
  710.  
  711.     symtab    : declptr;            (* table of symbols    *)
  712.  
  713.     statlvl,                (* static decl. level    *)
  714.     maxlevel : integer;            (*  - " - maximum value    *) 
  715.  
  716.     deftab    : array [ predefs ] of treeptr;    (* predefined idents.    *)
  717.     defnams    : array [ predefs ] of symptr;    (*        - " -        *)
  718.     typnods    : array [ pretyps ] of treeptr;    (* predef. types.    *)
  719.  
  720.     pprio,
  721.     cprio    : array [ nassign .. nnil ] of 0 .. maxprio;
  722.  
  723.     ctable    : array [ cnames ] of idptr;    (* table of C-keywords    *)
  724.  
  725.     nmachdefs : 0 .. maxmachdefs;
  726.     machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types    *)
  727.             record
  728.                 lolim, hilim    : integer;
  729.                 typstr        : strindx
  730.             end;
  731.  
  732.     lineno,                    (* input line number    *)
  733.     colno,                    (* input column number    *)
  734.     lastcol,                (* last OK input column    *)
  735.     lastline : integer;            (* last OK input line    *)
  736.  
  737.     lasttok    : toknbuf;            (* last input token    *)
  738.  
  739.     varno    : integer;        (* counter for unique id's    *)
  740.  
  741.     hexdig    : packed array [ 0 .. 15 ] of char;
  742.  
  743. (*    Prtmsg produces an error message. It asssumes that procedure    *)
  744. (*    "message" (predefined) will "writeln" to user tty. OS        *)
  745. procedure prtmsg(m : errors);
  746.  
  747. const    user    = 'Error: ';
  748.     restr    = 'Implementation restriction: ';
  749.     inter    = '* Internal error * ';
  750.     xtoklen    = 64;                (* should be <= maxtoklen *)
  751.  
  752. var    i    : toknidx;
  753.     xtok    : packed array [ 1 .. xtoklen ] of char;
  754.  
  755. begin
  756.     case m of
  757.       ebadsymbol:
  758.         message(user, 'Unexpected symbol');
  759.       ebadchar:
  760.         message(user, 'Bad character');
  761.       elongstring:
  762.         message(restr, 'Too long string');
  763.       ebadstring:
  764.         message(user, 'Newline in string or character');
  765.       eeofstr:
  766.         message(user, 'End of file in string or character');
  767.       eeofcmnt:
  768.         message(user, 'End of file in comment');
  769.       elongtokn:
  770.         message(restr, 'Too long identfier');
  771.       emanytokn:
  772.         message(restr, 'Too many strings, identifiers or real numbers');
  773.       enotdeclid:
  774.         message(user, 'Identifier not declared');
  775.       emultdeclid:
  776.         message(user, 'Identifier declared twice');
  777.       enotdecllab:
  778.         message(user, 'Label not declared');
  779.       emultdecllab:
  780.         message(user, 'Label declared twice');
  781.       emuldeflab:
  782.         message(user, 'Label defined twice');
  783.       evarpar:
  784.         message(user, 'Actual parameter not a variable');
  785.       enulchr:
  786.         message(restr, 'Cannot handle nul-character in strings');
  787.       enew:
  788.         message(restr, 'New returned a nil-pointer');
  789.       eoverflow:
  790.         message(restr, 'Token buffer overflowed');
  791.       esetbase:
  792.         message(restr, 'Cannot handle sets with base >> 0');
  793.       esetsize:
  794.         message(restr, 'Cannot handle sets with very large range');
  795.       etree:
  796.         message(inter, 'Bad tree structure');
  797.       etag:
  798.         message(inter, 'Cannot find tag');
  799.       evrntfile:
  800.         message(restr, 'Cannot initialize files in record variants');
  801.       evarfile:
  802.         message(restr, 'Cannot handle files in structured variables');
  803.       euprconf:
  804.         message(inter, 'No upper bound on conformant arrays');
  805.       easgnconf:
  806.         message(inter, 'Cannot assign conformant arrays');
  807.       ecmpconf:
  808.         message(inter, 'Cannot compare conformant arrays');
  809.       econfconf:
  810.         message(restr, 'Cannot handle nested conformat arrays');
  811.       erange:
  812.         message(inter, 'Cannot find C-type for integer-subrange');
  813.       emanymachs:
  814.         message(restr, 'Too many machine integer types');
  815.       ebadmach:
  816.         message(inter, 'Bad name for machine integer type');
  817.     end;(* case *)
  818.     if lastline <> 0 then
  819.         begin
  820.         (* error detected during parsing,
  821.             report line/column and print the offending symbol *)
  822.         message('Line ', lastline:1, ', col ', lastcol:1, ':');
  823.         if m in [enulchr, ebadchar, ebadstring, ebadsymbol,
  824.             emuldeflab, emultdecllab, enotdecllab, emultdeclid,
  825.             enotdeclid, elongtokn, elongstring] then
  826.             begin
  827.             i := 1;
  828.             while (i < xtoklen) and (lasttok[i] <> chr(null)) do
  829.                 begin
  830.                 xtok[i] := lasttok[i];
  831.                 i := i + 1
  832.                 end;
  833.             while i < xtoklen do
  834.                 begin
  835.                 xtok[i] := ' ';
  836.                 i := i + 1
  837.                 end;
  838.             xtok[xtoklen] := ' ';
  839.             message('Current symbol: ', xtok)
  840.             end
  841.         end
  842. end;
  843.  
  844. procedure fatal(m : errors);    forward;
  845. procedure error(m : errors);    forward;
  846.  
  847. (*    Map letters to upper-case.                    *)
  848. (*    This function assumes a machine collating sequence where the    *)
  849. (*    letters of either case form a contigous sequence, CHAR.    *)
  850. function uppercase(c : char) : char;
  851.  
  852. begin
  853.     if (c >= 'a') and (c <= 'z') then
  854.         uppercase := chr(ord(c) + ord('A') - ord('a'))
  855.     else
  856.         uppercase := c
  857. end;
  858.  
  859.  
  860. (*    Map letters to lower-case.                    *)
  861. (*    This function assumes a machine collating sequence where the    *)
  862. (*    letters of either case form a contigous sequence, CHAR.    *)
  863. function lowercase(c : char) : char;
  864.  
  865. begin
  866.     if (c >= 'A') and (c <= 'Z') then
  867.         lowercase := chr(ord(c) - ord('A') + ord('a'))
  868.     else
  869.         lowercase := c
  870. end;
  871.  
  872. (*    Retrieve a string from strstor.                *)
  873. procedure gettokn(i : strindx; var t : toknbuf);
  874.  
  875. var    c    : char;
  876.     k    : toknidx;
  877.     j    : strbidx;
  878.     p    : strptr;
  879.  
  880. begin
  881.     k := 1;
  882.     (* compute block and offset in block *)
  883.     p := strstor[i div (maxstrblk + 1)];
  884.     j := i mod (maxstrblk + 1);
  885.     (* retrieve text up to null *)
  886.     repeat
  887.         c := p^[j];
  888.         t[k] := c;
  889.         j := j + 1;
  890.         k := k + 1;
  891.         if k = maxtoknlen then
  892.             begin
  893.             c := chr(null);
  894.             t[maxtoknlen] := chr(null);
  895.             prtmsg(eoverflow)
  896.             end
  897.     until    c = chr(null)
  898. end;
  899.  
  900. (*    Deposit a string into strstor at a given start-position.    *)
  901. procedure puttokn(i : strindx; var t : toknbuf);
  902.  
  903. var    c    : char;
  904.     k    : toknidx;
  905.     j    : strbidx;
  906.     p    : strptr;
  907.  
  908. begin
  909.     k := 1;
  910.     p := strstor[i div (maxstrblk + 1)];
  911.     j := i mod (maxstrblk + 1);
  912.     repeat
  913.         c := t[k];
  914.         p^[j] := c;
  915.         k := k + 1;
  916.         j := j + 1
  917.     until    c = chr(null)
  918. end;
  919.  
  920. (*    Write a token on standard output.                *)
  921. procedure writetok(var w : toknbuf);
  922.  
  923. var    j    : toknidx;
  924.  
  925. begin
  926.     j := 1;
  927.     while w[j] <> chr(null) do
  928.         begin
  929.         write(w[j]);
  930.         j := j + 1
  931.         end
  932. end;
  933.  
  934. (*    Print a float number on standard output.            *)
  935. procedure printtok(i : strindx);
  936.  
  937. var    w    : toknbuf;
  938.  
  939. begin
  940.     gettokn(i, w);
  941.     writetok(w)
  942. end;
  943.  
  944. (*    Print an identifier on standard output.                *)
  945. procedure printid(ip : idptr);
  946.  
  947. begin
  948.     printtok(ip^.istr)
  949. end;
  950.  
  951. (*    Print a character on standard output with proper C-quoting.    *)
  952. procedure printchr(c : char);
  953.  
  954. begin
  955.     if (c = quote) or (c = bslash) then
  956.         write(quote, bslash, c, quote)
  957.     else
  958.         write(quote, c, quote)
  959. end;
  960.  
  961. (*    Print a string on standard output with proper C-quoting.    *)
  962. procedure printstr(i : strindx);
  963.  
  964. var    k    : toknidx;
  965.     c    : char;
  966.     w    : toknbuf;
  967.  
  968. begin
  969.     gettokn(i, w);
  970.     write(cite);
  971.     k := 1;
  972.     while w[k] <> chr(null) do
  973.         begin
  974.         c := w[k];
  975.         k := k + 1;
  976.         if (c = cite) or (c = bslash) then
  977.             write(bslash);
  978.         write(c)
  979.         end;
  980.     write(cite)
  981. end;
  982.  
  983. (*    Return a pointer to the declarationpoint of an identifier.    *)
  984. function idup(ip : treeptr) : treeptr;
  985.  
  986. begin
  987.     idup := ip^.tsym^.lsymdecl^.tup
  988. end;
  989.  
  990. (*    Compute a hashvalue for an identifier or a string.        *)
  991. function hashtokn(var id : toknbuf) : hashtyp;
  992.  
  993. var    h    : integer;
  994.     i    : toknidx;
  995.  
  996. begin
  997.     i := 1;
  998.     h := 0;
  999.     while id[i] <> chr(null) do
  1000.         begin
  1001.         (* if ord() of a character ranges from 0 to 127 then we can loop
  1002.            256 times without causing h to exceed 32767, this is safe as
  1003.            both strings and identifiers are limited in length *)
  1004.         h := h + ord(id[i]);    (* CHAR, CPU *)
  1005.         i := i + 1
  1006.         end;
  1007.     hashtokn := h mod hashmax
  1008. end;
  1009.  
  1010. (*    Global string table update.                    *)
  1011. (*    This function accepts a string and stores it in strstor.    *)
  1012. (*    It returns the id-number for the new string.            *)
  1013. function savestr(var t : toknbuf) : strindx;
  1014.  
  1015. var    k    : toknidx;
  1016.     i    : strindx;
  1017.     j    : strbcnt;
  1018.  
  1019. begin
  1020.     (* find length of new string including null-char *)
  1021.     k := 1;
  1022.     while t[k] <> chr(null) do
  1023.         k := k + 1;
  1024.     if k > strleft then
  1025.         begin
  1026.         (* out of space in strstore *)
  1027.         if strstor[maxblkcnt] <> nil then    (* last slot used *)
  1028.             error(emanytokn);
  1029.         (* allocate a new block *)
  1030.         j := (strfree + maxstrblk) div (maxstrblk + 1);
  1031.         new(strstor[j]);
  1032.         if strstor[j] = nil then
  1033.             error(enew);
  1034.         strfree := j * (maxstrblk + 1);
  1035.         strleft := maxstrblk
  1036.         end;
  1037.     (* copy new str, update location of last used cell,
  1038.        return starting location for new str *)
  1039.     i := strfree;
  1040.     strfree := strfree + k;
  1041.     strleft := strleft - k;
  1042.     puttokn(i, t);
  1043.     savestr := i
  1044. end;
  1045.  
  1046. (*    Global id table lookup.                        *)
  1047. (*    This procedure accepts an identifier and determines if it has    *)
  1048. (*    been seen before. If that is the case a pointer to its idnode    *)
  1049. (*    is returned, otherwise the identifier is saved and a pointer to    *)
  1050. (*    a new node is returned.                        *)
  1051. function saveid(var id : toknbuf) : idptr;
  1052.  
  1053. label    999;
  1054.  
  1055. var    k    : toknidx;
  1056.     ip    : idptr;
  1057.     h    : hashtyp;
  1058.     t    : toknbuf;
  1059.  
  1060. begin
  1061.     h := hashtokn(id);
  1062.     ip := idtab[h];                (* scan hashlist for id    *)
  1063.     while ip <> nil do
  1064.         begin
  1065.         gettokn(ip^.istr, t);        (* look at saved token    *)
  1066.         k := 1;
  1067.         while id[k] = t[k] do
  1068.             if id[k] = chr(null) then
  1069.                 goto 999    (* found it!        *)
  1070.             else
  1071.                 k := k + 1;    (* look at next char    *)
  1072.         ip := ip^.inext
  1073.         end;
  1074.  
  1075.     (* identifier wasn't previously seen, manufacture a new idnode,
  1076.        save index to strstor and hashvalue, insert idnode in idtab *)
  1077.     new(ip);
  1078.     if ip = nil then
  1079.         error(enew);
  1080.     ip^.inref := 0;
  1081.     ip^.istr := savestr(id);
  1082.     ip^.ihash := h;
  1083.     ip^.inext := idtab[h];
  1084.     idtab[h] := ip;
  1085.  
  1086. 999:
  1087.     (* return the idnode *)
  1088.     saveid := ip
  1089. end;
  1090.  
  1091. (*    This function creates a new variable by concatenating one name    *)
  1092. (*    with another injecting a given separator.            *)
  1093. function mkconc(sep : char; p, q : idptr) : idptr;
  1094.  
  1095. var    w, x    : toknbuf;
  1096.     i, j    : toknidx;
  1097.  
  1098. begin
  1099.     (* fetch second part and determine its length *)
  1100.     gettokn(q^.istr, x);
  1101.     j := 1;
  1102.     while x[j] <> chr(null) do
  1103.         j := j + 1;
  1104.     (* fetch first part and locate its end *)
  1105.     w[1] := chr(null);
  1106.     if p <> nil then
  1107.         gettokn(p^.istr, w);
  1108.     i := 1;
  1109.     while w[i] <> chr(null) do
  1110.         i := i + 1;
  1111.     (* check total length *)
  1112.     if i + j + 2 >= maxtoknlen then
  1113.         error(eoverflow);
  1114.  
  1115.     (* add separators *)
  1116.     if sep = '>' then
  1117.         begin
  1118.         (* special case 1: > gives arrow: a->b *)
  1119.         w[i] := '-';
  1120.         i := i + 1
  1121.         end;
  1122.     if sep <> space then
  1123.         begin
  1124.         (* special case 2: space gives nothing: ab *)
  1125.         w[i] := sep;
  1126.         i := i + 1
  1127.         end;
  1128.     (* add second part *)
  1129.     j := 1;
  1130.     repeat
  1131.         w[i] := x[j];
  1132.         i := i + 1;
  1133.         j := j + 1
  1134.     until w[i-1] = chr(null);
  1135.     (* save new identifier *)
  1136.     mkconc := saveid(w)
  1137. end;
  1138.  
  1139. (*    Create a new id with name-prefix from w.            *)
  1140. function mkuniqname(var t : toknbuf) : idptr;
  1141.  
  1142. var    i    : toknidx;
  1143.  
  1144.     procedure dig(n : integer);
  1145.     begin
  1146.         if n > 0 then
  1147.             begin
  1148.             dig(n div 10);
  1149.             if i = maxtoknlen then
  1150.                 error(eoverflow);
  1151.             t[i] := chr(n mod 10 + ord('0'));    (* CHAR *)
  1152.             i := i + 1
  1153.             end
  1154.     end;
  1155.  
  1156. begin
  1157.     i := 1;
  1158.     while t[i] <> chr(null) do
  1159.         i := i + 1;
  1160.     varno := varno + 1;
  1161.     dig(varno);
  1162.     t[i] := chr(null);
  1163.     mkuniqname := saveid(t)
  1164. end;
  1165.  
  1166. (*    Make a new unique variable with given char as prefix.        *)
  1167. function mkvariable(c : char) : idptr;
  1168.  
  1169. var    t    : toknbuf;
  1170.  
  1171. begin
  1172.     t[1] := c;
  1173.     t[2] := chr(null);
  1174.     mkvariable := mkuniqname(t)
  1175. end;
  1176.  
  1177. (*    Make a new unique variable with given char as prefix and    *)
  1178. (*    with a given id as tail. Commonly used for renaming id's.    *)
  1179. function mkrename(c : char; ip : idptr) : idptr;
  1180.  
  1181. begin
  1182.     mkrename := mkconc(uscore, mkvariable(c), ip)
  1183. end;
  1184.  
  1185. (*    Make a name for a variant. Variants are mapped onto C unions,    *)
  1186. (*    which we always give the name "U", thus the name of the variant    *)
  1187. (*    becomes "U.Vnnn" where "nnn" is a unique number.        *)
  1188. function mkvrnt : idptr;
  1189.  
  1190. var    t    : toknbuf;
  1191.  
  1192. begin
  1193.     t[1] := 'U';
  1194.     t[2] := '.';
  1195.     t[3] := 'V';
  1196.     t[4] := chr(null);
  1197.     mkvrnt := mkuniqname(t)
  1198. end;
  1199.  
  1200. procedure checksymbol(ss : symset);
  1201. begin
  1202.     if not (currsym.st in ss) then
  1203.         error(ebadsymbol);
  1204. end;
  1205.  
  1206. (*    Lexical analysis routine.                    *)
  1207. (*    This procedure reads and classifies the next lexical token in    *)
  1208. (*    the input stream. The token is saved in the global variable    *)
  1209. (*    "currsym". The found symbol should be one of the symbols given    *)
  1210. (*    in the parameter "ss" otherwise the error routine is called.    *)
  1211. procedure nextsymbol(ss : symset);
  1212.  
  1213. var    lastchr    : 0 .. maxtoknlen;
  1214.  
  1215.     (*    This function reads the next character from the input    *)
  1216.     (*    and updates "lineno" and "colno" accordingly.        *)
  1217.     function nextchar : char;
  1218.  
  1219.     var    c    : char;
  1220.  
  1221.     begin
  1222.         if eof then
  1223.             c := chr(null)
  1224.         else begin
  1225.             colno := colno + 1;
  1226.             if eoln then
  1227.                 begin
  1228.                 lineno := lineno + 1;
  1229.                 colno := 0
  1230.                 end;
  1231.             read(c);
  1232.             if echo then
  1233.                 if colno = 0 then
  1234.                     writeln
  1235.                 else
  1236.                     write(c);
  1237.             if c = tab1 then
  1238.                 colno := ((colno div tabwidth) + 1) * tabwidth
  1239.              end;
  1240.         if lastchr > 0 then
  1241.             begin
  1242.             lasttok[lastchr] := c;
  1243.             lastchr := lastchr + 1
  1244.             end;
  1245.         nextchar := c
  1246.     end;
  1247.  
  1248.     (*    This function looks at the next input character.    *)
  1249.     function peekchar : char;
  1250.  
  1251.     begin
  1252.         if eof then
  1253.             peekchar := chr(null)
  1254.         else
  1255.             peekchar := input^
  1256.     end;
  1257.  
  1258.     (*    Read and classify the next token.            *)
  1259.     procedure nexttoken(realok : boolean);
  1260.  
  1261.     var    c    : char;
  1262.         n    : integer;
  1263.  
  1264.         ready    : boolean;
  1265.  
  1266.         wl    : toknidx;
  1267.         wb    : toknbuf;
  1268.  
  1269.         (*    Determine if c is valid in an identifier.    *)
  1270.         (*    This function assumes a machine collating    *)
  1271.         (*    sequence where letters and digits form conti-    *)
  1272.         (*    gous sequences, CHAR.                *)
  1273.         function idchar(c : char) : boolean;
  1274.  
  1275.         begin
  1276.             idchar := 
  1277.                 (c >= 'a') and (c <= 'z') or
  1278.                     (c >= '0') and (c <= '9') or
  1279.                     (c >= 'A') and (c <= 'Z') or
  1280.                         (c = uscore)
  1281.         end;
  1282.  
  1283.         (*    Determine if c is valid in a number. CHAR.    *)
  1284.         function numchar(c : char) : boolean;
  1285.  
  1286.         begin
  1287.             numchar := (c >= '0') and (c <= '9')
  1288.         end;
  1289.  
  1290.         (*    Convert a digit to its numeric value. CHAR    *)
  1291.         function numval(c : char) : integer;
  1292.  
  1293.         begin
  1294.             numval := ord(c) - ord('0')
  1295.         end;
  1296.  
  1297.         (*    Determine if the current token is a keyword.    *)
  1298.         function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;
  1299.  
  1300.         var    n    : 1 .. keywordlen;
  1301.             i, j, k    : 0 .. keytablen;
  1302.             wrd    : keyword;
  1303.             kwc    : symtyp;
  1304.  
  1305.         begin
  1306.             (* quick check on token length,
  1307.                pascal keywords range from 2 to 9 chars in length *)
  1308.             if (l > 1) and (l < keywordlen) then
  1309.                 begin
  1310.                 (* could be a keyword, initialize wrd *)
  1311.                 wrd := keytab[keytablen].wrd;
  1312.                 (* copy w to wrd *)
  1313.                 for n := 1 to l do
  1314.                     wrd[n] := w[n];
  1315.  
  1316.                 (* binary search for tokn,
  1317.                    relies on symtyp being sorted *)
  1318.                 i := 0;
  1319.                 j := keytablen;
  1320.                 while j > i do
  1321.                     begin
  1322.                     k := (i + j) div 2;
  1323.                     if keytab[k].wrd >= wrd then
  1324.                         j := k
  1325.                     else
  1326.                         i := k + 1
  1327.                     end;
  1328.                 if keytab[j].wrd = wrd then
  1329.                     kwc := keytab[j].sym
  1330.                 else
  1331.                     kwc := sid
  1332.                 end
  1333.             else
  1334.                 kwc := sid;
  1335.             keywordcheck := kwc
  1336.         end;
  1337.  
  1338.     begin    (* nexttoken *)
  1339.         (* don't save blanks/comments *)
  1340.         lastchr := 0;
  1341.         (* read non-blank character *)
  1342.         repeat
  1343.             c := nextchar;
  1344.             (* skip comments, the two comment delimiters of pascal
  1345.                are treated as different if "diffcomm" is true *)
  1346.             if c = '{' then
  1347.                 begin
  1348.                 repeat
  1349.                     c := nextchar;
  1350.                     if diffcomm then
  1351.                         ready := c = '}'
  1352.                     else
  1353.                         ready := ((c = '*') and
  1354.                                 (peekchar = ')'))
  1355.                             or (c = '}')
  1356.                 until ready or eof;
  1357.                 if eof and not ready then
  1358.                     error(eeofcmnt);
  1359.                 if (c = '*') and not eof then
  1360.                     c := nextchar;
  1361.                 c := space
  1362.                 end
  1363.             else if (c = '(') and (peekchar = '*')  then
  1364.                 begin
  1365.                 c := nextchar;
  1366.                 repeat
  1367.                     c := nextchar;
  1368.                     if diffcomm then
  1369.                         ready := (c = '*') and
  1370.                             (peekchar = ')')
  1371.                     else
  1372.                         ready := ((c = '*') and
  1373.                                 (peekchar = ')'))
  1374.                             or (c = '}')
  1375.                 until ready or eof;
  1376.                 if eof and not ready then
  1377.                     error(eeofcmnt);
  1378.                 if (c = '*') and not eof then
  1379.                     c := nextchar;
  1380.                 c := space
  1381.                 end
  1382.         until    (c <> space) and (c <> tab1);
  1383.  
  1384.         (* save characters from this token and save line- and column-
  1385.            numbers for errormessages *)
  1386.         lasttok[1] := c;
  1387.         lastchr := 2;
  1388.         lastcol := colno;
  1389.         lastline := lineno;
  1390.  
  1391.         (* map all CHAR control characters onto "badchr" *)
  1392.         if c < okchr then
  1393.             c := badchr;
  1394.  
  1395.         (* decode symbol *)
  1396.         with currsym do
  1397.             if eof then
  1398.             begin
  1399.                 lasttok[1] := '*';
  1400.                 lasttok[2] := 'E';
  1401.                 lasttok[3] := 'O';
  1402.                 lasttok[4] := 'F';
  1403.                 lasttok[5] := '*';
  1404.                 lastchr := 6;
  1405.                 st := seof
  1406.             end
  1407.             else
  1408.             case c of
  1409.  
  1410.  
  1411.             (* CHAR, chars not in Pascal *)
  1412.               '|', '`', '~', '}',
  1413.               bslash, uscore, badchr:
  1414.                 error(ebadchar);
  1415.  
  1416.             (* identifiers or keywords *)
  1417.               'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
  1418.               'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
  1419.               'u', 'v', 'w', 'x', 'y', 'z',
  1420.               'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
  1421.               'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
  1422.               'U', 'V', 'W', 'X', 'Y', 'Z':
  1423.                 begin
  1424.                 (* read token into buffer *)
  1425.                 wb[1] := lowercase(c);
  1426.                 wl := 2;
  1427.                 while (wl < maxtoknlen) and idchar(peekchar) do
  1428.                     begin
  1429.                     wb[wl] := lowercase(nextchar);
  1430.                     wl := wl + 1
  1431.                     end;
  1432.                 if wl >= maxtoknlen then
  1433.                     begin
  1434.                     lasttok[lastchr] := chr(null);
  1435.                     error(elongtokn)
  1436.                     end;
  1437.                 (* terminate token and match *)
  1438.                 wb[wl] := chr(null);
  1439.                 (* check if keyword/identifier *)
  1440.                 st := keywordcheck(wb, wl-1);
  1441.                 if st = sid then
  1442.                     vid := saveid(wb)
  1443.                 end;
  1444.  
  1445.             (* integer or real numbers *)
  1446.               '0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
  1447.                 begin
  1448.                 (* assume integer number, save it in buffer *)
  1449.                 wb[1] := c;
  1450.                 wl := 2;
  1451.                 n := numval(c);
  1452.                 while numchar(peekchar) do
  1453.                     begin
  1454.                     c := nextchar;
  1455.                     n := n * 10 + numval(c);
  1456.                     wb[wl] := c;
  1457.                     wl := wl + 1
  1458.                     end;
  1459.                 st := sinteger;
  1460.                 vint := n;
  1461.                 if realok then
  1462.                     begin
  1463.                     (* accept real numbers *)
  1464.                     if peekchar = '.' then
  1465.                         begin
  1466.                         (* this is a real number *)
  1467.                         st := sreal;
  1468.                         wb[wl] := nextchar;
  1469.                         wl := wl + 1;
  1470.                         while numchar(peekchar) do
  1471.                             begin
  1472.                             wb[wl] := nextchar;
  1473.                             wl := wl + 1
  1474.                             end
  1475.                         end;
  1476.                     c := peekchar;
  1477.                     if (c = 'e') or (c = 'E') then
  1478.                         begin
  1479.                         (* this is a real number *)
  1480.                         st := sreal;
  1481.                         c := nextchar;
  1482.                         wb[wl] := xpnent;
  1483.                         wl := wl + 1;
  1484.                         c := peekchar;
  1485.                         if (c = '-') or (c = '+') then
  1486.                             begin
  1487.                             wb[wl] := nextchar;
  1488.                             wl := wl + 1
  1489.                             end;
  1490.                         while numchar(peekchar) do
  1491.                             begin
  1492.                             wb[wl] := nextchar;
  1493.                             wl := wl + 1
  1494.                             end
  1495.                         end;
  1496.                     if st = sreal then
  1497.                         begin
  1498.                         wb[wl] := chr(null);
  1499.                         vflt := savestr(wb)
  1500.                         end
  1501.                     end
  1502.                 end;
  1503.  
  1504.               '(':
  1505.                 if peekchar = '.' then
  1506.                     begin
  1507.                     (* some compilers on non-ascii systems
  1508.                        use (. for [ and .) for ] *)
  1509.                     c := nextchar;
  1510.                     st := slbrack
  1511.                     end
  1512.                 else
  1513.                     st := slpar;
  1514.               ')':
  1515.                 st := srpar;
  1516.               '[':
  1517.                 st := slbrack;
  1518.               ']':
  1519.                 st := srbrack;
  1520.               '.':
  1521.                 if peekchar = '.' then
  1522.                     begin
  1523.                     c := nextchar;
  1524.                     st := sdotdot
  1525.                     end
  1526.                 else if peekchar = ')' then
  1527.                     begin
  1528.                     c := nextchar;
  1529.                     st := srbrack
  1530.                     end
  1531.                 else
  1532.                     st := sdot;
  1533.               ';':
  1534.                 st := ssemic;
  1535.               ':':
  1536.                 if peekchar = '=' then
  1537.                     begin
  1538.                     c := nextchar;
  1539.                     st := sassign
  1540.                     end
  1541.                 else
  1542.                     st := scolon;
  1543.               ',':
  1544.                 st := scomma;
  1545.               '@',
  1546.               '^':
  1547.                 st := sarrow;
  1548.               '=':
  1549.                 st := seq;
  1550.               '<':
  1551.                 if peekchar = '=' then
  1552.                     begin
  1553.                     c := nextchar;
  1554.                     st := sle
  1555.                     end
  1556.                 else if peekchar = '>' then
  1557.                     begin
  1558.                     c := nextchar;
  1559.                     st := sne
  1560.                     end
  1561.                 else
  1562.                     st := slt;
  1563.               '>':
  1564.                 if peekchar = '=' then
  1565.                     begin
  1566.                     c := nextchar;
  1567.                     st := sge
  1568.                     end
  1569.                 else
  1570.                     st := sgt;
  1571.               '+':
  1572.                 st := splus;
  1573.               '-':
  1574.                 st := sminus;
  1575.               '*':
  1576.                 st := smul;
  1577.               '/':
  1578.                 st := squot;
  1579.               quote:
  1580.                 begin
  1581.                 (* assume the symbol is a literal string *)
  1582.                 wl := 0;
  1583.                 ready := false;
  1584.                 repeat
  1585.                     if eoln then
  1586.                         begin
  1587.                         lasttok[lastchr] := chr(null);
  1588.                         error(ebadstring)
  1589.                         end;
  1590.                     c := nextchar;
  1591.                     if c = quote then
  1592.                         if peekchar = quote then
  1593.                             c := nextchar
  1594.                         else
  1595.                             ready := true;
  1596.                     if c = chr(null) then
  1597.                         begin
  1598.                         if eof then
  1599.                             error(eeofstr);
  1600.                         lasttok[lastchr] := chr(null);
  1601.                         error(enulchr)
  1602.                         end;
  1603.                     if not ready then
  1604.                         begin
  1605.                         wl := wl + 1;
  1606.                         if wl >= maxtoknlen then
  1607.                             begin
  1608.                             lasttok[lastchr] :=
  1609.                                 chr(null);
  1610.                             error(elongstring)
  1611.                             end;
  1612.                         wb[wl] := c
  1613.                         end
  1614.                 until    ready;
  1615.                 if wl = 1 then
  1616.                     begin
  1617.                     (* only 1 character => not a string *)
  1618.                     st := schar;
  1619.                     vchr := wb[1]
  1620.                     end
  1621.                 else begin
  1622.                     (* > 1 character => its a string *)
  1623.                     wl := wl + 1;
  1624.                     if wl >= maxtoknlen then
  1625.                         begin
  1626.                         lasttok[lastchr] := chr(null);
  1627.                         error(elongstring)
  1628.                         end;
  1629.                     wb[wl] := chr(null);
  1630.                     st := sstring;
  1631.                     vstr := savestr(wb)
  1632.                      end
  1633.                 end
  1634.  
  1635.             end;(* case *)
  1636.         if lastchr = 0 then
  1637.             lastchr := 1;
  1638.         lasttok[lastchr] := chr(null)
  1639.     end;    (* nexttoken *)
  1640.  
  1641. begin    (* nextsymbol *)
  1642.     nexttoken(sreal in ss);
  1643.     checksymbol(ss)
  1644. end;    (* nextsymbol *)
  1645.  
  1646. (*    Return a pointer to the node describing the type of tp. This    *)
  1647. (*    function also stores the result in the node for future ref.    *)
  1648. function typeof(tp : treeptr) : treeptr;
  1649.  
  1650. var    tf, tq    : treeptr;
  1651.  
  1652. begin
  1653.     tq := tp;
  1654.     tf := tq^.ttype;
  1655.     (* keep working until a type is found *)
  1656.     while tf = nil do
  1657.         begin
  1658.         case tq^.tt of
  1659.           nchar:
  1660.             tf := typnods[tchar];
  1661.  
  1662.           ninteger:
  1663.             tf := typnods[tinteger];
  1664.  
  1665.           nreal:
  1666.             tf := typnods[treal];
  1667.  
  1668.           nstring:
  1669.             tf := typnods[tstring];
  1670.  
  1671.           nnil:
  1672.             tf := typnods[tnil];
  1673.  
  1674.           nid:
  1675.             begin
  1676.             tq := idup(tq);
  1677.             if tq = nil then
  1678.                 fatal(etree)
  1679.             end;
  1680.  
  1681.           ntype,
  1682.           nvar,
  1683.           nconst,
  1684.           nfield,
  1685.           nvalpar,
  1686.           nvarpar:
  1687.             tq := tq^.tbind;
  1688.  
  1689.           npredef,
  1690.           nptr,
  1691.           nscalar,
  1692.           nrecord,
  1693.           nconfarr,
  1694.           narray,
  1695.           nfileof,
  1696.           nsetof:
  1697.             tf := tq;    (* these nodetypes represent types *)
  1698.  
  1699.           nsubrange:
  1700.             if tq^.tup^.tt = nconfarr then
  1701.                 tf := tq^.tup^.tindtyp
  1702.             else
  1703.                 tf := tq;
  1704.  
  1705.           ncall:
  1706.             begin
  1707.             tf := typeof(tq^.tcall);
  1708.             if tf = typnods[tpoly] then
  1709.                 tf := typeof(tq^.taparm)
  1710.             end;
  1711.  
  1712.           nfunc:
  1713.             tq := tq^.tfuntyp;
  1714.  
  1715.           nparfunc:
  1716.             tq := tq^.tpartyp;
  1717.  
  1718.           nproc,
  1719.           nparproc:
  1720.             tf := typnods[tnone];
  1721.  
  1722.           nvariant,
  1723.           nlabel,
  1724.           npgm,
  1725.           nempty,
  1726.           nbegin,
  1727.           nlabstmt,
  1728.           nassign,
  1729.           npush,
  1730.           npop,
  1731.           nif,
  1732.           nwhile,
  1733.           nrepeat,
  1734.           nfor,
  1735.           ncase,
  1736.           nchoise,
  1737.           ngoto,
  1738.           nwith,
  1739.           nwithvar:
  1740.             fatal(etree);
  1741.  
  1742.           nformat,
  1743.           nrange:
  1744.             tq := tq^.texpl;
  1745.  
  1746.           nplus,
  1747.           nminus,
  1748.           nmul:
  1749.             begin
  1750.             tf := typeof(tq^.texpl);
  1751.             if tf = typnods[tinteger] then
  1752.                 tf := typeof(tq^.texpr)
  1753.             else if tf^.tt = nsetof then
  1754.                 tf := typnods[tset]
  1755.             end;
  1756.  
  1757.           numinus,
  1758.           nuplus:
  1759.             tq := tq^.texps;
  1760.  
  1761.           nmod,
  1762.           ndiv:
  1763.             tf := typnods[tinteger];
  1764.  
  1765.           nquot:
  1766.             tf := typnods[treal];
  1767.  
  1768.           neq,
  1769.           nne,
  1770.           nlt,
  1771.           nle,
  1772.           ngt,
  1773.           nge,
  1774.           nin,
  1775.           nor,
  1776.           nand,
  1777.           nnot:
  1778.             tf := typnods[tboolean];
  1779.  
  1780.           nset:
  1781.             tf := typnods[tset];
  1782.  
  1783.           nselect:
  1784.             tq := tq^.tfield;
  1785.  
  1786.           nderef:
  1787.             begin
  1788.             tq := typeof(tq^.texps);
  1789.             case tq^.tt of
  1790.               nptr:
  1791.                 tq := tq^.tptrid;
  1792.               nfileof:
  1793.                 tq := tq^.tof;
  1794.               npredef:
  1795.                 tf := typnods[tchar]    (* textfile *)
  1796.             end (* case *)
  1797.             end;
  1798.  
  1799.           nindex:
  1800.             begin
  1801.             tq := typeof(tq^.tvariable);
  1802.             if tq^.tt = nconfarr then
  1803.                 tq := tq^.tcelem
  1804.             else if tq = typnods[tstring] then
  1805.                 tf := typnods[tchar]
  1806.             else
  1807.                 tq := tq^.taelem
  1808.             end;
  1809.  
  1810.         end (* case *)
  1811.     end;
  1812.     if tp^.ttype = nil then
  1813.         tp^.ttype := tf;    (* remember type for future reference *)
  1814.     typeof := tf
  1815. end;    (* typeof *)
  1816.  
  1817. (*    Connect all nodes to their fathers.                *)
  1818. procedure linkup(up, tp : treeptr);
  1819.  
  1820. begin
  1821.     while tp <> nil do
  1822.         begin
  1823.         if tp^.tup = nil then
  1824.             begin
  1825.             tp^.tup := up;
  1826.             case tp^.tt of
  1827.               npgm,
  1828.               nfunc,
  1829.               nproc:
  1830.                 begin
  1831.                 linkup(tp, tp^.tsubid);
  1832.                 linkup(tp, tp^.tsubpar);
  1833.                 linkup(tp, tp^.tfuntyp);
  1834.                 linkup(tp, tp^.tsublab);
  1835.                 linkup(tp, tp^.tsubconst);
  1836.                 linkup(tp, tp^.tsubtype);
  1837.                 linkup(tp, tp^.tsubvar);
  1838.                 linkup(tp, tp^.tsubsub);
  1839.                 linkup(tp, tp^.tsubstmt)
  1840.                 end;
  1841.  
  1842.  
  1843.               nvalpar,
  1844.               nvarpar,
  1845.               nconst,
  1846.               ntype,
  1847.               nfield,
  1848.               nvar:
  1849.                 begin
  1850.                 linkup(tp, tp^.tidl);
  1851.                 linkup(tp, tp^.tbind)
  1852.                 end;
  1853.  
  1854.               nparproc,
  1855.               nparfunc:
  1856.                 begin
  1857.                 linkup(tp, tp^.tparid);
  1858.                 linkup(tp, tp^.tparparm);
  1859.                 linkup(tp, tp^.tpartyp)
  1860.                 end;
  1861.  
  1862.               nptr:
  1863.                 linkup(tp, tp^.tptrid);
  1864.               nscalar:
  1865.                 linkup(tp, tp^.tscalid);
  1866.  
  1867.               nsubrange:
  1868.                 begin
  1869.                 linkup(tp, tp^.tlo);
  1870.                 linkup(tp, tp^.thi)
  1871.                 end;
  1872.               nvariant:
  1873.                 begin
  1874.                 linkup(tp, tp^.tselct);
  1875.                 linkup(tp, tp^.tvrnt)
  1876.                 end;
  1877.               nrecord:
  1878.                 begin
  1879.                 linkup(tp, tp^.tflist);
  1880.                 linkup(tp, tp^.tvlist)
  1881.                 end;
  1882.               nconfarr:
  1883.                 begin
  1884.                 linkup(tp, tp^.tcindx);
  1885.                 linkup(tp, tp^.tcelem);
  1886.                 linkup(tp, tp^.tindtyp)
  1887.                 end;
  1888.               narray:
  1889.                 begin
  1890.                 linkup(tp, tp^.taindx);
  1891.                 linkup(tp, tp^.taelem)
  1892.                 end;
  1893.               nfileof,
  1894.               nsetof:
  1895.                 linkup(tp, tp^.tof);
  1896.               nbegin:
  1897.                 linkup(tp, tp^.tbegin);
  1898.               nlabstmt:
  1899.                 begin
  1900.                 linkup(tp, tp^.tlabno);
  1901.                 linkup(tp, tp^.tstmt)
  1902.                 end;
  1903.               nassign:
  1904.                 begin
  1905.                 linkup(tp, tp^.tlhs);
  1906.                 linkup(tp, tp^.trhs)
  1907.                 end;
  1908.               npush,
  1909.               npop:
  1910.                 begin
  1911.                 linkup(tp, tp^.tglob);
  1912.                 linkup(tp, tp^.tloc);
  1913.                 linkup(tp, tp^.ttmp)
  1914.                 end;
  1915.               ncall:
  1916.                 begin
  1917.                 linkup(tp, tp^.tcall);
  1918.                 linkup(tp, tp^.taparm )
  1919.                 end;
  1920.               nif:
  1921.                 begin
  1922.                 linkup(tp, tp^.tifxp);
  1923.                 linkup(tp, tp^.tthen);
  1924.                 linkup(tp, tp^.telse)
  1925.                 end;
  1926.               nwhile:
  1927.                 begin
  1928.                 linkup(tp, tp^.twhixp);
  1929.                 linkup(tp, tp^.twhistmt)
  1930.                 end;
  1931.               nrepeat:
  1932.                 begin
  1933.                 linkup(tp, tp^.treptstmt);
  1934.                 linkup(tp, tp^.treptxp)
  1935.                 end;
  1936.               nfor:
  1937.                 begin
  1938.                 linkup(tp, tp^.tforid);
  1939.                 linkup(tp, tp^.tfrom);
  1940.                 linkup(tp, tp^.tto);
  1941.                 linkup(tp, tp^.tforstmt)
  1942.                 end;
  1943.               ncase:
  1944.                 begin
  1945.                 linkup(tp, tp^.tcasxp);
  1946.                 linkup(tp, tp^.tcaslst);
  1947.                 linkup(tp, tp^.tcasother)
  1948.                 end;
  1949.               nchoise:
  1950.                 begin
  1951.                 linkup(tp, tp^.tchocon);
  1952.                 linkup(tp, tp^.tchostmt)
  1953.                 end;
  1954.               nwith:
  1955.                 begin
  1956.                 linkup(tp, tp^.twithvar);
  1957.                 linkup(tp, tp^.twithstmt)
  1958.                 end;
  1959.               nwithvar:
  1960.                 linkup(tp, tp^.texpw);
  1961.               nindex:
  1962.                 begin
  1963.                 linkup(tp, tp^.tvariable);
  1964.                 linkup(tp, tp^.toffset)
  1965.                 end;
  1966.               nselect:
  1967.                 begin
  1968.                 linkup(tp, tp^.trecord);
  1969.                 linkup(tp, tp^.tfield)
  1970.                 end;
  1971.  
  1972.               ngoto:
  1973.                 linkup(tp, tp^.tlabel);
  1974.  
  1975.               nrange, nformat,
  1976.               nin, neq,
  1977.               nne, nlt, nle,
  1978.               ngt, nge, nor,
  1979.               nplus, nminus,
  1980.               nand, nmul,
  1981.               ndiv, nmod,
  1982.               nquot:
  1983.                 begin
  1984.                 linkup(tp, tp^.texpl);
  1985.                 linkup(tp, tp^.texpr)
  1986.                 end;
  1987.  
  1988.               nderef,
  1989.               nnot, nset,
  1990.               numinus,
  1991.               nuplus:
  1992.                 linkup(tp, tp^.texps);
  1993.  
  1994.               nid,
  1995.               nnil, ninteger,
  1996.               nreal, nchar,
  1997.               nstring, npredef,
  1998.               nlabel, nempty:
  1999.                 (* no op *)
  2000.             end (* case *)
  2001.         end;
  2002.         tp := tp^.tnext
  2003.         end
  2004. end;    (* linkup *)
  2005.  
  2006. (*    Allocate a new symbol node.                    *)
  2007. function mksym(vt : ltypes) : symptr;
  2008.  
  2009. var    mp    : symptr;
  2010.  
  2011. begin
  2012.     new(mp);
  2013.     if mp = nil then
  2014.         error(enew);
  2015.     mp^.lt := vt;
  2016.     mp^.lnext := nil;
  2017.     mp^.lsymdecl := nil;
  2018.     mp^.ldecl := nil;
  2019.     mksym := mp
  2020. end;
  2021.  
  2022. (*    Enter a symbol at current declarationlevel.            *)
  2023. procedure declsym(sp : symptr);
  2024.  
  2025. var    h    : hashtyp;
  2026.  
  2027. begin
  2028.     if sp^.lt in [lpredef, lidentifier, lfield, lforward, lpointer] then
  2029.         h := sp^.lid^.ihash
  2030.     else
  2031.         h := hashmax;
  2032.     sp^.lnext := symtab^.ddecl[h];
  2033.     symtab^.ddecl[h] := sp;
  2034.     sp^.ldecl := symtab
  2035. end;
  2036.  
  2037. (*    Create a node of selected type.                    *)
  2038. function mknode(nt : treetyp) : treeptr;
  2039.  
  2040. var    tp    : treeptr;
  2041.  
  2042. begin
  2043.     tp := nil;
  2044.     case nt of
  2045.       npredef:    new(tp, npredef);
  2046.       npgm:        new(tp, npgm);
  2047.       nfunc:    new(tp, nfunc);
  2048.       nproc:    new(tp, nproc);
  2049.       nlabel:    new(tp, nlabel);
  2050.       nconst:    new(tp, nconst);
  2051.       ntype:    new(tp, ntype);
  2052.       nvar:        new(tp, nvar);
  2053.       nvalpar:    new(tp, nvalpar);
  2054.       nvarpar:    new(tp, nvarpar);
  2055.       nparproc:    new(tp, nparproc);
  2056.       nparfunc:    new(tp, nparfunc);
  2057.       nsubrange:    new(tp, nsubrange);
  2058.       nvariant:    new(tp, nvariant);
  2059.       nfield:    new(tp, nfield);
  2060.       nrecord:    new(tp, nrecord);
  2061.       nconfarr:    new(tp, nconfarr);
  2062.       narray:    new(tp, narray);
  2063.       nfileof:    new(tp, nfileof);
  2064.       nsetof:    new(tp, nsetof);
  2065.       nbegin:    new(tp, nbegin);
  2066.       nptr:        new(tp, nptr);
  2067.       nscalar:    new(tp, nscalar);
  2068.       nif:        new(tp, nif);
  2069.       nwhile:    new(tp, nwhile);
  2070.       nrepeat:    new(tp, nrepeat);
  2071.       nfor:        new(tp, nfor);
  2072.       ncase:    new(tp, ncase);
  2073.       nchoise:    new(tp, nchoise);
  2074.       ngoto:    new(tp, ngoto);
  2075.       nwith:    new(tp, nwith);
  2076.       nwithvar:    new(tp, nwithvar);
  2077.       nempty:    new(tp, nempty);
  2078.       nlabstmt:    new(tp, nlabstmt);
  2079.       nassign:    new(tp, nassign);
  2080.       nformat:    new(tp, nformat);
  2081.       nin:        new(tp, nin);
  2082.       neq:        new(tp, neq);
  2083.       nne:        new(tp, nne);
  2084.       nlt:        new(tp, nlt);
  2085.       nle:        new(tp, nle);
  2086.       ngt:        new(tp, ngt);
  2087.       nge:        new(tp, nge);
  2088.       nor:        new(tp, nor);
  2089.       nplus:    new(tp, nplus);
  2090.       nminus:    new(tp, nminus);
  2091.       nand:        new(tp, nand);
  2092.       nmul:        new(tp, nmul);
  2093.       ndiv:        new(tp, ndiv);
  2094.       nmod:        new(tp, nmod);
  2095.       nquot:    new(tp, nquot);
  2096.       nnot:        new(tp, nnot);
  2097.       numinus:    new(tp, numinus);
  2098.       nuplus:    new(tp, nuplus);
  2099.       nset:        new(tp, nset);
  2100.       nrange:    new(tp, nrange);
  2101.       nindex:    new(tp, nindex);
  2102.       nselect:    new(tp, nselect);
  2103.       nderef:    new(tp, nderef);
  2104.       ncall:    new(tp, ncall);
  2105.       nid:        new(tp, nid);
  2106.       nchar:    new(tp, nchar);
  2107.       ninteger:    new(tp, ninteger);
  2108.       nreal:    new(tp, nreal);
  2109.       nstring:    new(tp, nstring);
  2110.       nnil:        new(tp, nnil);
  2111.       npush:    new(tp, npush);
  2112.       npop:        new(tp, npop);
  2113.       nbreak:    new(tp, nbreak)
  2114.     end;(* case *)
  2115.     if tp = nil then
  2116.         error(enew);
  2117.     tp^.tt := nt;
  2118.     tp^.tnext := nil;
  2119.     tp^.tup := nil;
  2120.     tp^.ttype := nil;
  2121.     mknode := tp
  2122. end;
  2123.  
  2124. (*    Create a node with a literal value.                *)
  2125. function mklit : treeptr;
  2126.  
  2127. var    sp    : symptr;
  2128.     tp    : treeptr;
  2129.  
  2130. begin
  2131.     case currsym.st of
  2132.       sinteger:
  2133.         begin
  2134.         sp := mksym(linteger);
  2135.         sp^.linum := currsym.vint;
  2136.         tp := mknode(ninteger);
  2137.         end;
  2138.       sreal:
  2139.         begin
  2140.         sp := mksym(lreal);
  2141.         sp^.lfloat := currsym.vflt;
  2142.         tp := mknode(nreal);
  2143.         end;
  2144.       schar:
  2145.         begin
  2146.         sp := mksym(lcharacter);
  2147.         sp^.lchar := currsym.vchr;
  2148.         tp := mknode(nchar);
  2149.         end;
  2150.       sstring:
  2151.         begin
  2152.         sp := mksym(lstring);
  2153.         sp^.lstr := currsym.vstr;
  2154.         tp := mknode(nstring);
  2155.         end
  2156.     end;(* case *)
  2157.     tp^.tsym := sp;
  2158.     sp^.lsymdecl := tp;
  2159.     mklit := tp
  2160. end;
  2161.  
  2162. (*    Look up an identifier among declared symbols.            *)
  2163. function lookupid(ip : idptr; fieldok : boolean) : symptr;
  2164.  
  2165. label    999;
  2166.  
  2167. var    sp    : symptr;
  2168.     dp    : declptr;
  2169.     vs    : set of ltypes;
  2170.  
  2171. begin
  2172.     lookupid := nil;
  2173.     if fieldok then
  2174.         vs := [lidentifier, lforward, lpointer, lfield]
  2175.     else
  2176.         vs := [lidentifier, lforward, lpointer];
  2177.     sp := nil;
  2178.  
  2179.     (* pick up symboltable from innermost scope *)
  2180.     dp := symtab;
  2181.     while dp <> nil do
  2182.         begin
  2183.         (* scan linked symbols with same hasvalue *) 
  2184.         sp := dp^.ddecl[ip^.ihash];
  2185.         while sp <> nil do
  2186.             begin
  2187.             (* break out when proper id found *)
  2188.             if (sp^.lt in vs) and (sp^.lid = ip) then
  2189.                 goto 999;
  2190.             sp := sp^.lnext
  2191.             end;
  2192.         (* proceed to enclosing scope *)
  2193.         dp := dp^.dprev
  2194.         end;
  2195. 999:
  2196.     lookupid := sp
  2197. end;
  2198.  
  2199. (*    Look up a label.                        *)
  2200. function lookuplabel(i : integer) : symptr;
  2201.  
  2202. label    999;
  2203.  
  2204. var    sp    : symptr;
  2205.     dp    : declptr;
  2206.  
  2207. begin
  2208.     sp := nil;
  2209.     dp := symtab;
  2210.     while dp <> nil do
  2211.         begin
  2212.         sp := dp^.ddecl[hashmax];
  2213.         while sp <> nil do
  2214.             begin
  2215.             if (sp^.lt in [lforwlab, llabel]) and (sp^.lno = i) then
  2216.                 goto 999;
  2217.             sp := sp^.lnext
  2218.             end;
  2219.         dp := dp^.dprev
  2220.         end;
  2221. 999:
  2222.     lookuplabel := sp
  2223. end;
  2224.  
  2225. (*    Create a new declaration level (a new scope) link declnode to    *)
  2226. (*    previous node.    dp is non-nil when a procedure/function body    *)
  2227. (*    is encountered for which we have seen a forward declaration.     *)
  2228. procedure enterscope(dp : declptr);
  2229.  
  2230. var    h    : hashtyp;
  2231.  
  2232. begin
  2233.     if dp = nil then
  2234.         begin
  2235.         new(dp);
  2236.         for h := 0 to hashmax do
  2237.             dp^.ddecl[h] := nil
  2238.         end;
  2239.     dp^.dprev := symtab;
  2240.     symtab := dp
  2241. end;
  2242.  
  2243. (*    Return current scope (as a pointer to symbol-table).    *)
  2244. function currscope : declptr;
  2245.  
  2246. begin
  2247.     currscope := symtab
  2248. end;
  2249.  
  2250. (*    Drop innermost declaration scope.                *)
  2251. procedure leavescope;
  2252.  
  2253. begin
  2254.     symtab := symtab^.dprev
  2255. end;
  2256.  
  2257. (*    Create a new identifier symbol.                    *)
  2258. function mkid(ip : idptr) : symptr;
  2259.  
  2260. var    sp    : symptr;
  2261.  
  2262. begin
  2263.     sp := mksym(lidentifier);
  2264.     sp^.lid := ip;
  2265.     sp^.lused := false;
  2266.     declsym(sp);
  2267.     ip^.inref := ip^.inref + 1;
  2268.     mkid := sp
  2269. end;
  2270.  
  2271. (*    Check that the current identifier is new then save it in the    *)
  2272. (*    current scope. Create and return a new node representing this    *)
  2273. (*    instance of the identifier.                    *)
  2274. function newid(ip : idptr) : treeptr;
  2275.  
  2276. var    sp    : symptr;
  2277.     tp    : treeptr;
  2278.  
  2279. begin
  2280.     sp := lookupid(ip, false);
  2281.     if sp <> nil then
  2282.         if sp^.ldecl <> symtab then
  2283.             sp := nil;
  2284.     if sp = nil then
  2285.         begin
  2286.         (* new identifier *)
  2287.         tp := mknode(nid);
  2288.         sp := mkid(ip);
  2289.         sp^.lsymdecl := tp;
  2290.         tp^.tsym := sp
  2291.         end
  2292.     else if sp^.lt = lpointer then
  2293.         begin
  2294.         (* previously declared as a pointer type *)
  2295.         tp := mknode(nid);
  2296.         tp^.tsym := sp;
  2297.         sp^.lt := lidentifier;
  2298.         sp^.lsymdecl := tp
  2299.         end
  2300.     else if sp^.lt = lforward then
  2301.         begin
  2302.         (* previously forward declared *)
  2303.         sp^.lt := lidentifier;
  2304.         tp := sp^.lsymdecl
  2305.         end
  2306.     else
  2307.         error(emultdeclid);
  2308.     newid := tp
  2309. end;
  2310.  
  2311. (*    Check that the current identifier is already declared,    *)
  2312. (*    we fail unless l in [lforward, lpointer].        *)
  2313. (*    Create and return a new node referencing it.        *)
  2314. function oldid(ip : idptr; l : ltypes) : treeptr;
  2315.  
  2316. var    sp    : symptr;
  2317.     tp    : treeptr;
  2318.  
  2319. begin
  2320.     sp := lookupid(ip, true);
  2321.     if sp = nil then
  2322.         begin
  2323.         if l in [lforward, lpointer] then
  2324.             begin
  2325.             tp := newid(ip);
  2326.             tp^.tsym^.lt := l
  2327.             end
  2328.         else
  2329.             error(enotdeclid)
  2330.         end
  2331.     else begin
  2332.         sp^.lused := true;
  2333.         tp := mknode(nid);
  2334.         tp^.tsym := sp;
  2335.         if (sp^.lt = lpointer) and (l = lidentifier) then
  2336.             begin
  2337.             sp^.lt := lidentifier;
  2338.             sp^.lsymdecl := tp
  2339.             end
  2340.          end;
  2341.     oldid := tp
  2342. end;
  2343.  
  2344. (*    Look up a field in a record declaration.            *)
  2345. (*    Return nil if field isn't declared in "tp" or its variants.    *)
  2346. function oldfield(tp : treeptr; ip : idptr) : treeptr;
  2347.  
  2348. label    999;
  2349.  
  2350. var    tq, ti,
  2351.     fp    : treeptr;
  2352.  
  2353. begin
  2354.     fp := nil;
  2355.     tq := tp^.tflist;
  2356.     while tq <> nil do
  2357.         begin
  2358.         ti := tq^.tidl;
  2359.         while ti <> nil do
  2360.             begin
  2361.             if ti^.tsym^.lid = ip then
  2362.                 begin
  2363.                 fp := mknode(nid);
  2364.                 fp^.tsym := ti^.tsym;
  2365.                 goto 999
  2366.                 end;
  2367.             ti := ti^.tnext
  2368.             end;
  2369.         tq := tq^.tnext
  2370.         end;
  2371.     tq := tp^.tvlist;
  2372.     while tq <> nil do
  2373.         begin
  2374.         fp := oldfield(tq^.tvrnt, ip);
  2375.         if fp <> nil then
  2376.             tq := nil
  2377.         else
  2378.             tq := tq^.tnext
  2379.         end;
  2380. 999:
  2381.     oldfield := fp
  2382. end;
  2383.  
  2384. (*    This is the main parsing routine. It parses a correct pascal-    *)
  2385. (*    program and builds a parsetree which is left in the global    *)
  2386. (*    variable top.                            *)
  2387. (*    Parsing is done through recursive descent using a set of    *)
  2388. (*    mutually recursive functions.                    *)
  2389. procedure parse;
  2390.  
  2391.     function plabel : treeptr;                forward;
  2392.     function pidlist(l : ltypes) : treeptr;            forward;
  2393.     function pconst : treeptr;                forward;
  2394.     function pconstant(realok : boolean) : treeptr;        forward;
  2395.     function precord(cs : symtyp; dp : declptr) : treeptr;    forward;
  2396.     function ptypedef : treeptr;                forward;
  2397.     function ptype : treeptr;                forward;
  2398.     function pvar : treeptr;                forward;
  2399.     function psubs : treeptr;                forward;
  2400.     function psubpar : treeptr;                forward;
  2401.     function plabstmt : treeptr;                forward;
  2402.     function pstmt : treeptr;                forward;
  2403.     function psimple : treeptr;                forward;
  2404.     function pvariable(varptr : treeptr) : treeptr;        forward;
  2405.     function pexpr(tnp : treeptr) : treeptr;        forward;
  2406.     function pcase : treeptr;                forward;
  2407.     function pif : treeptr;                    forward;
  2408.     function pwhile : treeptr;                forward;
  2409.     function prepeat : treeptr;                forward;
  2410.     function pfor : treeptr;                forward;
  2411.     function pwith : treeptr;                forward;
  2412.     function pgoto : treeptr;                forward;
  2413.     function pbegin(retain : boolean) : treeptr;        forward;
  2414.  
  2415.     (*    Open scope of a record variable.            *)
  2416.     procedure scopeup(tp : treeptr);
  2417.  
  2418.         (*    Scan a record-declaration and add all fields to    *)
  2419.         (*    current scope.                    *)
  2420.         procedure addfields(rp : treeptr);
  2421.  
  2422.         var    fp, ip, vp    : treeptr;
  2423.             sp        : symptr;
  2424.  
  2425.         begin
  2426.             fp := rp^.tflist;
  2427.             while fp <> nil do
  2428.                 begin
  2429.                 ip := fp^.tidl;
  2430.                 while ip <> nil do
  2431.                     begin
  2432.                     sp := mksym(lfield);
  2433.                     sp^.lid := ip^.tsym^.lid;
  2434.                     sp^.lused := false;
  2435.                     sp^.lsymdecl := ip;
  2436.                     declsym(sp);
  2437.                     ip := ip^.tnext
  2438.                     end;
  2439.                 fp := fp^.tnext
  2440.                 end;
  2441.             vp := rp^.tvlist;
  2442.             while vp <> nil do
  2443.                 begin
  2444.                 addfields(vp^.tvrnt);
  2445.                 vp := vp^.tnext
  2446.                 end
  2447.         end;
  2448.     begin
  2449.         addfields(typeof(tp))
  2450.     end;
  2451.  
  2452.     (*    Check that the current label is new then save it in the    *)
  2453.     (*    current scope. Create and return a new node referencing    *)
  2454.     (*    the label.                        *)
  2455.     function newlbl : treeptr;
  2456.  
  2457.     var    sp    : symptr;
  2458.         tp    : treeptr;
  2459.  
  2460.     begin
  2461.         tp := mknode(nlabel);
  2462.         sp := lookuplabel(currsym.vint);
  2463.         if sp <> nil then
  2464.             if sp^.ldecl <> symtab then
  2465.                 sp := nil;
  2466.         if sp = nil then
  2467.             begin
  2468.             sp := mksym(lforwlab);
  2469.             sp^.lno := currsym.vint;
  2470.             sp^.lgo := false;
  2471.             sp^.lsymdecl := tp;
  2472.             declsym(sp)
  2473.             end
  2474.         else
  2475.             error(emultdecllab);
  2476.         tp^.tsym := sp;
  2477.         newlbl := tp
  2478.     end;
  2479.  
  2480.     (*    Check that the current label is already declared.    *)
  2481.     (*    Create and return a new node referencing it.        *)
  2482.     function oldlbl(defpt : boolean) : treeptr;
  2483.  
  2484.     var    sp    : symptr;
  2485.         tp    : treeptr;
  2486.  
  2487.     begin
  2488.         sp := lookuplabel(currsym.vint);
  2489.         if sp = nil then
  2490.             begin
  2491.             prtmsg(enotdecllab);
  2492.             tp := newlbl;
  2493.             sp := tp^.tsym
  2494.             end
  2495.         else begin
  2496.             tp := mknode(nlabel);
  2497.             tp^.tsym := sp
  2498.              end;
  2499.         if defpt then
  2500.             begin
  2501.  
  2502.