program { logicsim.p } logicsim( input, output, f1, f2, f3, f4 );

{ The Iowa Logic Simulator, version 10
    a digital logic simulation system taking
    input in the Iowa Logic Specification Language. }

{ -----------------------------------------------------------------
  Copyright 1988, Douglas Jones.

    Permission is hereby granted to make copies of this program for
    research and personal use so long as this copyright notice is
    included in the copy.

    Neither this software nor any software derived from it may be
    sold or incorporated into a product which is sold without
    explicit permission from the copyright holder.
  ----------------------------------------------------------------- }

{ -----------------------------------------------------------------
  Warrantee:
    This software is distributed without any warrantee.  I hope it
    will be useful, but it may not work at all.  You get what you
    pay for.
  ----------------------------------------------------------------- }

{ Version 1:  started May 26, 1983; released for student use, fall 83;
    Douglas W. Jones -- buildmodel
    Wun-Chin Kao     -- simulate }
{ Version 2:  started Feb 11, 1984; released for student use, fall 84;
    George S. Singer -- add subcircuit mechanism to simulate }
{ Version 3:  started Fall, 1984; not released;
    George S. Singer -- add use statement, major changes to buildmodel 
                        See Univ. of Iowa, Dept. of Comp. Sci, TR 85-03 }
{ Version 4:  started Jan 4, 1985; released for student use, spring 85;
    Douglas W. Jones -- eliminate command mode from simulate }
{ Version 5:  started June, 1985; released for student use, fall 85;
        Work on Version 5 was supported, in part, by the University of Iowa
        Weeg Computing Center in the form of salary support for Daniela Rus.
    Daniela Rus      -- move most lexical work to firstpass, fast event set
    Douglas W. Jones -- structural changes in simulate to increase speed }
{ Version 6:  started Sept., 1986;
    Jing Jan         -- structural changes in buildmodel to increase clarity
    Douglas W. Jones -- ditto, and changes in buildmodel for increased speed }
{ Version 7:  started Apr., 1987; released for student use, summer 87;
    Jing Jan         -- implemented exprs, arrays, iterators and parameterized
                        subcircuits }
{ Version 8:  started June, 1987; released for student use, jan 1988;
    Jing Jan         -- implemented conditional parts & wire lists, as well
                        as free mixing of constant and subcirc declarations
    Douglas W. Jones -- added pulse input to simulator, latch gates, changed
                        simulation header to accomodate arrays.  }
{ Version 9:  started April, 1988;
    Douglas W. Jones -- bug fixes, faster pass 1,
                        changed boolean operators to &, |, \.}
{ Version 10:  started Nov, 1998;
    Douglas W. Jones -- bug fixes, line nums from preprocessor, range
                        comparison, range or, assert construct, fix tristate
			bitcount function. }

{ Bugs:
    The official grammar lists very specific details of where commas and
        semicolons are allowed.  The simulator enforces none of these rules.
    If two different source files include the same source file, the result
        is that the text is included twice in pactext; this should be avoided.
        Now that file names are in the symbol table, it might be possible
        to search for a previous use of a file and, in that case, avoid
        rereading files, but instead, simply duplicate the needed
        parts of the data structure, specifically, the subcircuit description
        nodes for the root level subcircuits found in the file in question.
    Procedure readline depends on the ASCII colating sequence.
    The symbol table implements dynamic scope rules; it should implement
        static scope rules!
    Procedure displayheader is a mess, resulting from shotgun debugging and
        patching over the years.
    Should not rely on the characters # $ @ [ \ ] ^ | ~ to remain same from
        one language to another in ISO character set; curly braces also
        change from one language to another.  This means use of | and \ for
        or and not in expressions should have an alternative, possibly !
        and -. 
}

label 9999 { for goto from procedure fatalerror to end of main program };

const
    { constants governing limits on circuits which can be simulated }
    strpoollim = 8000  { size of strpool, identifier and string table };
    pactextlim = 16000 { size of pactext, packed input copy (see textradix) };
    tabsize = 2303     { number of entries in symtab (see textradix) };
    niltabindex = tabsize { last entry used for nil ptr to symtab };
    pooldel = '@'      { delimiter character used strpool (illegal in input) };
    linelen = 120      { input line length limit (intentionally generous) };
    filestklength = 4  { length of file stack (see f1, f2, f3, f4) };
    maxparams = 20     { suc(maximum param count) for gates and subcircuits };
    undefined = -maxint { constant for undefined parameter or array index };

    { definitions of fundamental time units, in nanoseconds }
    second = 1.0e9;
    millisecond = 1.0e6;
    microsecond = 1.0e3;
    nanosecond = 1.0;
    defgdel = 10.0     { default gate delay in nanoseconds; common TTL };
    defwdel = 0.7      { default wire delay in nanoseconds; 8-inch wire };

type
    { names of logic levels used in simulation }
    logiclevel = (low { 0, false }, high { 1, true }, open {tristate} );

    strpoolindex = 0 .. strpoollim { index type for strpool };
    tabindex = 0 .. tabsize { index type for symbol table in buildmodel };

    lineindex = 1..linelen { index type for lines of text };
    line = packed array [lineindex] of char;

    eventkinds = (lateinit, showoutput, getinput, logicchange, outchange);
    eventref = ^event;
    gateref = ^gate;
    event = record { of one event in simulate, used also to pass
                            a list of gates from buildmodel to simulate }
                kind: eventkinds;
                old, new: logiclevel;
                time: real;
                gateid: gateref;
                inputval: integer;

                { link fields for event list management }
                downlink: eventref;
                leftlink: eventref;
            end { record };

    { data structures used to represent the circuit being tested }
    wireref = ^wirelist;
    instdescrref = ^instdescr;
    tieptref = ^tiept;

    gatekind = ( { symmetric (all inputs have equal meanings) }
                 andg, nandg, org, norg, xorg, equg

                 { tristate drivers (have data and control inputs) }
               , trig, ntrig

                 { memory element (d latch) (has data and control inputs) }
               , latchg

                 { tristate bus (a named wire between bus drivers) }
               , trbg

                 { input/output interface to simulator, unused in buildmodel }
               , iogate

                 { not gate; changed to 1-input nand prior to gate allocation }
               , notg
               );

    gate = packed record
               { fields used for gate naming and error reporting }
               name: strpoolindex { name of gate };
               inst: instdescrref { circuit instance it is part of };

               { fields used for arrays of gates }
               index: integer { index of gate };
               nextgate: gateref { next gate in array (circularly linked) };
      {10}     { nextgate not needed after model is built }

      {10}     { fields used in fixtristate after model is built }
      {10}     { nextgate: if non-nil, gate where outputs were relocated to }

               { fields used for gate semantics }
               lastout: logiclevel;
               outto: wireref;
               delay: real;
               request: eventref;
               case kind:gatekind of
                  andg, nandg, org, norg, xorg, equg, trbg: (
                      { symmetrical logic gates are all the same }
                      fanin: integer;
                      instates: array [ logiclevel ] of integer;
                  );
                  ntrig, trig, latchg: (
                      inp, control: logiclevel;
                  );
                  iogate: (
                      next: gateref;
                      state: logiclevel;
                      changecount: integer;
                  );
                  notg: ( { this variant is never allocated! }
                  );
           end { record };

    instdescr = record { describes one subcircuit instance }

                    { fields used for error reporting }
                    name: strpoolindex { name of gate };
                    inst: instdescrref { circuit instance it is part of };

                    { fields used if instance is a member of an array }
                    index: integer { index of instance };
                    nextinst: instdescrref { next instance in sequence };

                    { fields used during construction of circuit only }
                    inputlist,
                    outputlist: tieptref;
                end { record };

    wirelist = packed record
                   g: gateref { gate this wire connects to };
                   inputval: integer { pin number of gate connected };
                   delay: real { delay of wire };
                   next: wireref { next wire in this chain };
               end { record };

    { types for Tie point management, used only in secondpass but
      declared here because they hook onto the symbol table and inst records }

    tiept = record   { input or output nodes of subs }
                slot: tabindex { name of this tiepoint };
                index: integer { subscript of this tiepoint };
                nexttiept: tieptref { successor of this in tiepoint list };
                nextelem: tieptref { used to circularly link tiepoint arrays };
                isinput: boolean { if false, this must be an output tiepoint };

                { if tiepoint has unknown source, following may be non-nil }
                destlist: wireref { pointer to wirelist };

                { if tiepoint has known source, following will be non-nil }
                srcgate: gateref { source (if a gate) };
                srctiept: tieptref { source (if a tiepoint) };
                delay: real { delay from source to this tiepoint };
            end;

