(FILECREATED " 2-Mar-86 18:27:25" {PHYLUM}<STANSBURY>PARSER>WINTER86>PARSER.;58 68400
changes to: (FNS CODE.PARSER DISJOINT LLA.READ NONTERMINALP MAKEPARSER
CODE.LOOKAHEAD.ALL.TOKENS CODE.LOOKAHEAD.TOKEN CODE.LOOKAHEAD.MATCH
CODE.READ.TOKEN CODE.READ.SWITCH CODE.REDUCE.SWITCH INITIALIZE.GRAMMAR AFSMS
ROOTPRODUCTION CODE.REDUCE CODE.REDUCE.STACKS LR0FSM DETERMINISTIC
CONNECT.AFSMS RABIN.SCOTT LALRKFSM STATES CODE.STATES LLA.REDUCE
LLA.LOOKAHEAD LLA RESOLVE LLA.NEXT.STATES SMASH.FSM)
(RECORDS PARSERSPEC ALTERNATIVE FSM STATE)
(VARS PARSERCOMS)
previous date: "28-Feb-86 19:50:02" {PHYLUM}<STANSBURY>PARSER>WINTER86>PARSER.;44)
(* Copyright (c) 1983, 1984, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PARSERCOMS)
(RPAQQ PARSERCOMS ((* * Parser generation system.)
(FNS MAKEPARSER INITIALIZE.GRAMMAR)
(RECORDS PARSERSPEC FPRODUCTION ALTERNATIVE GRAMMAR)
(MACROS SELF STRICTEOF TCONC.FRONT)
(* * State machine generation. For an explanation of the parser technology, see
"Theory & Construction of LR(k) Parsers"
(Preliminary Version)
, Benjamin M. Brosgol, Center for Research in Computing Technology, Harvard University,
March 1973)
(FNS LR0FSM AFSMS ROOTPRODUCTION AFSM.ADDPROD CONNECT ADD.ARC DETERMINISTIC DETERMINISTIC1
CONNECT.AFSMS CONNECT.AFSMS1 SINGLETON CONNECTED OWNS.LINKS RABIN.SCOTT RABIN.SCOTT1
REPLACEMENT TRANSITION.SYMBOLS NEXT.STATES COMPOSITE.STATE.NAME DISCONNECT NONTERMINALP
TERMINALP)
(FNS LALRKFSM BUILD.BackLinks CONNECT.BACK STATETYPE RESOLVE PRINT.INADEQUATE
BUILD.LOOKAHEAD.SETS DISJOINT LLA LLA.LOOKAHEAD LLA.READ LLA.REDUCE BACKUP
LOOKAHEAD.SOURCE REDUCE.TARGET LOOKAHEADP)
(FNS OLD.LLA)
(RECORDS PRODUCTION FSM STATE LINK)
(FNS SMASH.FSM)
(FNS PPL PPM PPP PPS)
(FNS STATES STATES1 STATE.ORDER)
(* * Lisp code generation)
(FNS CODE.PARSER CODE.STATES)
(FNS CODE.LOOKAHEAD CODE.LOOKAHEAD.ALL.TOKENS CODE.LOOKAHEAD.TOKEN CODE.LOOKAHEAD.SWITCH
CODE.LOOKAHEAD.MATCH)
(FNS CODE.READ CODE.READ.TOKEN CODE.READ.SWITCH)
(FNS CODE.REDUCE CODE.REDUCE.STACKS CODE.REDUCE.SWITCH)
(* * Other)
(FNS PRINT.FUNCTION)))
(* * Parser generation system.)
(DEFINEQ
(MAKEPARSER
[LAMBDA (PARSERSPEC SORTED?) (* hts: "28-Feb-86 21:04")
(* * Constructs a parser according to PARSERSPEC)
(LET ((GRAMMAR (fetch GRAMMAR of PARSERSPEC))
(NAME (fetch PARSERNAME of PARSERSPEC)))
(INITIALIZE.GRAMMAR GRAMMAR)
(LET [(M (LALRKFSM (LR0FSM GRAMMAR]
(PUTD NAME (CODE.PARSER M PARSERSPEC SORTED?))
(SMASH.FSM M))
NAME])
(INITIALIZE.GRAMMAR
[LAMBDA (G) (* hts: "28-Feb-86 17:45")
(* * Builds the SymbolTable for GRAMMAR G. The SymbolTable is a hashtable which maps each symbol in the alphabet of
grammar G onto {NONTERMINAL, TERMINAL}. Also checks the grammar for syntactic correctness)
(LET ((PRODS (fetch PRODUCTIONS of G))
(TABLE (fetch (GRAMMAR SymbolTable) of G)))
(* * Note the nonterminals)
(CLRHASH TABLE)
(for P in PRODS
do (if (NOT (type? FPRODUCTION P))
then (ERROR "Improper grammar format"))
(PUTHASH (fetch LEFTHAND of P)
(QUOTE NONTERMINAL)
TABLE))
(* * Note the terminals)
[for P in PRODS do (for A in (fetch ALTERNATIVES of P)
do (if (NOT (type? ALTERNATIVE A))
then (ERROR "Improper grammar format"))
(for SYMBOL in (fetch RULE of A)
do (if (NOT (ATOM SYMBOL))
then (ERROR "Improper grammar format"))
(if (NULL (GETHASH SYMBOL TABLE))
then (PUTHASH SYMBOL (QUOTE TERMINAL)
TABLE]
(PUTHASH (QUOTE EOF)
(QUOTE TERMINAL)
TABLE)
G])
)
[DECLARE: EVAL@COMPILE
(DATATYPE PARSERSPEC (PARSERNAME (* name to be given to parser)
GRAMMAR (* specifies language to be parsed)
READFN (* called to read next token)
CLASSFN (* called to determine class of a token)
INSTANCEFN (* called to determine instance of a token)
EOFFN (* called to verify that token read may be interpreted
as EOF)
STACKINITFN (* initializes empty stacks)
PUSHFN (* push method for stacks)
POPFN (* pop method for stacks)
TOPFN (* tells what's on top of the stack)
LAQUEUEINITFN (* initializes main lookahead queue)
QUEUEINITFN (* initializes empty temp lookahead queue)
ENQUEUEFN (* enqueueing method for queues)
DEQUEUEFN (* dequeueing method for queues)
QUEUENOTEMPTYFN (* tells if queue is empty)
SAVESTATEFN (* bundles up state to be saved)
)
CLASSFN ← (QUOTE SELF)
INSTANCEFN ← (QUOTE SELF)
EOFFN ← (QUOTE STRICTEOF)
STACKINITFN ← (QUOTE NILL)
PUSHFN ← (QUOTE push)
POPFN ← (QUOTE pop)
TOPFN ← (QUOTE CAR)
LAQUEUEINITFN ← (QUOTE SELF)
QUEUEINITFN ← (QUOTE CONS)
ENQUEUEFN ← (QUOTE TCONC)
DEQUEUEFN ← (QUOTE TCONC.FRONT)
QUEUENOTEMPTYFN ← (QUOTE CDR)
SAVESTATEFN ← (QUOTE SELF))
(RECORD FPRODUCTION (LEFTHAND . ALTERNATIVES)
(* * LEFTHAND is the left-hand side of the rule; ALTERNATIVES is a list of ALTERNATIVEs, which are alternative
right-hand sides)
[TYPE? (AND (LISTP DATUM)
(LITATOM (fetch LEFTHAND of DATUM))
(LISTP (fetch ALTERNATIVES of DATUM])
(RECORD ALTERNATIVE (RULE AUGMENT)
[TYPE? (AND (LISTP DATUM)
(EQ 2 (LENGTH DATUM])
(DATATYPE GRAMMAR (StartSymbol (* the atom which is the start symbol)
PRODUCTIONS (* rules; should be a list of FPRODUCTIONs)
SymbolTable (* hasharray which tells class of symbols)
)
SymbolTable ← (HASHARRAY 33))
]
(/DECLAREDATATYPE (QUOTE PARSERSPEC)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((PARSERSPEC 0 POINTER)
(PARSERSPEC 2 POINTER)
(PARSERSPEC 4 POINTER)
(PARSERSPEC 6 POINTER)
(PARSERSPEC 8 POINTER)
(PARSERSPEC 10 POINTER)
(PARSERSPEC 12 POINTER)
(PARSERSPEC 14 POINTER)
(PARSERSPEC 16 POINTER)
(PARSERSPEC 18 POINTER)
(PARSERSPEC 20 POINTER)
(PARSERSPEC 22 POINTER)
(PARSERSPEC 24 POINTER)
(PARSERSPEC 26 POINTER)
(PARSERSPEC 28 POINTER)
(PARSERSPEC 30 POINTER)))
(QUOTE 32))
(/DECLAREDATATYPE (QUOTE GRAMMAR)
(QUOTE (POINTER POINTER POINTER))
(QUOTE ((GRAMMAR 0 POINTER)
(GRAMMAR 2 POINTER)
(GRAMMAR 4 POINTER)))
(QUOTE 6))
(DECLARE: EVAL@COMPILE
(PUTPROPS SELF MACRO ((A B)
A))
[PUTPROPS STRICTEOF MACRO ((CLASS)
(EQ CLASS (QUOTE EOF]
[PUTPROPS TCONC.FRONT MACRO (LAMBDA (PTR)
(* Removes and returns the first element of a TCONC list; returns
NIL if empty.)
(PROG1 (CAAR PTR)
(* Return the first element.)
(if (EQ (CAR PTR)
(CDR PTR))
then
(* * If there is only one element in the list, the
pointer to the tail of the list must be set to NIL.
If the list is empty, this will be a no-op.)
(RPLACA PTR NIL)
(RPLACD PTR NIL)
else
(* * Otherwise remove the first element of the list
(for n elements in list, n>=1.))
(RPLACA PTR (CDAR PTR]
)
(* * State machine generation. For an explanation of the parser technology, see
"Theory & Construction of LR(k) Parsers" (Preliminary Version) , Benjamin M. Brosgol, Center
for Research in Computing Technology, Harvard University, March 1973)
(DEFINEQ
(LR0FSM
[LAMBDA (G) (* hts: "26-Feb-86 13:47")
(* * Builds and returns the "LR(0)-FSM" of grammar G.)
(BLOCK)
(* * First build the "[A]-FSM" for each production in the grammar, and save them in the list NTSL
(whose CAR will be the start state of the root production of the grammar))
(LET ((NTSL (AFSMS G)))
(* * Connect the "[A]-FSMs" together. This is the so-called dotted-linking and -unlinking stage.)
(LET [(M (CONNECT.AFSMS NTSL (fetch (GRAMMAR SymbolTable) of G]
(* * Using the Rabin-Scott algorithm, remove nondeterminism from the FSM.)
(RABIN.SCOTT M])
(AFSMS
[LAMBDA (G) (* hts: "21-Feb-86 16:00")
(* * Constructs the "[A]-FSM" for each non terminal by linking the productions together as single strand transition
nets. Returns a list of their start states, with the start state of the root production as the first element of
that list.)
(* * Details: There is a single final state, FINAL, that all the "[A]-FSMs" share. The start states should be
accumulated in order so that the "LR(0)-FSM" and machines built from it will be more comprehensible to humans --
hence the use of TCONC. The hasharray mapping NAME.TO.START.STATE makes it faster to find the start state of the
"[A]-FSM" associated with a given nonterminal (faster than looking on the TCONC list). Finally, the "[A]-FSMs" had
better all be deterministic.)
(BLOCK)
(for P in (CONS (ROOTPRODUCTION G)
(fetch PRODUCTIONS of G))
bind START FINAL START.STATES NAME.TO.START.STATE
first (SETQ FINAL (create STATE
NAME ← (QUOTE FINAL)))
(SETQ START.STATES (CONS))
(SETQ NAME.TO.START.STATE (HASHARRAY 33))
do (SETQ START (GETHASH (fetch LEFTHAND of P)
NAME.TO.START.STATE))
(if (NOT (type? STATE START))
then (SETQ START (create STATE
NAME ← (fetch LEFTHAND of P)))
(TCONC START.STATES START)
(PUTHASH (fetch LEFTHAND of P)
START NAME.TO.START.STATE))
(for A in (fetch ALTERNATIVES of P) do (AFSM.ADDPROD
(create PRODUCTION
LHS ← (fetch LEFTHAND
of P)
RHS ← (fetch RULE
of A)
AUGMENT ←
(fetch (ALTERNATIVE
AUGMENT)
of A))
START FINAL))
finally (SETQ START.STATES (CAR START.STATES))
(* Get rid of TCONC cell)
(if (NOT (for S in START.STATES always (DETERMINISTIC S)))
then (SHOULDNT "Nondeterminism"))
(if (NEQ (QUOTE START)
(fetch NAME of (CAR START.STATES)))
then (SHOULDNT))
(RETURN START.STATES])
(ROOTPRODUCTION
[LAMBDA (G) (* hts: "28-Feb-86 17:45")
(* * Generates and returns a production rule which can serve as the root production -- it worries with the problem
of EOF as terminating the parse.)
(create FPRODUCTION
LEFTHAND ← (QUOTE START)
ALTERNATIVES ← (LIST (create ALTERNATIVE
RULE ← (LIST (fetch StartSymbol of G)
(QUOTE EOF))
AUGMENT ← NIL])
(AFSM.ADDPROD
[LAMBDA (PROD S FIN) (* hts: "21-Feb-86 15:28")
(if (NEQ (fetch NAME of S)
(fetch LHS of PROD))
then (\ILLEGAL.ARG S))
(if (NOT (type? STATE FIN))
then (\ILLEGAL.ARG FIN))
(* * Adds the given production to S, creating new states if necessary, finally linking it in to the FINAL state.
Builds new states in such a way as to ensure determinism.)
(BLOCK)
(for TOKEN in (fetch RHS of PROD) bind S2 L S3 first (SETQ S2 S)
do (SETQ L (for L2 in (fetch OUT of S2) thereis (EQ (fetch SYM of L2)
TOKEN)))
(SETQ S2 (if (type? LINK L)
then (CAR (fetch ST of L))
else (SETQ S3 (create STATE))
(CONNECT S2 S3 TOKEN)
S3))
finally (CONNECT S2 FIN PROD))
S])
(CONNECT
[LAMBDA (FROM.STATE TO.STATE TRANSITION.SYMBOL) (* hts: "24-Feb-86 17:38")
(* * Connects FROM.STATE to TO.STATE with a transition labelled TRANSITION.SYMBOL)
(BLOCK)
(replace OUT of FROM.STATE with (ADD.ARC (fetch OUT of FROM.STATE)
TO.STATE TRANSITION.SYMBOL])
(ADD.ARC
[LAMBDA (LINKS TO.STATE TRANSITION.SYMBOL) (* hts: "28-Feb-86 14:48")
(* * Augments the set of transitions LINKS by adding a transition via TRANSITION.SYMBOL to TO.STATE %.
Returns the augmented transition sets. Note: tries to keep them in order of acquisition)
(LET [(TRANSITION (for LINK in LINKS thereis (EQ (fetch SYM of LINK)
TRANSITION.SYMBOL]
(if (type? LINK TRANSITION)
then (if (FMEMB TO.STATE (fetch ST of TRANSITION))
then (fetch ST of TRANSITION)
else (push (fetch ST of TRANSITION)
TO.STATE))
LINKS
else (CONS (create LINK
SYM ← TRANSITION.SYMBOL
ST ← (LIST TO.STATE))
LINKS])
(DETERMINISTIC
[LAMBDA (S) (* hts: "21-Feb-86 16:55")
(if (type? FSM S)
then (SETQ S (fetch START of S)))
(* * Returns T if S is a deterministic FSM, NIL otherwise. For a state to have deterministic transitions to the
next state, (a) there may not be more than one arc out with the same transition symbol, and
(b) there may not be more than one state reachable by any transition symbol. (* * Details: HASHARRAY glop is to
ensure you don't get into infinite loops because of cycles in the FSM. Could have implemented this by calling
STATES, but that would CONS a lot more and require essentially two traversals instead of one.
Recursion shouldn't hurt because these FSMs are more bushy than they are deep.))
(BLOCK)
(DETERMINISTIC1 S (HASHARRAY 33])
(DETERMINISTIC1
[LAMBDA (S DONE) (* hts: "21-Feb-86 17:24")
(* * Tells whether the submachine beginning at S is deterministic. See comments in DETERMINISTIC.)
(OR (GETHASH S DONE)
(PROGN (PUTHASH S T DONE)
(for ARC in (fetch OUT of S) bind (SYMBOLS ← NIL)
always (AND (PROG1 (NOT (FMEMB (fetch SYM of ARC)
SYMBOLS))
(push SYMBOLS (fetch SYM of ARC)))
(SINGLETON (fetch ST of ARC))
(DETERMINISTIC1 (CAR (fetch ST of ARC))
DONE])
(CONNECT.AFSMS
[LAMBDA (NTSL SYMBOL.TABLE) (* hts: "27-Feb-86 15:58")
(* * Interconnects all the "[A]-FSMs" This is the dotted linking and unlinking phase. NTSL is a list of start
states of the various "[A]-FSMs", with the overall start state first. SYMBOL.TABLE maps symbols onto {TERMINAL,
NONTERMINAL}.)
(LET [(START (HASHARRAY (LENGTH NTSL]
(* * Build a hasharray which implements a fast mapping: name of the nonterminal to which an "[A]-FSM" reduces ->
the start state of that "[A]-FSM")
(for S in NTSL do (PUTHASH (fetch NAME of S)
S START))
(* * Absorb to each state all the links of any machine which reduces to a nonterminal which the state is supposed
to read)
(for S in (STATES NTSL) do (CONNECT.AFSMS1 S (LIST S)
SYMBOL.TABLE START))
(* * Check to make sure everything got connected up properly.)
(CONNECTED NTSL SYMBOL.TABLE START))
(* * Start state better be first in the list)
(if (NEQ (QUOTE START)
(fetch NAME of (CAR NTSL)))
then (SHOULDNT "Start state in wrong place"))
(* * Return the fully-connected state machine)
(create FSM
START ← (CAR NTSL)
SymbolTable ← SYMBOL.TABLE])
(CONNECT.AFSMS1
[LAMBDA (S PATH SYMBOL.TABLE START) (* hts: "26-Feb-86 14:09")
(* * For each transition out of S, if it is a transition on a nonterminal (say A) and is not immediately reentrant
(ie, the first state of the "[A]-FSM" for A -> Ax for some x), then S inherits all the out-links of the "[A]-FSM"
(for A). The inheritance is done depth-first, since the "[A]-FSM" may have a first transition on a nonterminal, and
so may need to inherit some transitions itself. When a state has been completed, it is entered in the hashtable
STATES.TO.STATES; if a state is already in this table, it can have links copied from it directly, and does not have
its inheritance checked again. Of course, if there are cyclically left-recursive rules (eg, A -> Bx, B -> Ay) then
this depth first search could result in a cycle. To avoid this, the routine remembers and checks its current search
chain. If a cycle is detected, it is returned and not dealt with. If the caller's state is not involved in the
cycle, he deals with it (see CONNECT.CYCLES); else he returns it to his caller.)
(for TRANSITION in (fetch OUT of S) bind SYMBOL AFSM
do (SETQ SYMBOL (fetch SYM of TRANSITION))
(if (AND (NONTERMINALP SYMBOL SYMBOL.TABLE)
(NOT (FMEMB SYMBOL PATH)))
then (SETQ AFSM (GETHASH SYMBOL START))
(CONNECT.AFSMS1 AFSM (CONS SYMBOL PATH)
SYMBOL.TABLE START)
(for TRANSITION2 in (fetch OUT of AFSM)
do (for S2 in (fetch ST of TRANSITION2)
do (CONNECT S S2 (fetch SYM of TRANSITION2])
(SINGLETON
[LAMBDA (LST) (* hts: "16-Feb-86 13:48")
(* * Returns T if LST is a singleton list, NIL otherwise.)
(AND (LISTP LST)
(NOT (CDR LST])
(CONNECTED
[LAMBDA (NTSL SYMBOL.TABLE START) (* hts: "26-Feb-86 13:52")
(* * Checks to see if CONNECT.AFSMS has done its work correctly. calls SHOULDNT iff it hasnt.)
(for S in (STATES NTSL) do (for L in (fetch OUT of S)
do (if (NONTERMINALP (fetch SYM of L)
SYMBOL.TABLE)
then (OR (OWNS.LINKS S
(GETHASH
(fetch SYM
of L)
START))
(SHOULDNT "Ownership fault"])
(OWNS.LINKS
[LAMBDA (S1 S2) (* hts: "21-Feb-86 17:10")
(* * Returns non-NIL iff S1s transitions are a superset of S2s.)
(BLOCK)
(for L2 in (fetch OUT of S2) always (for NEXT2 in (fetch ST of L2)
always (for L1 in (fetch OUT
of S1)
thereis
(AND (EQ (fetch SYM
of L2)
(fetch SYM
of L1))
(for NEXT1
in (fetch ST
of L1)
thereis (EQ NEXT1
NEXT2])
(RABIN.SCOTT
[LAMBDA (M) (* hts: "27-Feb-86 15:58")
(* * Rabin-Scott algorithm for making deterministic a FSM. Returns the determinized FSM.)
(RABIN.SCOTT1 (fetch START of M)
(HASHARRAY 33)
(HASHARRAY 33))
(if (NOT (DETERMINISTIC M))
then (SHOULDNT "Nondeterminism"))
M])
(RABIN.SCOTT1
[LAMBDA (S STATES DONE) (* hts: "25-Feb-86 23:19")
(* * Does the actual work of the Rabin-Scott determinizing algorithm. Tail recursively enumerates the states of the
machine (including replacement states). Recursion should be ok here because FSMs should be more bushy than deep.
Basically, if S has transitions to two or more states S1, ..., Sn on the same symbol, replaces those transitions
with a single transition to a union state (which has all the out transitions of S1 thru Sn). DONE hashtable has an
entry for each state visited, so that you can detect cycles and not go catatonic over them.
STATES hashtable maps replacement state names onto union states; this is used to avoid unnecessary duplication of
union states)
(LET ((S.NAME (fetch NAME of S)))
(if (GETHASH S.NAME DONE)
then S
else (PUTHASH S.NAME T DONE)
(for SYM in (TRANSITION.SYMBOLS S) bind NEXT REPLACEMENT
do (SETQ NEXT (NEXT.STATES S SYM))
(SETQ REPLACEMENT (REPLACEMENT NEXT STATES))
(if REPLACEMENT
then (for N inside NEXT do (DISCONNECT S N SYM))
(CONNECT S REPLACEMENT SYM)))
(for L in (fetch OUT of S)
do (OR (SINGLETON (fetch ST of L))
(SHOULDNT "Nondeterministic state"))
(RABIN.SCOTT1 (CAR (fetch ST of L))
STATES DONE))
S])
(REPLACEMENT
[LAMBDA (S STATES) (* hts: "25-Feb-86 23:18")
(* * Finds or generates the union state (if any) for the list of states S.)
(if (AND (LISTP S)
(CDR S))
then (LET* ((NAME (COMPOSITE.STATE.NAME S))
(REPLACEMENT (GETHASH NAME STATES)))
(if (NOT (type? STATE REPLACEMENT))
then (SETQ REPLACEMENT (create STATE
NAME ← NAME))
(for SYM in (TRANSITION.SYMBOLS S)
do (for NEXT inside (NEXT.STATES S SYM)
do (CONNECT REPLACEMENT NEXT SYM)))
(PUTHASH NAME REPLACEMENT STATES))
REPLACEMENT)
else NIL])
(TRANSITION.SYMBOLS
[LAMBDA (STATESET) (* hts: "25-Feb-86 23:19")
(* * Finds all the transition symbols that come from any of the states in STATESET)
(LET ((SYMS (CONS)))
[for S inside STATESET do (for L in (fetch OUT of S)
do (if (NOT (FMEMB (fetch SYM of L)
(CAR SYMS)))
then (TCONC SYMS (fetch SYM of L]
(CAR SYMS])
(NEXT.STATES
[LAMBDA (STATESET SYMBOL) (* hts: "25-Feb-86 15:04")
(LET [(NEXT (for S inside STATESET bind TRANSITION
when [type? LINK (SETQ TRANSITION (for L in (fetch OUT of S)
thereis (EQ SYMBOL
(fetch SYM
of L]
join (COPY (fetch ST of TRANSITION]
(if (SINGLETON NEXT)
then (CAR NEXT)
else NEXT])
(COMPOSITE.STATE.NAME
[LAMBDA (STATESET) (* hts: "25-Feb-86 23:15")
(* * Gives a unique name to the set of states STATESET)
(if (NLISTP STATESET)
then (fetch NAME of STATESET)
else (PACK (SORT (for S in STATESET collect (fetch NAME of S))
(FUNCTION ALPHORDER])
(DISCONNECT
[LAMBDA (A B TRANSITION.SYMBOL) (* hts: "28-Feb-86 19:43")
(* * Breaks the link between states A and B along TRANSITION.SYMBOL)
(BLOCK)
(LET [(TRANSITION (for LINK in (fetch OUT of A) thereis (EQ TRANSITION.SYMBOL
(fetch SYM
of LINK]
[if (type? LINK TRANSITION)
then (if (SINGLETON (fetch ST of TRANSITION))
then (* this is the only transition that is keeping the
link alive, so kill the link)
(replace OUT of A with (DREMOVE TRANSITION
(fetch OUT of A)))
else (* chop B out of the link)
(replace ST of TRANSITION with (DREMOVE B (fetch ST
of TRANSITION]
(QUOTE DISCONNECTED])
(NONTERMINALP
[LAMBDA (SYM SYMBOL.TABLE) (* hts: " 1-Mar-86 17:06")
(* * Returns T if SYM is a nonterminal symbol according to SYMBOL.TABLE , which was built from the current grammar)
(EQ (GETHASH SYM SYMBOL.TABLE)
(QUOTE NONTERMINAL])
(TERMINALP
[LAMBDA (SYM SYMBOL.TABLE) (* hts: "24-Feb-86 16:28")
(* * Determines if SYM is a terminal for the current grammar. NIL is a terminal for all grammars.)
(OR (EQ (GETHASH SYM SYMBOL.TABLE)
(QUOTE TERMINAL))
(NULL SYM])
)
(DEFINEQ
(LALRKFSM
[LAMBDA (FSM) (* hts: " 1-Mar-86 00:38")
(* Transforms an "LR(0)-FSM" into a "LALR(K)-FSM" by adding lookahead states to resolve inadequate states of the
"LR(0)-FSM". Also builds inverse transition links; the backlinks, in addition to helping determine the lookahead
sets, help in building the actual parser (because you have to backtrack states on reduction))
(LET ((STATES (STATES FSM))
(SYMBOL.TABLE (fetch (FSM SymbolTable) of FSM)))
(* * Build inverse transition links.)
(BUILD.BackLinks STATES)
(* * Resolve all inadequate states by adding lookahead states.)
(for S in STATES do (SELECTQ (STATETYPE S SYMBOL.TABLE)
(INADEQUATE (PRINT.INADEQUATE S SYMBOL.TABLE)
(RESOLVE S SYMBOL.TABLE))
((READ REDUCE LOOKAHEAD)
NIL)
(NIL (if (NEQ (fetch NAME of S)
(QUOTE FINAL))
then (SHOULDNT "Null state type")))
(SHOULDNT "Queer state type")))
(* * Make sure there are no remaining inadequate states.)
(if (for S in (STATES FSM) thereis (EQ (STATETYPE S SYMBOL.TABLE)
(QUOTE INADEQUATE)))
then (SHOULDNT "Inadequate states remaining")))
FSM])
(BUILD.BackLinks
[LAMBDA (STATES) (* hts: "22-Feb-86 14:25")
(* * Puts backward links on each of the state S in FSM, showing which from which states you could have arrived at S
and by what token transition.)
[for S1 in STATES do (for L in (fetch OUT of S1)
do (for S2 in (fetch ST of L)
do (CONNECT.BACK S2 S1 (fetch SYM of L]
(QUOTE BACKLINKED])
(CONNECT.BACK
[LAMBDA (FROM.STATE TO.STATE TRANSITION.SYMBOL) (* hts: "21-Feb-86 18:16")
(* * Connects FROM.STATE to TO.STATE with a backwards transition labelled TRANSITION.SYMBOL)
(BLOCK)
(replace BackLinks of FROM.STATE with (ADD.ARC (fetch BackLinks of FROM.STATE)
TO.STATE TRANSITION.SYMBOL))
(QUOTE CONNECTED-BACKWARDS])
(STATETYPE
[LAMBDA (S SYMBOL.TABLE) (* hts: "24-Feb-86 23:18" posted: "20-MAY-77 23:03")
(* * Examines a state and determines its type for the parser.)
(for L in (fetch OUT of S) bind (TYPE ← NIL) do [COND
((LOOKAHEADP L)
(SELECTQ TYPE
((NIL LOOKAHEAD)
(SETQQ TYPE
LOOKAHEAD))
(SHOULDNT)))
((type? PRODUCTION
(fetch SYM
of L))
(SELECTQ TYPE
((READ REDUCE
INADEQUATE)
(SETQQ TYPE
INADEQUATE))
(NIL (SETQQ TYPE
REDUCE))
(SHOULDNT)))
((TERMINALP (fetch SYM
of L)
SYMBOL.TABLE)
(SELECTQ TYPE
((READ NIL)
(SETQQ TYPE READ))
((REDUCE INADEQUATE)
(SETQQ TYPE
INADEQUATE))
(SHOULDNT]
finally (RETURN TYPE])
(RESOLVE
[LAMBDA (S SYMBOL.TABLE) (* hts: "28-Feb-86 22:40")
(* * Attempts to resolve inadequacy in a state. Note that if the language is not "LALR(k)" for any k, this routine
will go into an infinite loop; but it will announce its progress to the user so he can (a) stop it if it looks
runaway, and (b) know what the conflict is. LOOKAHEAD.FROM is the State from which the lookahead will be computed
%. ATTACH.TO is the State to which the new lookahead states will be attached (not equal to LOOKAHEAD.FROM for K>1). K is the
Number of symbols of lookahead %.)
(LET ((LOOKAHEAD (BUILD.LOOKAHEAD.SETS S SYMBOL.TABLE)))
(for LOOK in LOOKAHEAD bind EXTRA.STATE LINK SYMBOL DEST LLA
do (SETQ LINK (CAR LOOK))
(SETQ SYMBOL (fetch SYM of LINK))
(SETQ DEST (CAR (fetch ST of LINK)))
(SETQ LLA (CDR LOOK))
(SETQ EXTRA.STATE (create STATE))
(CONNECT EXTRA.STATE DEST SYMBOL)
(for SYMS in LLA do (CONNECT S EXTRA.STATE SYMS))
(replace BackLinks of EXTRA.STATE with S)
(DISCONNECT S DEST SYMBOL)))
(QUOTE RESOLVED])
(PRINT.INADEQUATE
[LAMBDA (S SYMBOL.TABLE) (* hts: "24-Feb-86 15:44")
(* * Prints out information about the inadequate state about to be resolved. Tells what transitions are possible
from this state, thus showing the conflict. Should the parser generator enter an infinite loop trying to resolve
this state (ie, if the language is not "LALR(k)" for any k), this will help the user find the rules in his grammar
which are responsible for the problem.)
(PRINTOUT NIL "Adding lookahead to resolve conflict in state " (fetch NAME of S)
":" T)
(for L in (fetch OUT of S) do (LET ((SYM (fetch SYM of L)))
(if (TERMINALP SYM SYMBOL.TABLE)
then (PRINTOUT NIL " Read: " SYM T)
elseif (type? PRODUCTION SYM)
then (PRINTOUT NIL " Reduce: "
(fetch LHS of SYM)
" -> ")
(for THING
in (fetch RHS of SYM)
do (PRINTOUT NIL THING " "))
(PRINTOUT NIL T])
(BUILD.LOOKAHEAD.SETS
[LAMBDA (S SYMBOL.TABLE) (* hts: "27-Feb-86 23:09")
(* * Attempts to resolve inadequacy in a state. Note that if the language is not "LALR(k)" for any k, this routine
will go into an infinite loop; but it will announce its progress to the user so he can (a) stop it if it looks
runaway, and (b) know what the conflict is. LOOKAHEAD.FROM is the State from which the lookahead will be computed
%. ATTACH.TO is the State to which the new lookahead states will be attached (not equal to LOOKAHEAD.FROM for K>1). K is the
Number of symbols of lookahead %.)
(for K from 1 bind LLAS
do
(* * Tell user how deep you're going, so he can detect runaway (in case the grammar he gave is more complex than he
expected))
(PRINTOUT NIL " " K "-level lookahead from state " (fetch NAME of S)
T)
[SETQ LLAS (for L in (fetch OUT of S)
when (NOT (NONTERMINALP (fetch SYM of L)
SYMBOL.TABLE))
collect (CONS L (LLA K (LIST S)
L SYMBOL.TABLE NIL]
(if (DISJOINT LLAS)
then (RETURN LLAS])
(DISJOINT
[LAMBDA (LLASET) (* hts: " 1-Mar-86 21:59")
(* * Tells whether the lookahead sets in LLASET are all disjoint. Note that entries on LLASET are of the form
(link . set-of-lookahead-chars))
(for L on LLASET bind L1
never (SETQ L1 (CAR L))
(for L2 in (CDR L) thereis (INTERSECTION (CDR L1)
(CDR L2])
(LLA
[LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: "28-Feb-86 23:44")
(* * Finds the level-K set of lookahead symbols generated by looking along the state path PATH
(which is backwards). This local lookahead set is used to build the next level of lookahead states to resolve an
inadequate state. ALREADY is a set of states already visited, and it is intended to prevent infinite recursion
because of cycles.)
(COND
((LEQ K 0)
(* * The lookahead set for lookahead strings of length 0 is the set containing the empty string.
This stops the recursion.)
(LIST NIL))
((LISTP (fetch SYM of LINK))
(LLA.LOOKAHEAD K PATH LINK SYMBOL.TABLE ALREADY))
((TERMINALP (fetch SYM of LINK)
SYMBOL.TABLE)
(LLA.READ K PATH LINK SYMBOL.TABLE ALREADY))
((type? PRODUCTION (fetch SYM of LINK))
(LLA.REDUCE K PATH LINK SYMBOL.TABLE ALREADY))
(T (\ILLEGAL.ARG LINK])
(LLA.LOOKAHEAD
[LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: "28-Feb-86 23:43")
(* * Lookahead transition. Skip over it.)
(LET* [(NEXT.STATE (CAR (fetch ST of LINK)))
(NEXT.LOOKAHEAD (for L in (fetch OUT of NEXT.STATE)
when (NOT (NONTERMINALP (fetch SYM of L)
SYMBOL.TABLE))
join (LLA K PATH L SYMBOL.TABLE ALREADY]
(INTERSECTION NEXT.LOOKAHEAD NEXT.LOOKAHEAD])
(LLA.READ
[LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: " 1-Mar-86 21:17")
(* * Read transition. Current lookahead symbol, obviously, is the transition symbol of the current link.
Recurse to find deeper lookahead. (Except if current symbol is EOF, in which case all deeper lookahead must be EOF
also, by definition of LLA.))
(if (EQ (QUOTE EOF)
(fetch SYM of LINK))
then (LIST (to K collect (QUOTE EOF)))
else (LET* [(NEXT.STATE (CAR (fetch ST of LINK)))
(NEXT.LOOKAHEAD (for L in (fetch OUT of NEXT.STATE)
when (NOT (NONTERMINALP (fetch SYM of L)
SYMBOL.TABLE))
join (for LOOK in (LLA (SUB1 K)
(CONS NEXT.STATE PATH)
L SYMBOL.TABLE ALREADY)
collect (CONS (fetch SYM of LINK)
(COPY LOOK]
(INTERSECTION NEXT.LOOKAHEAD NEXT.LOOKAHEAD])
(LLA.REDUCE
[LAMBDA (K PATH LINK SYMBOL.TABLE ALREADY) (* hts: "28-Feb-86 23:20")
(* * Reduce transition: Back up along symbols of right-hand side of reduction rule %. Then follow the symbol of the
left hand side to get to another state. Now we've essentially performed the reduction and got back in the FSM to
where we would have been if we had just read the nonterminal symbol (if such were possible). Lookahead symbol
search can proceed (recursively) from there.)
(LET* [(PRODUCTION (fetch SYM of LINK))
(LHS (fetch LHS of PRODUCTION))
(RHS (fetch RHS of PRODUCTION))
(BACKUP (BACKUP PATH (REVERSE RHS)))
(SHORTENED.PATH (FNTH PATH (PLUS 2 (LENGTH RHS]
(LET [(LOOK (for S in BACKUP
join (LET ((TARGET (REDUCE.TARGET S LHS)))
(if (FMEMB TARGET ALREADY)
then NIL
else (for L in (fetch OUT of TARGET)
when (NOT (NONTERMINALP (fetch SYM
of L)
SYMBOL.TABLE))
join (LLA K (CONS TARGET (CONS S
SHORTENED.PATH))
L SYMBOL.TABLE (CONS TARGET ALREADY]
(INTERSECTION LOOK LOOK])
(BACKUP
[LAMBDA (STATE.PATH SYMBOL.PATH) (* hts: "21-Feb-86 18:08" posted: "23-JUN-77 13:45")
(* * Designates the set of states along PATH from which you could have reached (CAR PATH) by reading the symbols in
SYMBOL.PATH. STATE.PATH is a (perhaps incomplete) path of states along which to back up; (CAR STATE.PATH) is the
state from which to start backing. SYMBOL.PATH is the list of symbols along which to back up
(empty in the case of rules like A -> e).)
(SETQ STATE.PATH (for S in STATE.PATH collect (LOOKAHEAD.SOURCE S)))
(while (CDR STATE.PATH)
do (if [NOT (for LNK in (fetch BackLinks of (CAR STATE.PATH))
thereis (AND (EQ (fetch SYM of LNK)
(CAR SYMBOL.PATH))
(FMEMB (CADR STATE.PATH)
(fetch ST of LNK]
then (SHOULDNT))
(SETQ STATE.PATH (CDR STATE.PATH))
(SETQ SYMBOL.PATH (CDR SYMBOL.PATH)))
(while SYMBOL.PATH bind (STATE.SET ← STATE.PATH)
do (for S in STATE.SET bind (STATES ← NIL)
do (for PREV in [fetch ST of (for L in (fetch BackLinks of S)
thereis (EQ (fetch SYM of L)
(CAR SYMBOL.PATH]
do (if (NOT (FMEMB PREV STATES))
then (SETQ STATES (NCONC1 STATES PREV)))
finally (SETQ STATE.SET STATES)))
(SETQ SYMBOL.PATH (CDR SYMBOL.PATH))
finally (RETURN STATE.SET])
(LOOKAHEAD.SOURCE
[LAMBDA (S) (* hts: "20-Feb-86 11:53")
(* * If S was generated to do lookahead, you really want to start backign up from the state that S came from.
States generated to do lookahead always have their source (the state from which they do lookahead) in their
BackLinks field; other states have lists of states in their BackLinks field.)
(if (type? STATE (fetch BackLinks of S))
then (fetch BackLinks of S)
else S])
(REDUCE.TARGET
[LAMBDA (STATE NONTERMINAL) (* hts: "24-Feb-86 18:59")
(* * Returns the state connected by a transition from STATE along the nonterminal symbol NONTERMINAL)
(CAR (fetch ST of (for LNK in (fetch OUT of STATE)
thereis (EQ NONTERMINAL (fetch SYM of LNK])
(LOOKAHEADP
[LAMBDA (L) (* hts: "24-Feb-86 15:53")
(* * Tells whether the given link is a lookahead link. Ordinary backlinks fields contain lists of links;
states generated by lookahead have just a state as their backlink: the state from which the lookahead was
generated.)
(type? STATE (fetch BackLinks of (CAR (fetch ST of L])
)
(DEFINEQ
(OLD.LLA
[LAMBDA (K PATH LINK FIRST.LOOKAHEAD.SYMBOLS SYMBOL.TABLE ALREADY)
(* hts: "24-Feb-86 19:02")
(if (NOT (AND (FIXP K)
(GREATERP K 0)))
then (\ILLEGAL.ARG K))
(if (NOT (OR (type? PRODUCTION (fetch SYM of LINK))
(TERMINALP (fetch SYM of LINK)
SYMBOL.TABLE)))
then (\ILLEGAL.ARG LINK))
(if [NOT (AND (OR (NULL FIRST.LOOKAHEAD.SYMBOLS)
(LISTP FIRST.LOOKAHEAD.SYMBOLS))
(EQ (LENGTH FIRST.LOOKAHEAD.SYMBOLS)
(SUB1 K]
then (\ILLEGAL.ARG FIRST.LOOKAHEAD.SYMBOLS)) (* hts: "21-Feb-86 13:41")
(* * Finds the level-K set of lookahead symbols generated by looking along the state path PATH
(which is backwards), given that you've already found the lookahead symbols FIRST.LOOKAHEAD.SYMBOLS
(K-1th, ..., 1st.). This local lookahead set is used to build the next level of lookahead states to resolve an
inadequate state. ALREADY is a set of states already visited, and it is intended to prevent infinite recursion
because of cycles.)
(LET [(OLD.LLA (if (NOT (type? PRODUCTION (fetch SYM of LINK)))
then
(* * Read transition: the lookahead is just what you're about to read.)
(if (EQ K 1)
then
(* * Terminal case: just return a list containing the symbol in the current transition)
(LIST (fetch SYM of LINK))
else
(* * Got to recurse to find the desired level of lookahead -- constrained by the lookahead symbols already found,
FIRST.LOOKAHEAD.SYMBOLS.)
(if (EQ (fetch SYM of LINK)
(CAR FIRST.LOOKAHEAD.SYMBOLS))
then (LET [(NEXT.STATE (CAR (fetch ST
of LINK]
(for NEXT.LINK
in (fetch OUT of NEXT.STATE)
when (NOT (NONTERMINALP
(fetch SYM
of NEXT.LINK)
SYMBOL.TABLE))
join (OLD.LLA (SUB1 K)
(CONS NEXT.STATE PATH)
NEXT.LINK
(CDR
FIRST.LOOKAHEAD.SYMBOLS)
SYMBOL.TABLE ALREADY)))
else NIL))
else
(* * Reduce transition: Back up along symbols of right-hand side of reduction rule (constrained insofar as possible
by the state path PATH). Then follow the symbol of the left hand side to get to another state.
Now we've essentially performed the reduction and got back in the FSM to where we would have been if we had just
read the nonterminal symbol (if such were possible). Lookahead symbol search can proceed (recursively) from there.)
(LET* [(PRODUCTION (fetch SYM of LINK))
(LHS (fetch LHS of PRODUCTION))
(RHS (fetch RHS of PRODUCTION))
(BACKUP (BACKUP PATH (REVERSE RHS)))
(SHORTENED.PATH (FNTH PATH (PLUS 2 (LENGTH RHS]
(for S in BACKUP
join (LET* ((TARGET (REDUCE.TARGET S LHS)))
(if (FMEMB TARGET ALREADY)
then NIL
else (for L in (fetch OUT of TARGET)
when (NOT (NONTERMINALP
(fetch SYM
of L)
SYMBOL.TABLE))
join (OLD.LLA
K
(CONS TARGET
(CONS S
SHORTENED.PATH))
L FIRST.LOOKAHEAD.SYMBOLS
SYMBOL.TABLE
(CONS TARGET ALREADY]
(INTERSECTION OLD.LLA OLD.LLA])
)
[DECLARE: EVAL@COMPILE
(DATATYPE PRODUCTION (LHS (* an atom, the name of the nonterminal)
RHS (* a list of atoms, the right hand side of this rule)
AUGMENT (* name of a semantic action to be performed on
reducing to this rule)
))
(DATATYPE FSM (START (* Start state of the state machine)
SymbolTable (* a hashtable mapping symbols onto {terminal,
nonterminal})
))
(DATATYPE STATE (NAME (* name of this state; an atom)
OUT (* transitions from this state;
a list of LINKs)
BackLinks (* how you could have got to this state)
)
NAME ← (GENSYM))
(DATATYPE LINK (SYM (* thing to read or reduction rule for this
transition. Either an ATOM or a PRODUCTION)
ST (* list of states to which this transition brings you.
One element if deterministic)
))
]
(/DECLAREDATATYPE (QUOTE PRODUCTION)
(QUOTE (POINTER POINTER POINTER))
(QUOTE ((PRODUCTION 0 POINTER)
(PRODUCTION 2 POINTER)
(PRODUCTION 4 POINTER)))
(QUOTE 6))
(/DECLAREDATATYPE (QUOTE FSM)
(QUOTE (POINTER POINTER))
(QUOTE ((FSM 0 POINTER)
(FSM 2 POINTER)))
(QUOTE 4))
(/DECLAREDATATYPE (QUOTE STATE)
(QUOTE (POINTER POINTER POINTER))
(QUOTE ((STATE 0 POINTER)
(STATE 2 POINTER)
(STATE 4 POINTER)))
(QUOTE 6))
(/DECLAREDATATYPE (QUOTE LINK)
(QUOTE (POINTER POINTER))
(QUOTE ((LINK 0 POINTER)
(LINK 2 POINTER)))
(QUOTE 4))
(DEFINEQ
(SMASH.FSM
[LAMBDA (M) (* hts: "28-Feb-86 20:58")
(* * Kills circularity in the finite state machine M so that the silly refcount garbage collector can collect it.)
(for S in (STATES M) do (replace BackLinks of S with NIL))
M])
)
(DEFINEQ
(PPL
[LAMBDA (L) (* hts: "27-Feb-86 23:25")
(* * Prints where the link L leads and via what.)
(printout NIL .TAB0 10 "(")
(if (type? PRODUCTION (fetch SYM of L))
then (PPP (fetch SYM of L))
else (printout NIL (fetch SYM of L)))
(printout NIL ";")
(for I in (fetch ST of L) do (printout NIL , (fetch NAME of I)))
(printout NIL ")" T)
L])
(PPM
[LAMBDA (M) (* hts: "26-Feb-86 14:31")
(* * Prints out a representation of the finite state machine M)
(for S in (SORT (STATES M)
(FUNCTION STATE.ORDER))
do (PPS S))
(TERPRI)
M])
(PPP
[LAMBDA (P) (* hts: "25-Feb-86 00:14")
(* * Prints out a representation of a production rule)
(printout NIL (fetch LHS of P)
" ->")
(for TOKEN in (fetch RHS of P) do (PRINTOUT NIL " " TOKEN))
P])
(PPS
[LAMBDA (S) (* hts: "18-Feb-86 23:31")
(* * Prints crucial info about state S: transitions from it, whether it is a lookahead state, etc.)
(printout NIL (fetch NAME of S))
(if (for L in (fetch OUT of S) thereis (LOOKAHEADP L))
then (printout NIL .TAB 10 "Lookahead" T)
else (printout NIL T))
(if (fetch OUT of S)
then (printout NIL " Out: ")
(for L in (fetch OUT of S) do (PPL L)))
S])
)
(DEFINEQ
(STATES
[LAMBDA (S) (* hts: "24-Feb-86 22:32")
(* * Forms a list of the states of an FSM. Uses a hashtable (DONE) to determine whether a state has been visited.
If not, it gets appended to the list of states. Recursion shouldn't hurt because these FSMs are more bushy than
they are deep.)
(BLOCK)
(LET ((DONE (HASHARRAY 33))
(STATES (CONS)))
(COND
((type? FSM S)
(STATES1 (fetch START of S)
STATES DONE))
((LISTP S)
(for S1 in S join (STATES1 S1 STATES DONE)))
(T (STATES1 S STATES DONE)))
(CAR STATES])
(STATES1
[LAMBDA (S STATES DONE) (* hts: "24-Feb-86 22:33")
(* * Collects substates of state S. See comments in STATES.)
[if (NOT (GETHASH S DONE))
then (TCONC STATES S)
(PUTHASH S T DONE)
(for ARC in (fetch OUT of S) do (for S2 in (fetch ST of ARC)
do (STATES1 S2 STATES DONE]
NIL])
(STATE.ORDER
[LAMBDA (S1 S2) (* hts: "26-Feb-86 14:30")
(* * Returns T if S1's name should come before S2's; NIL otherwise)
(LET ((S1-NAME (fetch NAME of S1))
(S2-NAME (fetch NAME of S2)))
(COND
((EQ S1-NAME (QUOTE START))
T)
((EQ S2-NAME (QUOTE START))
NIL)
((EQ S1-NAME (QUOTE FINAL))
NIL)
((EQ S2-NAME (QUOTE FINAL))
T)
(T (ALPHORDER S1-NAME S2-NAME])
)
(* * Lisp code generation)
(DEFINEQ
(CODE.PARSER
[LAMBDA (M PARSERSPEC SORTED?) (* hts: " 2-Mar-86 18:25" posted: "20-MAY-77 23:01")
(* * Outputs a LISP program for the parser. PARSERSPEC is a parser specification, and M is the "LALR(k)-FSM"
generated from that specification. Parser program structurally is just a great big PROG, with labels for each of
the states in M and GOs to accomplish transitions from state to state. There are two stacks: USERSTACK contains the
developing parse tree, and CONTROLSTACK keeps a record of the states that have been seen so far and so makes it
possible to back up to the right place after reducing.)
(LIST (QUOTE LAMBDA)
(LIST (QUOTE EXPECTED)
(QUOTE STATE))
(LIST (QUOTE *)
(QUOTE *)
(QUOTE Parser)
(fetch PARSERNAME of PARSERSPEC))
(CONS (QUOTE PROG)
(CONS (LIST (LIST (QUOTE CONTROLSTACK)
(LIST (fetch STACKINITFN of PARSERSPEC)))
(LIST (QUOTE USERSTACK)
(LIST (fetch STACKINITFN of PARSERSPEC)))
[LIST (QUOTE LOOKAHEAD)
(LIST (fetch LAQUEUEINITFN of PARSERSPEC)
(LIST (QUOTE CAR)
(QUOTE STATE]
(QUOTE TOKEN)
(QUOTE CLASS)
(QUOTE LHS)
(QUOTE RHS))
(CONS (LIST (fetch PUSHFN of PARSERSPEC)
(QUOTE CONTROLSTACK)
(KWOTE (QUOTE START)))
(CONS (LIST (QUOTE GO)
(QUOTE START))
(CODE.STATES M PARSERSPEC SORTED?])
(CODE.STATES
[LAMBDA (M SPEC SORTED?) (* hts: "28-Feb-86 21:44")
(* * Generates code for each of the states in the stack-configuration-recognizing machine M.
Sorts the states by name if SORTED? is non-NIL. (This makes the code significantly easier for humans to read.))
(for STATE in (if SORTED?
then (SORT (STATES M)
(FUNCTION STATE.ORDER))
else (STATES M))
unless (EQ (fetch NAME of STATE)
(QUOTE FINAL))
join (LET ((SYMBOL.TABLE (fetch (FSM SymbolTable) of M)))
(CONS (fetch NAME of STATE)
(SELECTQ (STATETYPE STATE SYMBOL.TABLE)
(READ (CODE.READ STATE SYMBOL.TABLE SPEC))
(REDUCE (CODE.REDUCE STATE SPEC))
(LOOKAHEAD (CODE.LOOKAHEAD STATE SYMBOL.TABLE SPEC))
(SHOULDNT])
)
(DEFINEQ
(CODE.LOOKAHEAD
[LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: "28-Feb-86 14:08")
(* * Generates the code to peek a token from the input stream and act on it appropriately.)
(LIST (LIST (QUOTE *)
(QUOTE Lookahead))
(CODE.LOOKAHEAD.ALL.TOKENS STATE SYMBOL.TABLE PARSERSPEC)
(CODE.LOOKAHEAD.SWITCH STATE SYMBOL.TABLE PARSERSPEC])
(CODE.LOOKAHEAD.ALL.TOKENS
[LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: "28-Feb-86 21:16")
(* * Generates the code to peek all the tokens necessary to do lookahead discrimination. For 1-symbol lookahead,
CLASS gets bound to the symbol; for n-symbol lookahead, n>1, CLASS gets bound to a list of symbols)
(LET* [(LOOKAHEAD (for L in (fetch OUT of STATE) when (LISTP (fetch SYM
of L))
collect (fetch SYM of L)))
(NSYMS (LENGTH (CAR LOOKAHEAD]
(if (EQ NSYMS 1)
then
(* * CLASS is just the class of the token read; stick the token on the regular lookahead queue.)
(LIST (QUOTE SETQ)
(QUOTE CLASS)
(CODE.LOOKAHEAD.TOKEN PARSERSPEC (for L in LOOKAHEAD
collect (CAR L))
(QUOTE LOOKAHEAD)))
else
(* * If peeking multiple tokens, must first stick them on a special queue and then shift them onto the normal
lookahead queue. This makes it possible for lookaheads to look at results of previous lookaheads without themselves
looping on the same symbol.)
(LIST (QUOTE PROG1)
[LIST (QUOTE SETQ)
(QUOTE CLASS)
(CONS (QUOTE LIST)
(for N from 1 to NSYMS
collect (CODE.LOOKAHEAD.TOKEN
PARSERSPEC
(for L in LOOKAHEAD
collect (CAR (FNTH L N)))
(QUOTE TEMP.LOOKAHEAD]
(LIST (QUOTE for)
(QUOTE TOKEN)
(QUOTE in)
(QUOTE CLASS)
(QUOTE do)
(LIST (fetch ENQUEUEFN of PARSERSPEC)
(QUOTE LOOKAHEAD)
(QUOTE TOKEN])
(CODE.LOOKAHEAD.TOKEN
[LAMBDA (PARSERSPEC EXPECTED QUEUE) (* hts: "28-Feb-86 21:59")
(* * Generates the code for peeking a token from the input stream. Stores the thing on the lookahead buffer ,
determines its class and returns its class.)
(LIST (QUOTE LET*)
[LIST (LIST (QUOTE EXPECTED.OWN)
(KWOTE EXPECTED))
(LIST (QUOTE TOKEN)
(LIST (QUOTE if)
(LIST (fetch QUEUENOTEMPTYFN of PARSERSPEC)
(QUOTE LOOKAHEAD))
(QUOTE then)
(LIST (fetch DEQUEUEFN of PARSERSPEC)
(QUOTE LOOKAHEAD))
(QUOTE else)
(LIST (fetch READFN of PARSERSPEC)
(QUOTE EXPECTED.OWN)
(LIST (QUOTE CDR)
(QUOTE STATE]
(LIST (fetch ENQUEUEFN of PARSERSPEC)
QUEUE
(QUOTE TOKEN))
(LIST (fetch CLASSFN of PARSERSPEC)
(QUOTE TOKEN)
(QUOTE EXPECTED.OWN])
(CODE.LOOKAHEAD.SWITCH
[LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: "28-Feb-86 17:46")
(* * Generates the code to make appropriate transitions from lookahead states. Gotta watch out: EOF transitions
must be checked last, in case of overly permissive EOF-acceptor fns.)
(CONS (QUOTE COND)
(NCONC1 [for L in [SORT (COPY (fetch OUT of STATE))
(FUNCTION (LAMBDA (L1 L2)
(GREATERP (for TOKEN
in (fetch SYM of L1)
when (NEQ TOKEN (QUOTE EOF))
sum 1)
(for TOKEN
in (fetch SYM of L2)
when (NEQ TOKEN (QUOTE EOF))
sum 1]
when (LISTP (fetch SYM of L))
collect (LIST (CODE.LOOKAHEAD.MATCH (fetch SYM of L)
PARSERSPEC)
(LIST (QUOTE GO)
(fetch NAME of (CAR (fetch ST
of L]
(LIST T (LIST (QUOTE PARSE.ERROR])
(CODE.LOOKAHEAD.MATCH
[LAMBDA (LOOKAHEAD.PATH PARSERSPEC) (* hts: "28-Feb-86 17:46")
(* * Generates code which will be true if the tokens read match those in LOOKAHEAD.PATH, and false otherwise.
Matching is a little tricky, for two reasons: (a) if lookahead is only 1 token deep, it will be stored in CLASS
bare (ie, not wrapped in a list); and (b) you don't want to read eof more than once, and you want to check it
specially so that peculiar things can be admitted as pseudo-eof tokens.)
(LET* ((PATH (for SYM in LOOKAHEAD.PATH when (NOT (EQ SYM (QUOTE EOF))) collect
SYM))
(LPLEN (LENGTH LOOKAHEAD.PATH))
(PLEN (LENGTH PATH)))
(if (EQ LPLEN PLEN)
then (* No eof)
(if (EQ PLEN 1)
then (* Single-token lookahead)
(LIST (QUOTE EQ)
(QUOTE CLASS)
(KWOTE (CAR PATH)))
else (* Multiple-token lookahead)
(LIST (QUOTE EQUAL)
(QUOTE CLASS)
(KWOTE PATH)))
else (* Check for eof last)
(if (EQ LPLEN 1)
then (* just check eof)
(LIST (fetch EOFFN of PARSERSPEC)
(QUOTE CLASS))
else (* Check other tokens first, then eof)
(LIST (QUOTE AND)
(LIST (QUOTE for)
(QUOTE READ)
(QUOTE in)
(QUOTE CLASS)
(QUOTE as)
(QUOTE NEED)
(QUOTE in)
(KWOTE PATH)
(QUOTE always)
(LIST (QUOTE EQ)
(QUOTE READ)
(QUOTE NEED)))
(LIST (fetch EOFFN of PARSERSPEC)
(LIST (QUOTE CAR)
(LIST (QUOTE FNTH)
(QUOTE CLASS)
(ADD1 PLEN])
)
(DEFINEQ
(CODE.READ
[LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: "28-Feb-86 18:08")
(* * Generates the code to read a token from the input stream and act on it appropriately. Also records the name of
this state on the control stack for later use in backup after reducing.)
(LIST (LIST (QUOTE *)
(QUOTE Read))
(CODE.READ.TOKEN PARSERSPEC (for L in (fetch OUT of STATE)
when (TERMINALP (fetch SYM of L)
SYMBOL.TABLE)
collect (fetch SYM of L)))
(CODE.READ.SWITCH STATE SYMBOL.TABLE PARSERSPEC])
(CODE.READ.TOKEN
[LAMBDA (PARSERSPEC EXPECTED) (* hts: "28-Feb-86 21:59")
(* * Generates the code for reading a token from the input stream. Reads token from lookahead buffer if anything
there, else from stream itself. Determines the class and instance of the token. Pushes the instance on the user
stack and returns the class.)
(LIST (QUOTE LET)
(LIST (LIST (QUOTE EXPECTED.OWN)
(KWOTE EXPECTED)))
[LIST (QUOTE SETQ)
(QUOTE TOKEN)
(LIST (QUOTE if)
(LIST (fetch QUEUENOTEMPTYFN of PARSERSPEC)
(QUOTE LOOKAHEAD))
(QUOTE then)
(LIST (fetch DEQUEUEFN of PARSERSPEC)
(QUOTE LOOKAHEAD))
(QUOTE else)
(LIST (fetch READFN of PARSERSPEC)
(QUOTE EXPECTED.OWN)
(LIST (QUOTE CDR)
(QUOTE STATE]
(LIST (QUOTE SETQ)
(QUOTE CLASS)
(LIST (fetch CLASSFN of PARSERSPEC)
(QUOTE TOKEN)
(QUOTE EXPECTED.OWN)))
(LIST (fetch PUSHFN of PARSERSPEC)
(QUOTE USERSTACK)
(LIST (fetch INSTANCEFN of PARSERSPEC)
(QUOTE TOKEN)
(QUOTE EXPECTED.OWN)))
(QUOTE CLASS])
(CODE.READ.SWITCH
[LAMBDA (STATE SYMBOL.TABLE PARSERSPEC) (* hts: " 1-Mar-86 01:13")
(* * Generates the code to make appropriate transitions from lookahead states. EOF transitions checked specially
(and last), because of possible permissivity in what counts as EOF. Note for read transitions, you must record your
state path on the control stack so subsequent reduces can know where to unwind to.)
(CONS (QUOTE SELECTQ)
(CONS (QUOTE CLASS)
(NCONC1 [for L in (fetch OUT of STATE)
when (AND (TERMINALP (fetch SYM of L)
SYMBOL.TABLE)
(NEQ (QUOTE EOF)
(fetch SYM of L)))
collect (LIST (fetch SYM of L)
[LIST (fetch PUSHFN of PARSERSPEC)
(QUOTE CONTROLSTACK)
(KWOTE (fetch NAME
of (CAR (fetch ST
of L]
(LIST (QUOTE GO)
(fetch NAME
of (CAR (fetch ST of L]
(LET [(EOF.TRANSITION (for L in (fetch OUT of STATE)
thereis (EQ (QUOTE EOF)
(fetch SYM of L]
(if EOF.TRANSITION
then [LET [(NEXT (fetch NAME
of (CAR (fetch ST of
EOF.TRANSITION]
(LIST (QUOTE if)
(LIST (fetch EOFFN of PARSERSPEC)
(QUOTE CLASS))
(QUOTE then)
(LIST (fetch ENQUEUEFN of PARSERSPEC)
(QUOTE LOOKAHEAD)
(QUOTE TOKEN))
(LIST (fetch PUSHFN of PARSERSPEC)
(QUOTE CONTROLSTACK)
(KWOTE NEXT))
(LIST (QUOTE GO)
NEXT)
(QUOTE else)
(LIST (QUOTE PARSE.ERROR]
else (LIST (QUOTE PARSE.ERROR])
)
(DEFINEQ
(CODE.REDUCE
[LAMBDA (STATE PARSERSPEC) (* hts: "28-Feb-86 21:38")
(* * Outputs the code for a REDUCE operation.)
(LET [(PROD (fetch SYM of (for L in (fetch OUT of STATE)
thereis (type? PRODUCTION (fetch SYM of L]
(* PROD is the production rule according to which we
will reduce.)
(if (EQ (fetch LHS of PROD)
(QUOTE START))
then
(* * if you're reducing the start state, you're done: just return the user stack)
[LIST (LIST (QUOTE *)
(QUOTE Reduce)
(QUOTE start)
(QUOTE state))
(LIST (QUOTE RPLACA)
(QUOTE STATE)
(LIST (fetch SAVESTATEFN of PARSERSPEC)
(QUOTE LOOKAHEAD)))
(LIST (fetch POPFN of PARSERSPEC)
(QUOTE USERSTACK))
(LIST (QUOTE RETURN)
(LIST (fetch POPFN of PARSERSPEC)
(QUOTE USERSTACK]
else
(* * Otherwise generate code to munge stacks and proceed to the next appropriate state.)
(LIST (LIST (QUOTE *)
(QUOTE Reduce))
(CODE.REDUCE.STACKS (fetch LHS of PROD)
(fetch RHS of PROD)
(fetch (PRODUCTION AUGMENT) of PROD)
PARSERSPEC)
(CODE.REDUCE.SWITCH STATE (fetch LHS of PROD)
(fetch RHS of PROD)
PARSERSPEC])
(CODE.REDUCE.STACKS
[LAMBDA (LHS RHS AUGMENT PARSERSPEC) (* hts: " 1-Mar-86 15:44")
(* * Generates the code to perform a reduce action for the parser. Must pop the things being reduced off the user
stack and replace them with the result of the semantic action for this rule. Then must pop states being reduced off
the control stack. They will later be replaced by the name of the state to which the LHS transition goes.)
(LET ((LEN (LENGTH RHS)))
(LIST (QUOTE PROGN)
(LIST (QUOTE SETQ)
(QUOTE LHS)
(KWOTE LHS))
(LIST (QUOTE SETQ)
(QUOTE RHS)
NIL)
(LIST (QUOTE to)
LEN
(QUOTE do)
(LIST (QUOTE push)
(QUOTE RHS)
(LIST (fetch POPFN of PARSERSPEC)
(QUOTE USERSTACK)))
(LIST (fetch POPFN of PARSERSPEC)
(QUOTE CONTROLSTACK)))
(LIST (fetch PUSHFN of PARSERSPEC)
(QUOTE USERSTACK)
(COPY AUGMENT))
(QUOTE LHS])
(CODE.REDUCE.SWITCH
[LAMBDA (S LHS RHS PARSERSPEC) (* hts: " 1-Mar-86 16:20")
(* * Generates the code to go to the next state from a reduce state. Where you go depends on where you have been
already (your left-context), which can be determined from the top of the control stack.)
(CONS (QUOTE SELECTQ)
(CONS (LIST (fetch TOPFN of PARSERSPEC)
(QUOTE CONTROLSTACK))
(NCONC1 [for FROM.STATE in (BACKUP (LIST S)
(REVERSE RHS))
collect (LET [(TARGET.NAME (fetch NAME of (REDUCE.TARGET
FROM.STATE LHS]
(LIST (fetch NAME of FROM.STATE)
(LIST (fetch PUSHFN of PARSERSPEC)
(QUOTE CONTROLSTACK)
(KWOTE TARGET.NAME))
(LIST (QUOTE GO)
TARGET.NAME]
(LIST (QUOTE SHOULDNT])
)
(* * Other)
(DEFINEQ
(PRINT.FUNCTION
[LAMBDA (FUNC FILE) (* hts: "24-Feb-86 22:44")
(* * PRETTY-PRINTS FUNCTION FUNC TO FILE (OR THE DEFAULT PRINTER IF FILE IS NIL))
(LET [(DEF (OR (LISTP (GETD FUNC))
(LISTP (GETPROP FUNC (QUOTE EXPR]
(if DEF
then (LET [(S (OPENSTREAM (OR FILE (QUOTE {LPT}))
(QUOTE OUTPUT]
(PRINTDEF (LIST FUNC DEF)
NIL T NIL NIL S)
(CLOSEF S])
)
(PUTPROPS PARSER COPYRIGHT ("Xerox Corporation" 1983 1984 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2233 4129 (MAKEPARSER 2243 . 2722) (INITIALIZE.GRAMMAR 2724 . 4127)) (8568 26532 (
LR0FSM 8578 . 9319) (AFSMS 9321 . 11769) (ROOTPRODUCTION 11771 . 12296) (AFSM.ADDPROD 12298 . 13276) (
CONNECT 13278 . 13633) (ADD.ARC 13635 . 14461) (DETERMINISTIC 14463 . 15373) (DETERMINISTIC1 15375 .
16048) (CONNECT.AFSMS 16050 . 17499) (CONNECT.AFSMS1 17501 . 19263) (SINGLETON 19265 . 19504) (
CONNECTED 19506 . 20086) (OWNS.LINKS 20088 . 20765) (RABIN.SCOTT 20767 . 21177) (RABIN.SCOTT1 21179 .
22749) (REPLACEMENT 22751 . 23490) (TRANSITION.SYMBOLS 23492 . 24014) (NEXT.STATES 24016 . 24521) (
COMPOSITE.STATE.NAME 24523 . 24925) (DISCONNECT 24927 . 25897) (NONTERMINALP 25899 . 26212) (TERMINALP
26214 . 26530)) (26533 41199 (LALRKFSM 26543 . 27987) (BUILD.BackLinks 27989 . 28502) (CONNECT.BACK
28504 . 28922) (STATETYPE 28924 . 30081) (RESOLVE 30083 . 31331) (PRINT.INADEQUATE 31333 . 32485) (
BUILD.LOOKAHEAD.SETS 32487 . 33753) (DISJOINT 33755 . 34218) (LLA 34220 . 35266) (LLA.LOOKAHEAD 35268
. 35784) (LLA.READ 35786 . 36834) (LLA.REDUCE 36836 . 38153) (BACKUP 38155 . 39802) (LOOKAHEAD.SOURCE
39804 . 40366) (REDUCE.TARGET 40368 . 40750) (LOOKAHEADP 40752 . 41197)) (41200 45043 (OLD.LLA 41210
. 45041)) (46926 47275 (SMASH.FSM 46936 . 47273)) (47276 49023 (PPL 47286 . 47799) (PPM 47801 . 48114
) (PPP 48116 . 48437) (PPS 48439 . 49021)) (49024 50741 (STATES 49034 . 49746) (STATES1 49748 . 50197)
(STATE.ORDER 50199 . 50739)) (50775 53428 (CODE.PARSER 50785 . 52476) (CODE.STATES 52478 . 53426)) (
53429 60038 (CODE.LOOKAHEAD 53439 . 53857) (CODE.LOOKAHEAD.ALL.TOKENS 53859 . 55702) (
CODE.LOOKAHEAD.TOKEN 55704 . 56766) (CODE.LOOKAHEAD.SWITCH 56768 . 57876) (CODE.LOOKAHEAD.MATCH 57878
. 60036)) (60039 64098 (CODE.READ 60049 . 60704) (CODE.READ.TOKEN 60706 . 62070) (CODE.READ.SWITCH
62072 . 64096)) (64099 67750 (CODE.REDUCE 64109 . 65717) (CODE.REDUCE.STACKS 65719 . 66794) (
CODE.REDUCE.SWITCH 66796 . 67748)) (67769 68313 (PRINT.FUNCTION 67779 . 68311)))))
STOP