var  { data structures for description of the model, built by second pass }
    inputs, outputs: gateref { global input and output gate lists };
    hiwire, lowire: wireref { global input constant sources };
    gatelist: eventref { master list of gates in model,
                         used for initialization in simulate };

    { data structures used for symbolic information about model; note,
      these are built by firstpass, but used everywhere }
    strpool: packed array [strpoolindex] of char;
    circuitinst: instdescrref { the main circuit instance };

    waserror: boolean { is circuit correctly defined };

    { data structures used for input processing }
    f1, f2, f3, f4: text { stack of input files };

    { private data for random number generation }
    seed: integer;



    { random number generation package }

    function random: real;
    { returns a random number between 0 and 1 }
    const
        modulus=65536;
        mul=25173;
        inc=13849;
    begin
        seed :=((mul * seed) + inc) mod modulus;
        random :=seed / modulus;
    end { random };

    function jitter( r: real ): real;
    { returns a multiplier approximately equal to 1, but with
      a random variation constrained by the given range(which
      must be less than 1 if negative results are to be avoided) }
    begin
        jitter := 1 + r * (1 - (random + random));
    end { jitter };



    { print name management }

    procedure printname( r: strpoolindex ; var len:integer; limit: integer);
    { print a name from the strpool, report printed length in len, but never
      print more than limit chars }
    begin
        len := 0;
        while (strpool[r] <> pooldel) and (len < limit) do begin
            write( strpool[r] );
            r := r + 1;
            len := len + 1;
        end;
    end { printname };

    procedure printprefix( inst: instdescrref; length: integer );
    { print the prefix path name of a circuit instance }
    var i: integer;
    begin
        if (inst <> nil) and (length > 0) then begin 
            printprefix( inst^.inst, length - 1 );
            printname( inst^.name, i, 80 );
            if inst^.index <> undefined then
                write( '(', inst^.index:1, ')' );
            write( '.' );
        end;
    end { printprefix };

    procedure printgatename( gate: gateref );
    { print the full path name of a gate (through all instances) }
    var i: integer;
    begin { printgatename }
        printprefix( gate^.inst, maxint );
        printname( gate^.name, i, 80 );
        if gate^.index <> undefined then
            write( '(', gate^.index:3, ')' );
    end { printgatename };



    { basic line management package }

    procedure readline( var f: text; var l: line; var len: integer );
    { read an input line from f ( cleanly );
      will strip all pooldel and control characters out of input;
      on end file, returns a line holding pooldel in column 1;
      l[len+1] is guaranteed to be blank; len < linelen always holds!
      WARNING:  This code depends on the ASCII colating sequence.
    }
    var ch: char;
        i: 0..linelen;
    begin
        i := 0;
        if not eof( f ) then begin
            while not eoln( f ) do begin
                read( f, ch );
                if ch = pooldel then begin
                    { ignore the string pool delimiter }
                end else if (ch >= ' ') and (ch <= '~') then begin { printing }
                    { the above line of code detects ASCII printing chars }
                    if i < (linelen - 1) then begin
                        i := i + 1;
                        l[i] := ch;
                    end;
                end else if ch = chr(8) then begin { ASCII backspace }
                    if i > 0 then i := i - 1;
                end else if ch = chr(9) then begin { ASCII tab }
                    if i < (linelen - 1) then begin { convert to blank }
                        i := i + 1;
                        l[i] := ' ';
                    end;
                end else begin
                    { ignore everything else }
                end;
            end { end while };
            readln( f );
        end else begin { at eof }
            i := 1;
            l[i] := pooldel;
        end;
        { assert 0 <= i < linelen }
        l[i+1] := ' ';
        len := i;
    end { readline };
    
    procedure writeoutput( var l:line; len: integer );
    { write a line cleanly to the terminal, minus trailing blanks;
      the line is passed by reference to avoid copying! }
    var i: lineindex;
    begin
        for i := 1 to len do write( l[i] );
        writeln;
    end { writeoutput };



    { main procedure to compile circuit specification }
    
    procedure buildmodel;
    { build the data structures for simulating a logic circuit }

    const
        textradix = 64 { radix used for integers encoded in pactext; this
                          must be bigger than root2( tabsize ), also bigger
                          than root3( pactextlim ), and less than
                          ord(maxchar); we assume that chr(0) is legal };
        undeflevel = 0 { nesting level of undefined ids };

    type
        fileref = 0..filestklength { ref to a file in the file stack };
        pactextindex = 0 .. pactextlim { index type for pactext };
        paramindex = 0 .. maxparams { parameter list index type };

        { structure describing nesting relations between (sub)circuits }
        subref = ^subdef;
        subdef = record
                     { description of circuit header, including name }
                     headpos: pactextindex { points to text after name };
                     slot: tabindex { name of the subcircuit };

                     parsed: boolean { were errors reported in this circuit };
                     instcount: integer { number of instances created };

                     { fields for structure itself }
                     son: subref { head of list of sons of this circuit };
                     brother: subref { link in list of sons };
                 end;

        { types of symbols and keywords }

        lextyp = { type of a lexeme; see arrays lextoch and chtolex,
                   initialized in initlexpack; changes here go there too!
                   the bounds will always be assumed to be id .. junk }
                 (
                  { complex lexeme types with other attributes,
                    always in the bounds id .. res }
                  id, inum, rnum, hop, res,

                  { simple cases such as punctuation follow }
                  colon, dot, plus, minus, star, slash, equal,
                  dotdot, starstar, bpar, epar, eofile,
                  less, lesseq, noteq, greateq, great,
                  andop, orop, notop,

                  kin { used in gotbutwant to flag 'in' is missing },
                  junk { not classifiable as a lexeme, also used between
                         the time a new symbol is put in the symbol table
                         and the time it is given appropriate attributes }
                 );

        keytyp = { type of a keyword; note: the bounds of keytyp will
                   always be assumed to be keycirc .. notkey; the order
                   of these determines which of a set of expected keywords
                   will be used in an error message when one is not found }
                 (keycirc 
                 ,keyint,  keyreal, keytime, keyrange, keybool
      {10}       ,keyassert
                 ,keyuse
                 ,keyinp,  keyoutp, keypart, keywire, keyend
                 ,keyfor,  keyto,   keydo,   keyendf
                 ,keyif,   keythen, keyelse, keyendif
                 ,keymod
                 ,notkey { not a keyword } );

        iduse =  { the use to which an indentifier has been put }
                 (inuse, outuse, gateuse, typeuse, subuse, instuse
                 ,decluse, unuse { use not yet determined } );

        symref = ^symbol;

        { types used for storing the value of an expression }

        exprtyp = ( { type of an expression }
                    inttyp, realtyp, timetyp, rangetyp, circtyp, booltyp,

                    undef { indicates the expression was in error },
                    noexpr { in a parameter list, indicates the end }
                  );

        valtyp = record
                     case typ: exprtyp of
                       inttyp: (ival: integer);
                      realtyp,
                      timetyp: (rval: real);
                     rangetyp: (first, last: integer);
                      booltyp: (bval: boolean);
                      circtyp: (subptr: symref);
                        undef,
                       noexpr: ();
                 end { record };

        { types used for storing a subcircuit }

        symbol = record
                     name: strpoolindex;
                     case typ: lextyp of
                         res: ( restyp: char { one letter code for it } );
                          id: ( level: integer {nesting level};
                                stkptr: symref { previous definition };
                                nextsym: tabindex { next symbol, same level };

                                { next 2 line applies only when
                                  use in [inuse, outuse, gateuse, instuse]
                                  if it is not an array, both equal undefined }
                                first, last: integer { array bounds if array };
                 
                                case use: iduse of
                                   inuse: (inputdef: tieptref);
                                  outuse: (outputdef: tieptref);
                                 gateuse: (g: gateref);
                                 typeuse: (t: gatekind;
                                           max, min: paramindex;
                                           typecount: integer);
                                  subuse: (s: subref);
                                 instuse: (inst: instdescrref );
                                 decluse: (valu: valtyp);
                                   unuse: ()
                              );
                        inum: ( ival: integer );
                        rnum: ( rval: real );

                        hop, colon, dot, plus, minus, star, slash,
                        equal, dotdot, starstar, bpar, epar, eofile,
                        less, lesseq, noteq, greateq, great, andop,
                        orop, notop, kin, junk
                            : ();
                 end { record };

    var { pseudo constants used in building and reading pactext }
        rescode: array[ char ] of keytyp { used to unpack keywords };
        lextoch: array[ lextyp ] of char { used to pack lexemes };
        chtolex: array[ char ] of lextyp { used to unpack lexemes };

        { pseudo constant pointers to predefined idents (not keywords!) }
        symin, symout: tabindex;
        symctl, symdata: tabindex;
        symsize, symfirst, symlast: tabindex;
        symodd, symonebits: tabindex;
        symhi, symlo: tabindex;
        symtally: tabindex;

        { the primary data items passed from firstpass to secondpass }

        pactext: packed array [pactextindex] of char {encoded text};
                        { the data format used in pactext is most
                          clearly documented in firstpass.copy. }

        symtab: array [tabindex] of symref { the symbol table };
        subhead: subref { root of the tree of subcircuits };
        tally: boolean { does user want tally of subcircuit and gate use? };


        procedure printsym( s: tabindex );
        { print a symbol; used inside error message packages of both passes }
        var xx: integer;
        begin
            write( '"' );
            if symtab[s] <> nil
              then printname( symtab[s]^.name, xx, 80 )
              else write( '-- error --' );
            write( '"' );
        end { printsym };

        procedure firstpass;
        { has to read from several files the definitions of circuits and
          of the main program and put them in the strpool. Also create
          the subcircuit structure, which is hanging from headSub }

        type
            errtype = ( errstrpoolovf, errsymtabovf, errunexpeof,
                        errcuioexp, errfilenest, errcirexp,
                        erridexp, erreofexp, erreparexp,
      {10}              errjunk,
                        errbadnum, errpactextovf );

            filerec = record
                          level: fileref;
                          name: tabindex { of file name };
                          currentline: line;
                          lineno: integer;
                          linepos: lineindex;
                      end;

        var { logical constants, legal characters, legal chars in idents }
            validch, idchars: set of char;

            currentfile: fileref { file currently reading from };

            srcfile: tabindex { index of name of current file in symtab };
            srcline: line { current line, read from };
            srclen: integer { number of characters in srcline };
            srclno: integer { line number of srcline };
            srcpos: lineindex { lexical scanner position in the srcline };
            srcchar: char { the character at srcpos in srcline };

            lexstart: lineindex { position where lexeme starts };
            lexend: lineindex { position where lexeme ends };
            lexemetyp: lextyp { type of lexeme };
            lexkeytyp: keytyp { more info for lexemetyp = res };
            lexslot: tabindex { more info if lexemetyp in [id,num] };

            strpos: strpoolindex { current position in strpool };

            symcount: tabindex { count of symbols defined in symtab };

            textpos: pactextindex { current position in pactext };
            textfile: tabindex { of most recent token copied to pactext };
            textlno: integer { of most recent token copied to pactext };

            procedure initializations;
            { initialize for firstpass }

                procedure initsymtab;
                { enter the reserved words in the symbol table }
                const strlen = 8;
                type string8 = packed array [1..strlen] of char;
                     { misspell string to avoid collisions with the reserved
                       word string used in some extended compilers; this
                       type is used only in define, and quoted strings passed
                       as parameters to define must coerce to this type. }
                var i, entry: integer;

                    procedure define( s: string8 );
                    { enter s in strpool and put it in the symbol table at
                      a position returned in the global variable entry;
                      This code computes a hash value of s;
                      NOTE: it must use the same hash function as
                      is used for hashing in lookup }
                    var start: strpoolindex;
                        j: integer;
                    begin
                        { put the string in strpool }
                        start := strpos { save the beginning };
                        for j := 1 to strlen do if s[j] <> ' ' then begin
                            strpool[ strpos ] := s[j];
                            strpos := strpos + 1;
                        end;
                        strpool[ strpos ] := pooldel;
                        strpos := strpos + 1;

                        { compute hash function as hash(s)
                          = (ord car(s) + 5*hash(cdr(s))) mod tabsize }
                        entry := 0;
                        for j := (strpos - start) - 1 downto 1
                          do entry := (entry*5 + ord(s[j])) mod tabsize;

                        { resolve collisions; note that this code
                          assumes that all definitions are new ones and
                          thus that a search for an empty slot suffices }
                        while symtab[ entry ] <> nil
                          do entry := (entry + 1) mod tabsize;

                        { begin building symtab entry; others end job }
                        new( symtab[ entry ] );
                        symtab[entry]^.name := start;
                        symcount := symcount + 1;
                    end { define };
                        
                    procedure makeid;
                    { make symbol at symtab[entry] into an identifier }
                    begin
                        symtab[entry]^.typ := id; 
                        symtab[entry]^.use := unuse;
                        symtab[entry]^.level := undeflevel;
                    end { makeid };

                    procedure maketime( t: real );
                    { make symbol at symtab[entry] into a time interval name }
                    begin
                        symtab[entry]^.typ := id;
                        symtab[entry]^.level := undeflevel;
                        symtab[entry]^.use := decluse;
                        symtab[entry]^.valu.typ := timetyp;
                        symtab[entry]^.valu.rval := t;
                    end { maketime };

                    procedure makebool( b: boolean );
                    { make symbol at symtab[entry] into a boolean constant }
                    begin
                        symtab[entry]^.typ := id;
                        symtab[entry]^.level := undeflevel;
                        symtab[entry]^.use := decluse;
                        symtab[entry]^.valu.typ := booltyp;
                        symtab[entry]^.valu.bval := b;
                    end { makebool };

                    procedure makekey( k: keytyp; c: char );
                    { make symbol at symtab[entry] into a reserved word }
                    begin
                        symtab[entry]^.typ := res;
                        symtab[entry]^.restyp := c;
                        rescode[c] := k;
                        chtolex[c] := res;
                    end { makekey };
                        
                    procedure makegate( gk: gatekind; lowp, highp: paramindex );
                    { make symbol at symtab[entry] into a gate of type g }
                    begin
                        with symtab[entry]^ do begin
                            typ := id;
                            level := undeflevel;
                            use := typeuse;
                            t := gk;
                            max := highp;
                            min := lowp;
                            typecount := 0;
                        end;
                    end;

                begin { initsymtab }

                    for i := 0 to tabsize do symtab[i] := nil;

                    { the following nonsense assignment is included to suppress
                      error messages from compilers that think entry is
                      undefined and don't notice that define defines it as a
                      side effect. }
                    entry := 0;

                    define('in      '); makeid; symin := entry;
                    define('out     '); makeid; symout := entry;
                    define('control '); makeid; symctl := entry;
                    define('data    '); makeid; symdata := entry;

                    define('size    '); makeid; symsize := entry;
                    define('first   '); makeid; symfirst := entry;
                    define('last    '); makeid; symlast := entry;
                    define('odd     '); makeid; symodd := entry;
                    define('onebits '); makeid; symonebits := entry;

                    define('high    '); makeid; symhi := entry;
                    define('low     '); makeid; symlo := entry;

                    define('tally   '); makeid; symtally := entry;

                    define('true    '); makebool( true );
                    define('false   '); makebool( false );

                    define('s       '); maketime( second );
                    define('ms      '); maketime( millisecond );
                    define('us      '); maketime( microsecond );
                    define('ns      '); maketime( nanosecond );

                    define('not     '); makegate( notg, 0, 1 );
                    define('equ     '); makegate( equg, 0, 1 );
                    define('and     '); makegate( andg, 1, 2 );
                    define('nand    '); makegate( nandg, 1, 2 );
                    define('or      '); makegate( org, 1, 2 );
                    define('nor     '); makegate( norg, 1, 2 );
                    define('xor     '); makegate( xorg, 0, 1 );
                    define('bus     '); makegate( trbg, 0, 0 );
                    define('tsgate  '); makegate( trig, 0, 1 );
                    define('ntsgate '); makegate( ntrig, 0, 1 );
                    define('latch   '); makegate( latchg, 0, 1 );

                    { the one letter codes listed for each keyword must not
                      conflict with the codes used in lextoch (see below) }
                    define('circuit '); makekey( keycirc, 'C' );
                    define('inputs  '); makekey( keyinp, 'I' );
                    define('outputs '); makekey( keyoutp, 'O' );
                    define('parts   '); makekey( keypart, 'P' );
                    define('wires   '); makekey( keywire, 'W' );
                    define('end     '); makekey( keyend, 'E' );
                    define('to      '); makekey( keyto, 'T' );
      {10}          define('assert  '); makekey( keyassert, 'S' );
                    define('use     '); makekey( keyuse, 'U' );
                    define('for     '); makekey( keyfor, 'F' );
                    define('mod     '); makekey( keymod, 'M' );
                    define('do      '); makekey( keydo, 'D' );
                    define('endfor  '); makekey( keyendf, 'N' );
                    define('integer '); makekey( keyint, 'G' );
                    define('real    '); makekey( keyreal, 'R' );
                    define('time    '); makekey( keytime, 'V' );
                    define('range   '); makekey( keyrange, 'A' );
                    define('boolean '); makekey( keybool, 'B' );
                    define('if      '); makekey( keyif, 'J' );
                    define('then    '); makekey( keythen, 'H' );
                    define('else    '); makekey( keyelse, 'L' );
                    define('endif   '); makekey( keyendif, 'K' );
                end { initsymtab };

                procedure initlexpack;
                { the one letter codes assigned here must differ from those
                  used above for keywords (as the second parameter to makekey)
                  and they must not include the digits used for line counting
                  in firstpass.copy and in secondpass.nextlex or blank, used
                  as a prefix on filenames in firstpass.fixhop and
                  secondpass.nextlex, or cedilla, used to negate line numbers }
                var lex: lextyp;
                begin
                    lextoch[id] := 'i';
                    lextoch[inum] := 'n';
                    lextoch[rnum] := 'r';
                    lextoch[hop] := 'h' { see planthop, secondpass.nextlex };
                    lextoch[res] := 's' { substitute rescode for this };
                    lextoch[colon] := ':';
                    lextoch[dot] := '.';
                    lextoch[plus] := '+';
                    lextoch[minus] := '-';
                    lextoch[star] := '*';
                    lextoch[slash] := '/';
                    lextoch[equal] := '=';
                    lextoch[dotdot] := 'd';
                    lextoch[starstar] := 's';
                    lextoch[bpar] := '(';
                    lextoch[epar] := ')';
                    lextoch[eofile] := 'e' { never sent! };
                    lextoch[less] := '<';
                    lextoch[lesseq] := 'l';
                    lextoch[noteq] := 'x';
                    lextoch[greateq] := 'g';
                    lextoch[great] := '>';
                    lextoch[andop] := '&';
                    lextoch[orop] := '!';
                    lextoch[notop] := '\';
                    lextoch[kin] := 'k' { never sent!};
                    lextoch[junk] := 'j' { never sent! };

                    for lex := id to junk do chtolex[lextoch[lex]] := lex;
                end { initlexpack };

            begin { initializations }
                strpos := 0;
                textpos := 0;
                currentfile := 0;
                symcount := 0;
                tally := false;

                { The following should be constants; note that the alphabet
                  is broken in such a way that this should work equally
                  well for EBCDIC and ASCII representations }
                idchars := ['A'..'I', 'J'..'R', 'S'..'Z',
                            'a'..'i', 'j'..'r', 's'..'z',
                            '0'..'9'                       ];
                validch := idchars + [':', '.', ',', ';', '(', ')',
                                      '+', '-', '*', '/', '=', '<', '>',
                                      '&', '|', '\'];

                initsymtab;
                initlexpack;
            end { initializations };

            procedure fatalerror;
            begin
                writeln;
                writeln ( 'Compilation aborted; fatal error.' );
                writeln;
                goto 9999 { transfer to end of program };
                { if nonlocal gotos are not available, a call to a
                  nonstandard halt procedure will be needed here };
            end {fatalerror};

            procedure error( errcode: errtype );
            begin
                waserror := true;
                writeln;
                write( 'ERROR on line ', srclno:1, ' of file ' );
                printsym(srcfile);
                writeln;
                write( '      ---> ' );

                case errcode of
                    errstrpoolovf: write('string pool overflow');
                    errpactextovf: write('packed text overflow');
                    errsymtabovf:  write('symbol table overflow');
                    errunexpeof:   write('unexpected EOF');
                    errcuioexp:    write('"circuit" or "inputs" expected');
                    erridexp:      write('identifier expected');
                    errfilenest:   write('too many use levels; limit = 4');
                    errcirexp:     write('"circuit" expected');
                    erreofexp:     write('EOF expected');
      {10}          errjunk:       write('unindentifiable lexeme');
                    errbadnum:     write('bad number');
                    erreparexp:    write('")" expected in parameter list');
                end { case }; 
                write( ' ' );

                if errcode in [ errstrpoolovf, errsymtabovf, errunexpeof
                              , errfilenest, errpactextovf ]
                  then fatalerror;
            end {error};


            { first pass lexical analysis package }
            
            procedure readfile;
            { read an input line from one file( cleanly ) }
            begin
                case currentfile of
                    1: readline( f1, srcline, srclen );
                    2: readline( f2, srcline, srclen );
                    3: readline( f3, srcline, srclen );
                    4: readline( f4, srcline, srclen );
                end {case};
            end { readfile };

            procedure bumppos;
            { advance the lexical analysis process one character,
              possibly advancing to the next line in the process;
              keep srcchar holding a copy of this character.
              For speed, the body of this is expanded as a macro in
              common cases (skipping comments, identifiers, numbers) }
            begin
                if srcpos > srclen then begin
                    readfile;
                    srclno := srclno + 1;
                    srcpos := 1;
                end else begin
                    srcpos := srcpos + 1;
                end;
                srcchar := srcline[srcpos];
            end { bumppos };

            procedure skipcomments;
            { scan over current character(s) if they're delimiters;
              delimeters include spaces, Pascal style comments,
              PL/I style comments, and Ada style comments }
            var  del: boolean;
      {10}       num: integer;
            begin
                del := true;
                while del do begin
                    while (srcchar = ' ') do begin { bumppos }
                        if srcpos > srclen then begin
                            readfile;
                            srclno := srclno + 1;
                            srcpos := 1;
                        end else begin
                            srcpos := srcpos + 1;
                        end;
                        srcchar := srcline[srcpos];
                    end { bumppos };
                    if srcchar in [ '{', '(', '-', '/', ',', ';' ]
                    then case srcchar of
                      ';',              { note that this code implies that }
                      ',':begin         { semicolons and commas never appear }
                              bumppos;  { as lexemes! }
                          end;
                      '{':begin
      {10}                    if srcline[srcpos+1] = '=' then begin
      {10}                        { line number fix provided by preprocessor }
      {10}                        bumppos;
      {10}                        bumppos;
      {10}                        num := 0;
      {10}                        while srcchar in ['0'..'9'] do begin
      {10}                            num := num*10 + (ord(srcchar)-ord('0'));
      {10}                            bumppos;
      {10}                        end;
      {10}                        if  (srcchar = '=')
      {10}                        and (srcline[srcpos + 1] = '}')
      {10}                          then srclno := num;
      {10}                    end else begin
      {10}                        bumppos;
      {10}                    end;
      {10}                    while (srcchar <> '}')
      {10}                    and   (srcchar <> pooldel) do begin
                                  { bumppos }
                                  if srcpos > srclen then begin
                                      readfile;
                                      srclno := srclno + 1;
                                      srcpos := 1;
                                  end else begin
                                      srcpos := srcpos + 1;
                                  end;
                                  srcchar := srcline[srcpos];
                                  { end bumppos }
      {10}                    end;
                              if srcchar <> pooldel then bumppos;
                          end;
                      '-':if srcline[srcpos+1] = '-' then begin
                              srcpos := linelen { force newline };
                              bumppos;
                          end else begin
                              del := false;
                          end;
                      '(':if srcline[srcpos+1] = '*' then begin
                              repeat
                                  repeat bumppos until (srcchar = '*')
                                                    or (srcchar = pooldel);
                              until (srcline[srcpos+1] = ')')
                                 or (srcchar = pooldel);
                              if srcchar <> pooldel then begin
                                  bumppos;
                                  bumppos;
                              end;
                          end else begin
                              del := false;
                          end;
                      '/':if srcline[srcpos+1] = '*' then begin
                              repeat
                                   repeat bumppos until (srcchar = '*')
                                                     or (srcchar = pooldel);
                              until (srcline[srcpos+1] = '/')
                                 or (srcchar = pooldel);
                              if srcchar <> pooldel then begin
                                  bumppos;
                                  bumppos;
                              end;
                          end else begin
                              del := false;
                          end;
                    end { case } else begin
                        del := false;
                    end { if };
                end { while };
            end { skipcomments };

            function lookup: tabindex;
            { This function returns the index of the current lexeme in
              symtab, it may have to put it there first, in which case, it
              declares the type of the symbol to be junk (the user must
              change this after calling lookup if it isn't junk);
              NOTE: this function must use the same code as
              is used for hashing in initsymtab.define }

            var done: boolean;
                x: strpoolindex;
                y: lineindex;
                i,initial: tabindex;

            begin { lookup }
                { compute the hash code for the lexeme as
                  hash(s) = (ord car(s) + 5*hash(cdr(s))) mod tabsize }
                i := 0;
                for y := lexend - 1 downto lexstart
                  do i := (i * 5 + ord( srcline[y] )) mod tabsize;
                { note that the above intentionally avoids using
                  symtab[tabsize]; this is used as a nil entry in
                  lists of symbols }

                { resolve collisions }
                done := false;
                initial := i;
                while (symtab[i] <> nil) and not done do begin
                    x := symtab[i]^.name;
                    y := lexstart;
                    { note that pooldel will not be in the lexeme }
                    while (strpool[x] = srcline[y]) do begin
                        y := y + 1;
                        x := x + 1;
                    end;
                    done := (strpool[ x ] = pooldel) and (y = lexend);
                    if not done then begin
                        i := (i + 1) mod tabsize;
                        if i = initial then error( errsymtabovf );
                    end;
                end;

                { put the symbol in the table if needed }
                if not done then begin { must define the symbol }
                    new( symtab[i] );
                    symtab[i]^.name := strpos;
                    if (strpos +(lexend - lexstart)+ 2) > strpoollim then begin
                        error( errstrpoolovf );
                    end else begin { put it in the stringpool }
                        for y := lexstart to lexend - 1 do begin
                            strpool[strpos] := srcline[ y ];
                            strpos := strpos + 1;
                        end;
                        strpool[strpos] := pooldel;
                        strpos := strpos + 1;
                    end { if };
                    symtab[i]^.typ := junk;
                    symcount := symcount + 1;
                end;

                lookup := i;
            end { lookup };

            procedure nextlex;
            { get the next lexeme from the input file; uses bumppos and
              skipcomments to advance through input; returns information
              about lexeme in lexstart and lexend (the position of the
              lexeme in linebuf) }

                function number( base: integer ): real;
                { parse a floating point number }
                var err: boolean;
                    val: integer;
                    scale: real;
                    y: lineindex;

                    procedure onedigit;
                    { compute value of the current digit and accumulate
                      it in number.val }
                    var d: integer;
                    begin
                        d := ord( srcline[y] ) - ord( '0' );
                        if d >= base then
                            err := true
                        else if val > ((maxint - d ) div base) then
                            err := true
                        else val := val * base + d;
                        y := y + 1;
                    end { onedigit };
              
                begin { number }
                    val := 0;
                    err := false;
                    y := lexstart;
                    while srcline[y] in ['0'..'9'] do onedigit;
                    if srcline[y] = '.' then begin
                        scale := 1;
                        y := y + 1;
                        while srcline[y] in ['0'..'9'] do begin
                            onedigit;
                            scale := scale * base;
                        end;
                        number := val / scale;
                    end else number := val;
                    if err then error( errbadnum ); 
                end { number };

            begin { nextlex }
                { assume that srcchar = srcline[srcpos] ready to examine }
                skipcomments;
                lexkeytyp := notkey { default assumption };
                lexslot := niltabindex { default };
                lexstart := srcpos;
                if srcchar = pooldel then begin { at end of file }
                    lexemetyp := eofile;
                end else if srcchar in validch then case srcchar of

                    ':': begin lexemetyp := colon; bumppos; end;
                    '(': begin lexemetyp := bpar; bumppos; end;
                    ')': begin lexemetyp := epar; bumppos; end;
                    '+': begin lexemetyp := plus; bumppos; end;
                    '-': begin lexemetyp := minus; bumppos; end;
                    '=': begin lexemetyp := equal; bumppos; end;
                    '/': begin lexemetyp := slash; bumppos; end;
                    '&': begin lexemetyp := andop; bumppos; end;
                    '|': begin lexemetyp := orop; bumppos; end;
                    '\': begin lexemetyp := notop; bumppos; end;

                    '.': begin
                               lexemetyp := dot; bumppos;
                               if srcchar = '.' then begin
                                   lexemetyp := dotdot;
                                   bumppos;
                               end;
                         end;
                    '*': begin
                               lexemetyp := star; bumppos;
                               if srcchar = '*' then begin
                                   lexemetyp := starstar;
                                   bumppos;
                               end;
                         end;
                    '<': begin
                               lexemetyp := less; bumppos;
                               if srcchar = '>' then begin
                                   lexemetyp := noteq;
                                   bumppos;
                               end else if srcchar = '=' then begin
                                   lexemetyp := lesseq;
                                   bumppos;
                               end;
                         end;
                    '>': begin
                               lexemetyp := great; bumppos;
                               if srcchar = '=' then begin
                                   lexemetyp := greateq;
                                   bumppos;
                               end;
                         end;

                    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
                    'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R',
                    'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',
                    'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i',
                    'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r',
                    's', 't', 'u', 'v', 'w', 'x', 'y', 'z':
                        begin { identifier or reserved word }
                            repeat { bumppos }
                                if srcpos > srclen then begin
                                    readfile;
                                    srclno := srclno + 1;
                                    srcpos := 1;
                                end else begin
                                    srcpos := srcpos + 1;
                                end;
                                srcchar := srcline[srcpos];
                            { end bumppos } until not( srcchar in idchars );
                            lexend := srcpos;
                            lexslot := lookup;
                            with symtab[lexslot]^ do begin
                                if typ = junk then begin
                                    typ := id;
                                    use := unuse;
                                    level := undeflevel;
                                end;
                                lexemetyp := typ;
                                if lexemetyp = res
                                  then lexkeytyp := rescode[restyp];
                            end;
                        end;

                    '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
                        begin { number }
                            repeat { bumppos }
                                if srcpos > srclen then begin
                                    readfile;
                                    srclno := srclno + 1;
                                    srcpos := 1;
                                end else begin
                                    srcpos := srcpos + 1;
                                end;
                                srcchar := srcline[srcpos];
                            { end bumppos } until not( srcchar in ['0'..'9'] );
                            if (srcchar = '.')
                            and (srcline[srcpos+1] <> '.') then begin
                                repeat bumppos
                                  until not( srcchar in ['0'..'9'] );
                                lexemetyp := rnum;
                                lexend := srcpos;
                                lexslot := lookup;
                                with symtab[lexslot]^ do
                                if typ = junk then begin
                                    typ := rnum;
                                    rval := number( 10 );
                                end;
                            end else begin;
                                lexemetyp := inum;
                                lexend := srcpos;
                                lexslot := lookup;
                                with symtab[lexslot]^ do
                                if typ = junk then begin
                                    typ := inum;
                                    ival := round( number( 10 ) );
                                end;
                            end;
                        end;

                end { case } else begin { any other character }
                    lexemetyp := junk;
                    repeat bumppos until srcchar in validch + [pooldel];
                    lexend := srcpos;
                end { if };
            end { nextlex };

            procedure getfname( var n: tabindex );
            { get a file name into the current lexeme; note that file names
              do not obey the usual lexical rules; they may have characters
              which would normally separate lexemes; nonetheless, they
              end up occupying a space in the symbol table, but their use
              as file names does not involve any of the normal semantic
              information stored in the symbol table }
            begin
                skipcomments;
                lexstart := srcpos;
                lexkeytyp := notkey;
                if srcchar <> pooldel then begin
                    lexemetyp := junk;
                    repeat { search for end of file name }
                        bumppos;
                    until srcchar in [' ',';'];
                    lexend := srcpos;
                    n := lookup;
                end else begin { eof occured }
                    lexemetyp := eofile;
                end;
            end { getfname };

            procedure savelex( var f: filerec );
            { save the state of the lexical analysis system }
            begin
                f.level := currentfile;
                f.name := srcfile;
                f.currentline := srcline;
                f.lineno := srclno;
                f.linepos := srcpos;
            end { savelex };

            procedure restorelex( var f: filerec );
            { recover the state of the lexical analysis system }
            begin
                currentfile := f.level;
                srcfile := f.name;
                srcline := f.currentline;
                srclno := f.lineno;
                srcpos := f.linepos;
                srcchar := srcline[srcpos];
                lexemetyp := junk { not saved, but was a file name, aka junk! };
            end { restorelex };

            procedure openlex( f: tabindex );
            { open lexical analysis from f, a file name indexed in symtab }
            var fname: line;
                i: strpoolindex;
                j: lineindex;
            begin
                if currentfile >= filestklength then begin
                    error( errfilenest );
                end else begin { there are enough nesting levels }
                    currentfile := currentfile + 1;

                    { copy f into fname }
                    i := symtab[f]^.name;
                    j := 1;
                    while strpool[i] <> pooldel do begin
                        fname[j] := strpool[i];
                        i := i + 1;
                        j := j + 1;
                    end;
                    for j := j to linelen do fname[j] := ' ';

                    { open the file }
                    case currentfile of
                        1: reset( f1, fname );
                        2: reset( f2, fname );
                        3: reset( f3, fname );
                        4: reset( f4, fname );
                    end {case};

                    readfile { read the first line };
                    srcfile := f;
                    srclno := 1;
                    srcpos := 1;
                    srcchar := srcline[srcpos];
                    nextlex;
                end;
            end { openlex };


            { first pass code used to build pactext for second pass }
              
            procedure copy;
            { Copies the current lexeme to pactext in packed form. }
            var d: integer;
            begin { copy }

                if textfile <> srcfile then begin { new file since last copy! }
                    if textpos > (pactextlim - 3)
                      then error( errpactextovf );
                    pactext[textpos    ] := ' ';
                    pactext[textpos + 1] := chr(srcfile mod textradix);
                    pactext[textpos + 2] := chr(srcfile div textradix);
                    textpos := textpos + 3;
                    textfile := srcfile;
                    textlno := 0;
                end;

      {10}      if textlno <> srclno then begin { new line since last copy }
                    d := srclno - textlno;
      {10}          if d < 0 then begin { handle backward steps }
      {10}              { backsteps occur when preprocessor resets line num }
      {10}              if textpos > (pactextlim - 1)
      {10}                then error( errpactextovf );
      {10}              pactext[ textpos ] := '~';
      {10}              textpos := textpos + 1;
      {10}              d := -d;
      {10}          end;
                    while d > 0 do begin
                        if textpos > (pactextlim - 1)
                          then error( errpactextovf );
                        pactext[ textpos ] := chr( (d mod 10) + ord('0') );
                        textpos := textpos + 1;
                        d := d div 10;
                    end { while };
                    textlno := srclno;
                end { if };

                case lexemetyp of { copy the lexeme into pactext }

                    colon, dot, bpar, epar, plus, minus,
                    star, slash, equal, less, great, andop, orop, notop,
                    dotdot, starstar, lesseq, greateq, noteq:
                        begin
                            if textpos > (pactextlim - 1)
                              then error( errpactextovf );
                            { enter separators as themselves }
                            pactext[textpos] := lextoch[lexemetyp];
                            textpos := textpos + 1;
                        end;

                    id, inum, rnum:
                        begin
                            if textpos > (pactextlim - 3)
                              then error( errpactextovf );
                            pactext[textpos] := lextoch[lexemetyp];
                            pactext[textpos+1]
                                        := chr(lexslot mod textradix);
                            pactext[textpos+2]
                                        := chr(lexslot div textradix);
                            textpos := textpos + 3;
                        end;

                    res:
                        begin
                            if textpos > (pactextlim - 1)
                              then error( errpactextovf );
                            pactext[textpos] := symtab[lexslot]^.restyp;
                            textpos := textpos + 1;
                        end;

                    hop { never happens },
                    eofile { never happens }:
                        { do nothing };

      {10}          junk { error needs reporting }:
      {10}              error( errjunk );

                end { case };
            end { copy };
              

            { procedures to parse circuit and subcircuit defintions }

            procedure readcirc( var s: subref );
            { read and copy the definition of one circuit, and set s
              to point to a record of that circuit; the syntax follows:

                <circuit> ::= <head> [ <declaration> |
                                       <use> | <circuit> ]* <body>
                <head> ::= circuit <identifier> [ <formalparamlist> ]
                <formalparamlist> ::= "(" <lexeme>* ")"
                <declaration> ::= <declkeyword> [ <lexeme> ]*
                <use> ::= use <filename>
                <body> ::= [ (inputs | outputs | parts | wires) <lexeme>* ] end
            }
            var myson: subref { working ref to a son of current circuit };
                lasthop: pactextindex { pointer to last text prior to subcirc };
                lastfile: tabindex { file reading from at time of hop };
                lastline: integer { line reading from at time of hop };

                procedure planthop;
                begin
                    if lasthop = 0 then begin { hop must be planted }
                        if textpos > (pactextlim - 4)
                          then error( errpactextovf );
                        lasthop := textpos + 1;
                        lastfile := textfile;
                        lastline := textlno;
                        pactext[textpos] := lextoch[hop];
                        textpos := textpos + 4;
                    end;
                end { planthop };

                procedure fixhop;
                begin
                    if lasthop <> 0 then begin { a hop to here was planted }
                        pactext[lasthop    ]
                                := chr(textpos mod textradix);
                        pactext[lasthop + 1]
                                := chr((textpos div textradix) mod textradix);
                        pactext[lasthop + 2]
                                := chr(textpos div (textradix * textradix));
                        lasthop := 0;
                        textfile := lastfile;
                        textlno := lastline;
                    end;
                end { fixhop };

                procedure copydefs;
                { copy definitions in circuit body or use file }

                    procedure readuse;
                    { handle use file insertions }
                    var f: filerec { save location for previous input source };
                        newf: tabindex { the text of a file name };
                    begin
                        getfname( newf );
                        if lexemetyp <> eofile then begin { have file name }
                            savelex( f );
                            openlex( newf );
                            copydefs;
                            if lexemetyp = dot then nextlex;
                            if lexemetyp <> eofile then error( erreofexp );
                            restorelex( f );
                            nextlex { get the lexeme after the file name };
                        end { else someone else will complain about eof };
                    end { readuse };

                begin { copydefs }
                    repeat
                        { find the next keyword }
                        if (lexemetyp <> eofile)
                        and not(lexkeytyp in [keyuse,
     {10}                                     keyassert,
                                              keycirc, keyint, keyreal,
                                              keytime, keyrange, keybool,
                                              keypart, keyinp, keyoutp,
					      keywire, keyend])
                        then begin
                            error( errcuioexp );
                            repeat nextlex
                            until (lexemetyp = eofile)
                               or (lexkeytyp in [keyuse,
     {10}                                        keyassert,
                                                 keycirc, keyint, keyreal,
                                                 keytime, keyrange, keybool,
                                                 keypart, keyinp, keyoutp,
					         keywire, keyend]);
                        end;

                        if lexkeytyp = keyuse then begin
                            readuse;
                        end else if lexkeytyp = keycirc then begin
                            planthop;
                            readcirc( myson );
                            { add myson to son list }
                            myson^.brother := s^.son;
                            s^.son := myson;
                        end else if lexkeytyp in [keyint, keyreal, keytime,
     {10}                                         keyassert,
                                                  keyrange, keybool] then begin
                            fixhop;
                            repeat
                                copy;
                                nextlex;
                            until (lexemetyp = eofile) or
                                  (lexkeytyp in [keyuse, keycirc, keypart,
     {10}                                        keyassert,
                                                 keyinp, keyoutp, keywire,
						 keyend]);
                        end { else (lexkeytyp in [part, inp, outp, wire, end])
                                or (lexemetyp = eofile) };
                    until (lexemetyp in [dot, eofile])
                       or (lexkeytyp in [keypart, keyinp, keyoutp,
					 keywire, keyend ]);
                end { copydefs };

            begin { readcirc };
                { first, create a record of the circuit }
                new(s);
                with s^ do begin
                    son := nil { default, changes when sons are found };
                    brother := nil { the caller may tack sons on here };
                    parsed := false { default needed by secondpass };
                    instcount := 0 { number of instances is initially zero };
                end { with };

                { start parsing by looking for the keyword circuit }
                if lexkeytyp <> keycirc then begin { hunt for keyword }
                    error( errcirexp );
                    repeat nextlex until (lexkeytyp = keycirc)
                                      or (lexemetyp = eofile);
                end;
                if lexkeytyp = keycirc then nextlex;
                lasthop := 0;
                textlno := 0;
                textfile := niltabindex;

                if lexemetyp <> id then begin
                    error( erridexp );
                end else begin { read circuit name and record position }
                    s^.headpos := textpos;
                    s^.slot := lexslot;
                    nextlex { skip circuit name };
                end;

                { put formal param list in pactext (if any) }
                if lexemetyp = bpar then begin
                    repeat
                        copy;
                        nextlex;
                    until (lexemetyp in [epar,eofile]) or
                          (lexkeytyp in
      {10}                   [keyuse,keyinp,keyoutp,keypart,keywire,keyend]);
                    if lexemetyp = epar then begin
                        copy;
                        nextlex;
                    end else begin
                        error( erreparexp );
                    end;
                end;

                { put local definitions in pactext and subcirc's in symtab }
                copydefs;

                { put body of circuit in pactext }
                fixhop;
                while (lexemetyp <> eofile)and(lexkeytyp <> keyend) do begin
                    copy;
                    nextlex;
                end;

                if lexemetyp = eofile then begin
                    error( errunexpeof );
                end else { assert lexkeytyp = keyend } begin
                    copy;
                    nextlex;
                end;
            end { readcirc };

        begin { firstpass }
            initializations;

            write( 'Source file name: ');
            readline(input, srcline, srclen);

            { put file name in symbol table, then open it }
            srcpos := 1;
            srcchar := srcline[srcpos];
            getfname(srcfile);
            openlex(srcfile);

            if lexslot = symtally then begin
                tally := true;
                nextlex;
            end;

            readcirc( subhead );
            if lexemetyp = dot then nextlex;
            if lexemetyp <> eofile then error( erreofexp );
            if waserror then fatalerror { halt };

            if tally or (strpos > (0.85 * strpoollim))
              then writeln( 'String pool occupies ', strpos:1,
                            ' bytes out of ', strpoollim:1, ' available.');
            if tally or (textpos > (0.85 * pactextlim))
              then writeln( 'Packed text occupies ', textpos:1,
                            ' bytes out of ', pactextlim:1, ' available.');
            if tally or (symcount > (0.85 * tabsize))
              then writeln( 'Symbol table holds ', symcount:1,
                            ' entries out of ', tabsize:1, ' available.');

            { replace [] in begin and end lines to get debug dump of pactext }
            { begin debug ]
            for srclno := 0 to textpos do begin
                if (srclno mod 16) = 0
                  then begin writeln; write( srclno:8, ': ' ) end;
                if pactext[srclno] < ' '
                  then write( '^', chr(ord(pactext[srclno])+ord('@')), '  ' )
                else if ord(pactext[srclno]) >= 127
                  then write( 'DEL ' )
                else write( ' ', pactext[srclno], '  ' );
            end;
            writeln;
            [ end debug }
        end { firstpass };
        


        procedure secondpass;

        type
            errtype = ( errredefine, errmanyparam,
                        errfewparam, errivdname, errpinname,
                        errpartname, errmodifier,
                        errreused, errnodest, errnotsource,
                        errnotdest, errnosrc, errrelop,
                        erridundef, errwrongtyp,
                        errplus, errminus, errstar, errslash, errbool,
      {10}              errassert,
                        errinteger, errposint, errnonzero, errpostime,
                        errillconn,
                        errrange, erroutofbnd,
                        errindexreq,
                        errnotarray, errbadparam );

            lexeme = record
                         key: keytyp { always notkey unless typ = res };
                         case typ: lextyp of
                               id: (slot: tabindex);
                             inum: (ival: integer);
                             rnum: (rval: real);

                             hop, res, colon, dot, plus, minus, star, slash,
                             equal, dotdot, starstar, bpar, epar, eofile,
                             less, lesseq, noteq, greateq, great, andop,
                             orop, notop, kin, junk
                                 : ();
                     end { record };

            textrec = record
                          pos: pactextindex { position in packed text };
                          lno: integer { the line number of current line };
                          fil: tabindex { file name from which line came };
                          lex: lexeme { the last lexeme };
                          err: boolean { should errors be shown };
                      end { record };

            keyset = set of keytyp;
            lexset = set of lextyp;

            dirpossible = ( indir, outdir, unkdir );
            pinrec = record { record of one pin of one device }
                         partname: symref;
                         partslot: tabindex;
                         partnum: integer;
                         pinslot: tabindex;
                         pinnum: integer;
                         pindir: dirpossible;
                         tiept: tieptref;
                         gate: gateref;
                         lno: integer
                     end;

            { data type used for parameters to a circuit instance }
            parampool = array [paramindex] of valtyp;
            { by convention, if x is of type parampool, and there are y
              actual parameters, x[y + 1].typ = noexpr, and x[0].typ = rangetyp,
              x[0].first = <source file from which actual params came>
              x[0].last = <line number from which actual params came> }

        var { lexical analysis state }
            textpos: pactextindex { position in packed text };
            lex: lexeme { current lexeme };

            { error reporting information (an extension of lexical state) }
            srclno: integer { line number of current line };
            srcfname: tabindex { name of file from which line originally came };
            showerror: boolean { should errors be reported? };
            errlno: integer { srclno of last error };

            currentlevel: integer;
            symfreelist: symref { symbol free list };
            tieptfreelist: tieptref { tie point free list };

            i: integer;
            nilparms: parampool;

            { error message format code (tightly coupled to lexical analysis) }

            procedure error( errcode: errtype );
            begin
                if showerror then begin
                    case errcode of
                        errredefine:  write( ' illegal redefinition' );
                        errmanyparam: write( ' too many (actual)parms' );
                        errfewparam:  write( ' too few (actual)parms' );
                        errivdname:   write( ' invalid gate/circuit name' );
                        errpinname:   write( ' invalid pin name' );
                        errpartname:  write( ' invalid part name' );
                        errmodifier:  write( ' unmodifiable name' );
                        errreused:    write( ' is illegally reused' );
                        errnodest:    write( ' no destination given' );
                        errnotsource: write( ' is not a source' );
                        errnotdest:   write( ' is not a destination' );
                        errnosrc:     write( ' has an open source connection' );
                        erridundef:   write( ' undeclared' );
                        errwrongtyp:  write( ' value is of wrong type' );
                        errplus:      write( ' operands of "+" incompatible' );
                        errminus:     write( ' operands of "-" incompatible' );
                        errstar:      write( ' operands of "*" incompatible' );
                        errslash:     write( ' operands of "/" incompatible' );
                        errrelop:     write( ' incomparable operands' );
                        errbool:      write( ' boolean expected' );
      {10}              errassert:    write( ' assertion failure' );
                        errinteger:   write( ' integer expected' );
                        errposint:    write( ' positive integer expected' );
                        errnonzero:   write( ' nonzero real expected' );
                        errpostime:   write( ' positive time expected' );
                        errrange:     write( ' range expected' );
                        erroutofbnd:  write( ' index out of bounds' );
                        errnotarray:  write( ' not an array name' );
                        errbadparam:  write( ' unmatched parameter types' );
                        errillconn:   write( ' unmatched bounds' );
                        errindexreq:  write( ' index required for this part' );
        
                    end { case };
                    writeln;
                end { if };
            end { error };

            procedure errorprefix( lno: integer );
            { This procedure writes the prefix for an error message }
            begin
                waserror := true;
                if showerror then begin
                    if errlno <> lno then begin
                        writeln;
                        write( 'ERROR on line ', lno:1, ' of file ' );
                        printsym( srcfname );
                        writeln;
                        errlno := lno;
                    end;
                    write( '     ---> ');
                end;
            end { errorprefix };

            procedure pinerror( var pin: pinrec; errcode: errtype );
            { print out name of current pin as part of an error msg }
            var i: integer;
            begin
                if showerror then begin
                    errorprefix( pin.lno );
                    write( 'pin "' );
                    printname( pin.partname^.name, i, 80 );
                    if pin.partnum <> undefined then
                        write( '(', pin.partnum:1, ')' );
                    if pin.pinslot <> niltabindex then begin
                        write('.');
                        printname( symtab[pin.pinslot]^.name, i, 80 );  
                        if pin.pinnum <> undefined then
                            write('(', pin.pinnum:1, ')');
                    end;
                    write( '"' );
                    error( errcode );
                end;
            end { pinerror };

            procedure gotbutwant( var got: lexeme;
                                  wantt: lextyp; wantk: keytyp );
            { This procedure invokes the error reporting routine
              to indicate that some particular kind of token is
              expected from the input; got is passed by reference
              only to avoid copying, and must not be modified }
            var templex: lexeme;

                procedure putlex( var lx:lexeme );
                { print the lexeme; lx is passed by reference
                  only to avoid copying, and must not be modified }
                begin
                    case lx.typ of
                        colon: write( '":"' );
                          dot: write( '"."' );
                         bpar: write( '"("' );
                         epar: write( '")"' );
                         plus: write( '"+"' );
                        minus: write( '"-"' );
                         star: write( '"*"' );
                        slash: write( '"/"' );
                        equal: write( '"="' );
                       dotdot: write( '".."' );
                     starstar: write( '"**"' );
                         less: write( '"<"' );
                       lesseq: write( '"<="' );
                        noteq: write( '"<>"' );
                      greateq: write( '">="' );
                        great: write( '">"' );
                        andop: write( '"&"' );
                         orop: write( '"|"' );
                        notop: write( '"\"' );
                         junk: ;
                         inum: write( 'number "', lx.ival:1, '"' );
                         rnum: write( 'number "', lx.rval:9:3, '"' );
                          hop: write( '"circuit"' { this init's a hop } );
                          res: case lx.key of
                                  keycirc: write( '"circuit"' );
                                   keyinp: write( '"inputs"'  );
                                  keyoutp: write( '"outputs"' );
                                  keypart: write( '"parts"'   );
                                  keywire: write( '"wires"'   );
                                   keyend: write( '"end"'     );
                                    keyto: write( '"to"'      );
                                   keyfor: write( '"for"'     );
                                   keymod: write( '"mod"'     );
                                    keydo: write( '"do"'      );
                                  keyendf: write( '"endfor"'  );
                                   keyint: write( '"integer"' );
                                  keyreal: write( '"real"'    );
                                  keytime: write( '"time"'    );
                                 keyrange: write( '"range"'   );
                                  keybool: write( '"boolean"' );
                                    keyif: write( '"if"'      );
                                  keythen: write( '"then"'    );
                                  keyelse: write( '"else"'    );
                                 keyendif: write( '"endif"'   );
                                   notkey: ;
                               end { res };
                           id: printsym( lx.slot );
                    end { case };
                end { putlex };

            begin { gotbutwant };
                if showerror then begin
                    errorprefix( srclno );
                    templex.typ := wantt;
                    templex.key := wantk;
                    putlex( got );
                    write( ' found; ' );
                    if wantt = id
                      then write( 'identifier' )
                    else if wantt = kin
                      then write( '"in"' )
                      else putlex( templex );
                    writeln( ' expected.' );
                end;
            end { gotbutwant };

            procedure badname( name: tabindex; errcode: errtype );
            { This procedure invokes the error reporting routine
              to indicate that the current identifier in the source
              file is illegal }
            begin
                if showerror then begin
                    errorprefix( srclno );
                    printsym( name );
                    write( ':' );
                    error( errcode );
                end;
            end { badname };

            procedure badnum( name: tabindex; num: valtyp; errcode: errtype );
            { report a bad number or other kind of value }
            var xx: integer;
            begin
                if showerror then begin
                    if name <> niltabindex
                      then badname( name, errcode )
                      else begin errorprefix( srclno ); error( errcode ) end;
                    write( '          ' );
                    write( 'the value found is: ');
                    case num.typ of
                        inttyp:   if num.ival <> undefined
                                    then write( num.ival:1 )
                                    else write( 'undefined' );
                        realtyp:  write( num.rval:9:3 );
                        timetyp:  if (num.rval < microsecond)
                                  and (num.rval > -microsecond)
                                    then write((num.rval/nanosecond):9:3,'ns')
                                  else if (num.rval < millisecond)
                                       and (num.rval > -millisecond)
                                    then write((num.rval/microsecond):9:3,'us')
                                  else if (num.rval < second)
                                       and (num.rval > -second)
                                    then write((num.rval/millisecond):9:3,'ms')
                                    else write((num.rval/second):9:3,'s');
                        rangetyp: write( num.first:1, ' .. ', num.last:1 );
                        booltyp:  write( num.bval );
                        circtyp:  begin
                                      write( '"' );
                                      printname( num.subptr^.name, xx, 80 );
                                      write( '"' );
                                  end;
                        noexpr,
                        undef:    write( 'undefined' );
                    end;
                    writeln;
                end;
            end { badnum };

            procedure badgate( g: gateref; errcode: errtype );
            var xx: integer;
            begin
                if showerror then begin
                    errorprefix( srclno );
                    write( '"' );
                    printname( g^.name, xx, 80 );
                    if g^.index <> undefined then write( '(', g^.index:1, ')' );
                    write( '":' );
                    error( errcode );
                end;
            end { badgate };

            procedure semanticerror( errcode: errtype; line: integer );
            { report that an operator has operands with incompatible types }
            begin
                if showerror then begin
                    errorprefix( line );
                    error( errcode );
                end;
            end { semanticerror };

            { Lexical analysis package }

            procedure nextlex;
            { get the next lexeme from pactext into lex }
            var i: tabindex;
                d: integer;
                ch: char;
            begin
                { first skip file and newline markers }
                ch := pactext[ textpos ];

                if ch = ' ' then begin { file name }
                    srcfname := ord(pactext[textpos + 1])
                              + ord(pactext[textpos + 2]) * textradix;
                    srclno := 0;
                    textpos := textpos + 3;
                    ch := pactext[ textpos ];
                end { if };

      {10}      if ((ch >= '0') and (ch <= '9')) or (ch = '~') then begin
                    { line number }
      {10}          if ch = '~' then begin
      {10}              d := -1;
      {10}              textpos := textpos + 1;
      {10}              ch := pactext[ textpos ];
      {10}              { assert that firstpass.copy guarantees ch is digit! }
      {10}          end else begin
                        d := 1;
      {10}          end { if };
                    repeat
                        srclno := srclno + ((ord(ch) - ord('0')) * d); 
                        d := d * 10;
                        textpos := textpos + 1;
                        ch := pactext[ textpos ];
                    until (ch < '0') or (ch > '9');
                end { if };

                lex.key := notkey { default assumption };

                { note: no error checks are needed here
                  statement because firstpass.copy guarantees that
                  pactext contains only legal sequences }

                lex.typ := chtolex[ch];

                if (lex.typ >= id) and (lex.typ <= res) then begin { more info }
                    if lex.typ = res then begin { reserved word codes }
                        lex.key := rescode[ch];
                        textpos := textpos + 1;
                    end else if lex.typ = hop then begin { hop over subcircuit }
                        textpos := ord(pactext[textpos + 1])
                                 + ord(pactext[textpos + 2]) * textradix
                                 + ord(pactext[textpos + 3]) * textradix
                                                             * textradix;
                    end else begin { lex.typ in [id, inum, rnum], get value }
                        i := ord(pactext[textpos + 1])
                           + ord(pactext[textpos + 2]) * textradix;
                        textpos := textpos + 3;
                        if lex.typ = id then begin
                            lex.slot := i
                        end else if lex.typ = inum then begin
                            lex.ival := symtab[ i ]^.ival
                        end else { lex.typ = rnum } begin
                            lex.rval := symtab[ i ]^.rval
                        end;
                    end;
                end else begin
                    textpos := textpos + 1;
                end { if };
            end { nextlex };

            procedure savelex( var t: textrec );
            { save the state of the lexical analysis system }
            begin
                t.pos := textpos;
                t.lno := srclno;
                t.fil := srcfname;
                t.lex := lex;
                t.err := showerror;
            end { savelex };

            procedure restorelex( var t: textrec );
            { restore the state of the lexical analysis system }
            begin
                textpos := t.pos;
                srclno := t.lno;
                srcfname := t.fil;
                lex := t.lex;
                showerror := t.err;
                errlno := -1 { if errors are printed, force new line header };
            end { restorelex };

            procedure openlex( err: boolean; pos: pactextindex );
            { start lexical analysis from copy in pactext }
            begin
                showerror := not err;
                textpos := pos;
                srclno := 0;
                srcfname := niltabindex;
                errlno := -1 { if errors are printed, force new line header };
                nextlex;
            end { openlex };


            { Procedures for handling free lists }

            procedure putsymbol( s: symref );
            { put a new symbol in the free list }
            begin
                s^.stkptr := symfreelist;
                symfreelist := s;
            end { putsymbol };

            procedure getsymbol( var s: symref );
            { get a symbol from the free list }
            begin
                if symfreelist = nil then begin
                    new( s );
                end else begin
                    s := symfreelist;
                    symfreelist := s^.stkptr;
                end;
            end { getsymbol };

            procedure puttiept( t: tieptref );
            { put a new tiepoint in the free list }
            begin
                t^.nexttiept := tieptfreelist;
                tieptfreelist := t;
            end { puttiept };

            procedure gettiept( var t: tieptref );
            { get a tiepoint from the freelist }
            begin
                if tieptfreelist = nil then begin
                    new( t );
                end else begin
                    t := tieptfreelist;
                    tieptfreelist := t^.nexttiept;
                end;
            end { gettiept };

            procedure dumpfreelists;
            var s: symref;
                t: tieptref;
            begin
                while symfreelist <> nil do begin
                    s := symfreelist;
                    symfreelist := s^.stkptr;
                    dispose( s );
                end;
                while tieptfreelist <> nil do begin
                    t := tieptfreelist;
                    tieptfreelist := t^.nexttiept;
                    dispose( t );
                end;
            end { dumpfreelists };


            { procedures for disposing of other data structures }

            procedure dumpsymtable;
            { dumps the main symbol table }
            var i: tabindex { index of entry being dumped };
                len: integer { length of name in printed report };
                num: integer { number of names on current line };
            begin
                if tally then begin
                    writeln;
                    writeln( 'Tally of parts used to build circuit:' );
                end;
                num := 0;
                for i := 0 to tabsize do begin
                    if symtab[i] <> nil then begin
                        with symtab[i]^ do begin
                            if tally
                            then if typ = id
                            then if use = typeuse
                            then if typecount > 0 then begin
                                if num >= 5 then begin
                                    writeln;
                                    num := 0;
                                end;
                                write( typecount:5, ' ' );
                                printname( name, len, 9 );
                                write( ' ':(9 - len) );
                                num := num + 1;
                            end;
                            putsymbol( symtab[i] );
                        end { with };
                        symtab[i] := nil;
                    end { if };
                end { for };
                if tally then writeln;
            end { dumpsymtable };

            procedure dumpsubtable;

                procedure dumpsub( s: subref; level: integer );
                { dumps the subcircuit symble table }
                var son, brother: subref;
                    len: integer { length of name printed on line, also temp };
                    num: integer { number of spaces used on this line };
                begin
                    num := 6;
                    while s <> nil do begin
                        son := s^.son;
                        brother := s^.brother;
                        if tally then if level > 0 then begin
                            if num >= 5 then begin
                                writeln;
                                for len := 1 to level - 1 do write( ' ':5 );
                                num := (level + 1) div 3;
                            end;
                            write( s^.instcount:5, ' ' );
                            printname( symtab[s^.slot]^.name, len, 9 );
                            if len < 9 then write( ' ':(9 - len) );
                            num := num + 1;
                        end;
                        dispose( s );
                        if son <> nil then begin
                            if level < 9
                              then dumpsub(son, level + 1)
                              else dumpsub(son, level);
                            if brother <> nil then num := 6;
                        end;
                        s := brother;
                    end;
                end { dumpsub };

            begin { dumpsubtable }
                if tally then begin
                    writeln;
                    write( 'Tally of subcircuits:' );
                end;
                dumpsub( subhead, 0 );
                if tally then writeln;
            end { dumpsubtable };


            { main procedure to connect wires between gates in model }

            procedure hookwire( var src, dest: pinrec; newdelay: real );
            { stretch wire from srcpin to destpin }
            var wire, lastwire: wireref;
                gate: gateref { source gate, if known };
            begin { hookwire }
                if (dest.partname <> nil) and (src.partname <> nil) then begin

                    { have a legal wire,
                      must first get destination wirelist if there is one }

                    if dest.tiept = nil then begin
                        { assert dest.partname^.use = gateuse }

                        { make a wire list entry for destination gate }
                        new( wire );
                        wire^.delay := 0.0 { delay will be added later };
                        wire^.g := dest.gate;
                        wire^.inputval := dest.pinnum;
                        wire^.next := nil;
                        with wire^.g^ do case kind of
                            andg, nandg, org, norg, xorg, equg, trbg:
                                begin
                                    instates[open] := instates[open] - 1;
                                    instates[low] := instates[low] + 1;
                                    if instates[low] > fanin
                                      then pinerror( dest, errreused );
                                end;
                            trig, ntrig, latchg:
                                begin
                                    if wire^.inputval = 0 then begin
                                        if control = open
                                          then control := low
                                          else pinerror( dest, errreused );
                                    end else begin { wire^.inputval = 1 }
                                        if inp = open
                                          then inp := low
                                          else pinerror( dest, errreused );
                                    end;
                                end;
                            iogate:
                                begin
                                    if state = open
                                      then state := low
                                      else pinerror( dest, errreused );
                                end;
                        end { with case };

                    end else begin

                        { destination is a tiepoint }

                        wire := dest.tiept^.destlist;
                        if (dest.tiept^.srcgate <> nil)
                        or (dest.tiept^.srctiept <> nil) then begin
                            { this tiepoint has already been used }
                            pinerror( dest, errreused );
                        end else begin
                            dest.tiept^.destlist := nil;
                            { values of .srcgate or .srctiept will be changed
                              when the best ultimate source is known }
                        end;

                    end;

                    { assert wire is head of list of destinations which
                      need their delays updated; these can then be put
                      on the wirelist closest to the ultimate source gate;
                      if the destination is a tiepoint, it must be updated
                      to hold a pointer to this approximation }

                    if src.tiept <> nil then begin { source is a tiepoint }
                        while src.tiept^.srctiept <> nil do begin
                            newdelay := newdelay + src.tiept^.delay;
                            src.tiept := src.tiept^.srctiept;
                        end;

                        { src.tiept now points to the tiepoint closest to
                          the ultimate source, and newdelay is the composite
                          delay from that source }
                        gate := src.tiept^.srcgate;
                        if gate <> nil
                          then newdelay := newdelay + src.tiept^.delay
                    end else begin { source is a gate }
                        gate := src.gate;
                    end;

                    { newdelay is now best known composite delay from ultimate
                      source; gate points to the source gate, if known; if not,
                      src.tiept points to the source tiepoint }

                    { update wirelist by composite delay }
                    if wire <> nil then begin 
                        lastwire := wire;
                        with lastwire^ do delay := delay + newdelay;
                        while lastwire^.next <> nil do begin
                            lastwire := lastwire^.next;
                            with lastwire^ do delay := delay + newdelay;
                        end;
                    end;
                    { if wire <> nil, lastwire is pointer to end of list }

                    { make connection to source }
                    if gate = nil then begin { source is tiepoint }
                        if wire <> nil then begin { connect the wires }
                            lastwire^.next := src.tiept^.destlist;
                            src.tiept^.destlist := wire;
                        end;

                        if dest.tiept <> nil then begin
                            { put back pointer in destination tiepoint }
                            dest.tiept^.srctiept := src.tiept;
                            dest.tiept^.delay := newdelay;
                        end;
                    end else begin { source is gate }
                        if wire <> nil then begin { connect the wires }
                            lastwire^.next := gate^.outto;
                            gate^.outto := wire;
                        end;

                        if dest.tiept <> nil then begin
                            { put back pointer in destination tiepoint }
                            dest.tiept^.srcgate := gate;
                            dest.tiept^.delay := newdelay;
                        end;
                    end;

                end;
            end { hookwire };

            procedure hookarrayofwires( var srcpin, destpin: pinrec;
                                        timedelay: real; first, last: integer );
            { hook up two arrays of pins with bounds 'first .. last' }
            var i: integer;

            begin
                { assert srcpin.tiept, destpin.tiept <> nil }

                { find head of source array }
                while srcpin.tiept^.index <> first do
                    srcpin.tiept := srcpin.tiept^.nextelem;
                { find head of destination array }
                while destpin.tiept^.index <> first do
                    destpin.tiept := destpin.tiept^.nextelem;

                for i := first to last do begin { hook them up! }
                    hookwire( srcpin, destpin, timedelay );
                    srcpin.tiept := srcpin.tiept^.nextelem;
                    destpin.tiept := destpin.tiept^.nextelem;
                end;
            end { hookarrayofwires };


            { syntax driven parser for the second pass }

            procedure parsecircuit( cursub: subref; var curinst: instdescrref;
                                    var actuals: parampool );
            { parse one circuit, an instance of cursub, with params in actuals;
              put pointer to instance in curinst; actuals are passed by ref
              only to avoid copying -- they must not be modified! }
            var
                save: textrec { saved lexical analysis state for recursion };
                symlist: tabindex { list of symbols defined in this circuit };


                { procedure for input and output tiepoint list error checks }

                procedure checktiepts( inst: instdescrref;
                                       tp: tieptref; length: integer );
                { check that all tiepoints in list tp of circuit instance inst
                  have a source connection; limit name of gate to length
                  components }
                var xx: integer;
                begin
                    if showerror then begin { don't check if messages ignored }
                        while tp <> nil do begin { check each tiept in list }
                            if (tp^.srcgate = nil)
                            then if (tp^.srctiept = nil ) then begin
                                { no source, neither a gate nor a tiepoint }
                                errorprefix( srclno );
                                write( '"' );
                                printprefix( inst, length );
                                printname( symtab[tp^.slot]^.name, xx, 80 );
                                if tp^.index <> undefined
                                  then write( '(', tp^.index:1, ')' );
                                write( '":' );
                                error( errnosrc );
                            end;
                            tp := tp^.nexttiept;
                        end { while };
                    end;
                end { checktiepts };


                { procedures for scope rule management }

                procedure redefine( slot: tabindex );
                { redefine symtab[slot] (assumed to be an indentifier) in the
                  current circuit, if possible; push previous definition,
                  if any, so it will be restored when this circuit ends;
                  only redefine previously defined identifiers from outer
                  nesting levels! }
                var olds, news: symref;
                begin { redefine }
                    olds := symtab[slot];
                    if olds^.level < currentlevel then begin { redefinable }
                        if olds^.use <> unuse then begin
                            { get new symbol record for this identifier }
                            getsymbol( news );
                            with news^ do begin
                                name := olds^.name;
                                typ := id;
                                use := unuse;
                                level := currentlevel;
                                stkptr := olds;
                            end;
                            symtab[slot] := news;
                        end else begin
                            olds^.level := currentlevel;
                            olds^.stkptr := nil;
                            news := olds;
                        end;

                        { record that this symbol was defined at current level }
                        news^.nextsym := symlist;
                        symlist := slot;
                    end else begin
                        badname( slot, errredefine );
                    end;
                end { redefine };

                procedure predefinelocals;
                { get all children of cursub and put them in symtab }
                var sub: subref {temp used for scanning};
                begin
                    sub := cursub^.son;
                    while sub <> nil do begin { march down brother list }

                        { put the subcircuit name in the symboltable }
                        redefine( sub^.slot );

                        { update the symboltable entry appropriately }
                        with symtab[sub^.slot]^ do begin
                            use := subuse;
                            s := sub;
                        end { with };

                        sub := sub^.brother;
                    end { while };
                end { predefinelocals };

                procedure undefinelocals;
                { undo definitions of local symbols }
                var sym: symref { symbol being undefined };
                    slot: tabindex { symbol table slot being undefined };
                    t, tt: tieptref { tiepoints of instance being undefined };
                    gate: gateref { gate being undefined };
                begin
                    slot := symlist;
                    while ( slot <> niltabindex ) do begin { undo local defs }
                        sym := symtab[slot];

                        { first do things specific to symbol being undefined }
                        if (sym^.use = instuse) then begin
                            { undefining a circuit instance }
                            if (sym^.inst <> nil) then begin { dump tiepoints }
                                { do input list and check that they were used }
                                t := sym^.inst^.inputlist;
                                checktiepts( sym^.inst, t, 1 );
                                while t <> nil do begin
                                    tt := t;
                                    t := t^.nexttiept;
                                    puttiept( tt );
                                end;
                                { do output list }
                                t := sym^.inst^.outputlist;
                                while t <> nil do begin
                                    tt := t;
                                    t := t^.nexttiept;
                                    puttiept( tt );
                                end;
                            end;
                        end else if (sym^.use = gateuse) then begin
                            { undefining a gate }
                            gate := sym^.g;
                            if (gate <> nil) then repeat
                                { check gate(s in this array) for open inputs }
                                case gate^.kind of
                                  andg, nandg, org, norg, xorg, equg:
                                    if gate^.instates[open] > 0
                                      then badgate( gate, errnosrc );
                                  trbg:
                                    if gate^.instates[low] = 0
                                      then badgate( gate, errnosrc );
                                  trig, ntrig, latchg:
                                    if (gate^.inp = open)
                                    or (gate^.control = open)
                                      then badgate( gate, errnosrc );
                                end { case };
                                gate := gate^.nextgate;
                            until gate = sym^.g;
                        end;

                        { then handle removal of symbol from environment }
                        if sym^.stkptr = nil then begin { no previous def }
                            sym^.level := undeflevel;
                            sym^.use := unuse;
                        end else begin { restore previous def }
                            symtab[slot] := sym^.stkptr;
                            putsymbol( sym );
                        end;
                        slot := sym^.nextsym;
                    end;
                end { undefinelocals };


                { parser service routines for error recovery }

                procedure findkeyword( k: keyset );
                { make sure that the current lexeme is a keyword in the
                  set k; if not, complain and scan for such a keyword }
                var i: keytyp;
                begin
                    { assert k <> [] }
                    if not (lex.key in k) then begin
                        i := keycirc;
                        while not (i in k) do i := succ( i );
                        gotbutwant( lex, res, i );
                        repeat nextlex until lex.key in k;
                    end;
                end { findkeyword };

                procedure findid( t:lexset );
                { verify that the current lexeme is an identifier; if
                  not, complain, and scan for some lexeme in the set t
                  which is assumed to contain identifier as one component }
                begin
                    if not (lex.typ in t) then begin
                        gotbutwant( lex, id, notkey );
                        repeat nextlex until lex.typ in t;
                    end;
                end { findid };


                { routines to parse components of a circuit }

                procedure parseexpr( var v: valtyp; enders: lexset );
                { <expr>  ::= <simpexpr> | <simpexpr> ..|<relop> <simpexpr>
                  <relop> ::= < | <= | <> | = | > | >=                    }
                var v1, v2: valtyp;
                    relop: lextyp;

                    procedure parsesimpexpr( var v: valtyp; enders: lexset );
                    { <simpexpr> ::= [ +|- ] <term> [ (+|-|or) <term> ]* }
                    var v1, v2: valtyp;
                        op: lextyp;

                        procedure parseterm( var v: valtyp; enders: lexset );
                        { <term> ::= <fact> [ (*|/|mod|and) <fact> ]* }
                        var v1, v2: valtyp;
                            op: lextyp;

                            procedure parsefact( var v:valtyp; enders:lexset );
                            { <fact> ::= <factor> [ ** <factor> ] }
                            var v1, v2: valtyp;

				function bitc(i: integer): integer;
                                { count ones in binary rep of an integer }
				var j: integer;
				begin
				    j := 0;
				    if i < 0 then begin
					i := (i - maxint) - 1;
					j := j + 1;
				    end;
				    while i > 0 do begin
					if odd(i) then j := j + 1;
					i := i div 2;
				    end;
				    bitc := j;
				end;

                                procedure parsefactor( var v: valtyp;
                                                       enders: lexset );
                                { <factor> ::=  <id> [ ( <expr> ) ] | <inum>
                                             |  <rnum> | ( <expr> )
                                             |  \ <factor>                 }
                                var v1: valtyp;
                                    functyp: tabindex;

                                begin
                                    { verify that lex is the start of a factor;
                                      if not, gripe and scan for one }
                                    if not(lex.typ in[notop,id,inum,rnum,bpar])
                                    then begin
                                        gotbutwant( lex, id, notkey );
                                        while not(lex.typ in ([id, inum, rnum,
                                                         bpar, notop]+enders))
                                          do nextlex;
                                    end;

                                    if lex.typ = id then begin
                                        if symtab[lex.slot]^.use = unuse
                                        then begin
                                            { error or predefined functions }
                                            if (lex.slot = symsize)
                                                     or (lex.slot = symfirst)
                                                     or (lex.slot = symlast)
                                            then begin
                                                v.typ := inttyp;
                                                functyp := lex.slot;
                                                nextlex;
                                                if lex.typ = bpar then begin
                                                    nextlex;
                                                    parseexpr(v1,enders+[epar]);
                                                    if (v1.typ <> rangetyp) and
                                                       (v1.typ <> undef)
                                                    then begin
                                                        v.typ := undef;
                                                        badnum( functyp,
                                                                v1, errrange );
                                                    end else if v1.typ = undef
                                                    then begin
                                                        v.typ := undef;
                                                    end else if functyp=symsize
                                                    then begin
                                                        v.ival := (v1.last -
                                                                  v1.first) + 1;
                                                        if v.ival < 0
                                                          then v.ival := 0;
                                                    end else if functyp=symfirst
                                                    then begin
                                                        v.ival := v1.first;
                                                    end else if functyp=symlast
                                                    then begin
                                                        v.ival := v1.last;
                                                    end;
                                                    if lex.typ<>epar then begin
                                                        gotbutwant( lex, epar,
                                                                    notkey );
                                                        repeat
                                                            nextlex;
                                                        until lex.typ
                                                           in enders+[epar];
                                                    end;
                                                end else begin
                                                    gotbutwant( lex, bpar,
                                                                notkey );
                                                    v.typ := undef;
                                                    repeat
                                                        nextlex;
                                                    until lex.typ
                                                       in enders+[epar];
                                                end;
                                            end else if (lex.slot = symodd)
                                                     or (lex.slot = symonebits)
                                            then begin
                                                functyp := lex.slot;
                                                nextlex;
                                                if lex.typ = bpar then begin
                                                    nextlex;
                                                    parseexpr(v1,enders+[epar]);
                                                    if (v1.typ <> inttyp) and
                                                       (v1.typ <> undef)
                                                    then begin
                                                       v.typ := undef;
                                                       badnum( symodd,
                                                               v1, errinteger );
                                                    end else if v1.typ = undef
                                                    then begin
                                                        v.typ := undef;
                                                    end else if functyp = symodd
		    			            then begin
                                                        v.typ := booltyp;
                                                        v.bval := odd(v1.ival);
						    end else begin
                                                        v.typ := inttyp;
                                                        v.ival := bitc(v1.ival);
                                                    end;
                                                    if lex.typ<>epar then begin
                                                        gotbutwant( lex, epar,
                                                                    notkey );
                                                        repeat
                                                            nextlex;
                                                        until lex.typ
                                                           in enders+[epar];
                                                    end;
                                                end else begin
                                                    gotbutwant( lex, bpar,
                                                                notkey );
                                                    v.typ := undef;
                                                    repeat
                                                        nextlex;
                                                    until lex.typ
                                                       in enders+[epar];
                                                end;
                                            end else begin
                                                v.typ := undef;
                                                badname( lex.slot, erridundef );
                                            end;
                                            nextlex;
                                        end else if symtab[lex.slot]^.use
                                                        = decluse then begin
                                            v := symtab[lex.slot]^.valu;
                                            nextlex;
                                        end else if symtab[lex.slot]^.use in
                                                 [typeuse, subuse] then begin
                                            v.typ := circtyp;
                                            v.subptr := symtab[lex.slot];
                                            nextlex;
                                        end else begin { defined but illegal }
                                            { instuse, gateuse, inuse, outuse }
                                            v.typ := undef;
                                            badname( lex.slot, errwrongtyp );
                                            nextlex;
                                        end;
                                    end else if lex.typ = inum then begin
                                        v.typ := inttyp;
                                        v.ival := lex.ival;
                                        nextlex;
                                    end else if lex.typ = rnum then begin
                                        v.typ := realtyp;
                                        v.rval := lex.rval;
                                        nextlex;
                                    end else if lex.typ = bpar then begin
                                        nextlex;
                                        parseexpr( v1, enders+[epar] );
                                        v := v1;
                                        if lex.typ = epar then nextlex
                                        else gotbutwant( lex, epar, notkey );
                                    end else if lex.typ = notop then begin
                                        nextlex;
                                        parsefactor( v1, enders );
                                        if v1.typ = booltyp then begin
                                            v.typ := booltyp;
                                            v.bval := not v1.bval;
                                        end else begin
                                            v.typ := undef;
                                            badnum( niltabindex, v, errbool );
                                        end;
                                    end else begin { syntax err already done }
                                        v.typ := undef;
                                    end;

                                    if not (lex.typ in enders) then begin
                                        gotbutwant( lex, plus, notkey );
                                        repeat
                                            nextlex;
                                        until lex.typ in (enders + [bpar]);
                                    end;
                                end { parsefactor };

                                function power( x, n: integer ): integer;
                                { compute x ** n }
                                var result: integer;
                                begin
                                    result := 1;
                                    while n > 0 do
                                        if odd(n) then begin
                                            result := x * result;
                                            n := n - 1;
                                        end else begin
                                            x := x * x;
                                            n := n div 2;
                                        end;
                                    power := result;
                                end { power };

                            begin { parsefact }
                                parsefactor( v1, enders+[starstar] );
                                if lex.typ = starstar then begin
                                    nextlex;
                                    parsefactor( v2, enders );
                                    if v1.typ <> inttyp then begin
                                        if v1.typ <> undef
                                          then badnum( niltabindex, v1,
                                                       errinteger );
                                        v1.typ := undef;
                                    end else if v2.typ <> inttyp then begin
                                        if v2.typ <> undef
                                          then badnum( niltabindex, v2,
                                                       errposint );
                                        v1.typ := undef;
                                    end else if v2.ival < 0 then begin
                                        badnum( niltabindex, v2, errposint );
                                        v1.typ := undef;
                                    end else if (v1.ival = 0)
                                                and (v2.ival = 0) then begin
                                        badnum( niltabindex, v2, errposint );
                                        v1.typ := undef;
                                    end else begin
                                        v1.ival := power( v1.ival, v2.ival )
                                    end;
                                end;
                                v := v1;
                            end { parsefact };

                        begin { parseterm }
                            parsefact( v1, enders+[star,slash,andop] );
                            op := lex.typ;
                            while (op in [star, slash, andop]) or
                                  ((lex.typ = res) and (lex.key = keymod))
                            do begin
                                nextlex;
                                parsefact( v2, enders+[star,slash,andop] );
                                if op = star then begin
                                    if (v1.typ = inttyp)
                                    and (v2.typ = inttyp) then begin
                                        v1.ival := v1.ival * v2.ival
                                    end else if (v1.typ = realtyp)
                                    and (v2.typ = inttyp) then begin
                                        v1.rval := v1.rval * v2.ival;
                                    end else if (v1.typ = inttyp)
                                    and (v2.typ = realtyp) then begin
                                        v2.rval := v1.ival * v2.rval;   
                                        v1 := v2;
                                    end else if (v1.typ = realtyp)
                                    and (v2.typ = realtyp) then begin
                                        v1.rval := v1.rval * v2.rval;
                                    end else if ((v1.typ = timetyp)
                                                and (v2.typ = realtyp))
                                    or ((v1.typ = realtyp)
                                       and (v2.typ = timetyp))
                                    then begin
                                        v1.typ := timetyp;
                                        v1.rval := v1.rval * v2.rval;
                                    end else if (v1.typ = timetyp)
                                    and (v2.typ = inttyp) then begin
                                        v1.rval := v1.rval * v2.ival;
                                    end else if (v1.typ = inttyp)
                                    and (v2.typ = timetyp) then begin
                                        v2.rval := v1.ival * v2.rval;
                                        v1 := v2;
                                    end else if (v1.typ <> undef)
                                    and (v2.typ <> undef) then begin
                                        semanticerror( errstar, srclno );
                                        v1.typ := undef;
                                    end else begin
                                        v1.typ := undef;
                                    end;
                                end else if op = slash then begin
                                    if (v1.typ = inttyp)
                                    and (v2.typ = inttyp) then begin
                                        if (v1.ival >= 0)
                                        and (v2.ival > 0) then begin
                                            v1.ival := v1.ival div v2.ival;
                                        end else begin
                                            if v1.ival < 0
                                              then badnum( niltabindex, v1,
                                                           errposint );
                                            if v2.ival <= 0
                                              then badnum( niltabindex, v2,
                                                           errposint );