;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; LL parser in Scheme. ;; ;; Written by Michael L. Scott for CSC 254, September 2004. ;; Modified and extended, September 2005, September 2006, and September 2008. ;; ;; To test this code, load it into your Scheme interpreter and type, e.g. ;; ;; (parse calc-gram '(read a read b sum := a + b write sum write sum / 2 $$)) ;; ;; Note that the input program has to be a quoted list. Elements within that ;; list should NOT be quoted. They will all be read as symbols (identifier names) ;; or numbers by the Scheme input routines. Internally, the parser converts ;; them into character strings. ;; ;; Note, also, that nothing in this file is input-language-specific, ;; other than the definition of calc-gram (which is only an example) ;; and the assumption that program symbols are all Scheme atoms. ;; For the assignment you'll need to add language-specific code to ;; convert the parse tree into an abstract syntax tree, to enforce ;; semantics rules, and to interpret program input. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; This first section of the file contains utility routines ;; that you may find helpful. I recommend you read all the ;; routines carefully. Understanding them (really, deeply ;; understanding them) will help you establish the mindset ;; you need to write the rest of the code. ;; (define sort (lambda (L) ; Use string comparison to quicksort list. (letrec ((partition (lambda (e L A B) (if (null? L) (cons A B) (let ((c (car L))) (if (stringlist s)) (char-alphanumeric? (lambda (c) (or (char-alphabetic? c) (char-numeric? c))))) (and (not (null? s)) (char-alphabetic? (car l)) (eval (append '(and) (map char-alphanumeric? l)) (interaction-environment)))))) (define tokenize (lambda (L grammar) ; Convert symbols of L to pairs of strings, in which ; the car of each pair is the parser's notion of terminal (e.g. "num") ; and the cadr of each pair is the actual input token (e.g. "12345"). ; (This works only if parentheses in the input program are balanced.) ; Note also that this code does not currently distinguish between ; integer and real-number constants. ; It also requires white space between any two adjacent symbols other ; than parentheses. (if (null? L) '() (let ((t (car L)) (r (tokenize (cdr L) grammar))) (cond ((number? t) (cons (list "num" (number->string t)) r)) ((symbol? t) (let ((s (symbol->string t))) (cons (cond ((string=? s "num") (list "id" "num")) ((terminal? s grammar) (list s s)) ((identifier? s) (list "id" s)) (else (list "??" s))) r))) ((list? t) (append '(("(" "(")) ; )) (tokenize t grammar) ; (( '((")" ")")) r)) (else (cons '("??" "??") r))))))) (define productions (lambda (grammar) ; Return list of all productions in grammar. ; Each is represented as a (lhs rhs) pair, where rhs is a list. (apply append (map (lambda (prods) (map (lambda (rhs) (list (car prods) rhs)) (cdr prods))) grammar)))) (define nonterminal? (lambda (x grammar) ; Is x a nonterminal? (not (not (member x (nonterminals grammar)))))) ; 'not not' makes return type a boolean, not a list (define gsymbol? (lambda (x grammar) ; is x a symbol in grammar? ; (note that name symbol? is taken by Scheme) (not (not (member x (gsymbols grammar)))))) ; 'not not' makes return type a boolean, not a list (define terminal? (lambda (x grammar) ; Is x a terminal in grammar? (and (member x (gsymbols grammar)) (not (member x (nonterminals grammar)))))) (define union (lambda sets ;; Note lack of parens! Parameter "sets" represents *all* arguments. (unique-sort (apply append sets)))) (define right-context (lambda (B grammar) ; Return a list of pairs. ; Each pair consists of a symbol A and a list of symbols beta ; such that for some alpha, A -> alpha B beta. (apply append (map (lambda (prod) (letrec ((helper (lambda (subtotal rhs) (let ((suffix (member B rhs))) (if suffix (helper (cons (cons (car prod) (list (cdr suffix))) subtotal) (cdr suffix)) subtotal))))) (helper '() (cadr prod)))) (productions grammar))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Here is our good friend the calculator language, ;; in the form expected by the parser generator. ;; We've also provided the sum-and-average program ;; ;; Note that all symbols in the grammar are quoted character strings. ;; Symbols in the input are Scheme atoms. ;; (define calc-gram '(("P" ("SL" "$$")) ("SL" ("S" "SL") ()) ("S" ("id" ":=" "E") ("read" "id") ("write" "E")) ("E" ("T" "TT")) ("T" ("F" "FT")) ("TT" ("ao" "T" "TT") ()) ("FT" ("mo" "F" "FT") ()) ("ao" ("+") ("-")) ("mo" ("*") ("/")) ("F" ("id") ("num") ("(" "E" ")")) )) (define sum-and-ave '(read a read b sum := a + b write sum write sum / 2 $$)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Here is the extended calculator grammar, with if and while statements. ;; To demonstrate that the language is no longer a complete toy, we've ;; provided a (rather slow) program to compute the first N prime numbers. ;; ;; Feel free to experiment with other grammars and inputs. ;; (define x-calc-gram '(("P" ("SL" "$$")) ("SL" ("S" "SL") ()) ("S" ("id" ":=" "E") ("read" "id") ("write" "E") ("if" "C" "SL" "end") ("while" "C" "SL" "end")) ("C" ("E" "rn" "E")) ("rn" ("==") ("!=") ("<") (">") ("<=") (">=")) ("E" ("T" "TT")) ("T" ("F" "FT")) ("TT" ("ao" "T" "TT") ()) ("FT" ("mo" "F" "FT") ()) ("ao" ("+") ("-")) ("mo" ("*") ("/")) ("F" ("id") ("num") ("(" "E" ")")) )) (define primes '(read n cp := 2 while n > 0 found := 0 cf1 := 2 cf1s := cf1 * cf1 while cf1s <= cp cf2 := 2 pr := cf1 * cf2 while pr <= cp if pr == cp found := 1 end cf2 := cf2 + 1 pr := cf1 * cf2 end cf1 := cf1 + 1 cf1s := cf1 * cf1 end if found == 0 write cp n := n - 1 end cp := cp + 1 end $$)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Next comes the parser generator. ;; The main entry routine is parse-table, which takes a grammar as argument ;; (in the format shown above) and returns an LL(1) parse table as a result. ;; The table looks like the grammar, except that each RHS is replaced with a ;; (predict-set RHS) pair. The computational heart of the algorithm is function ;; get-knowledge. ;; ;; Much of the following employs a "knowledge" structure. ;; It's a list of 4-tuples, one for each nonterminal, ;; in the same order those nonterminals appear in the grammar ;; (the order is important). ;; ;; The fields of the 4-tuple are: ;; car nonterminal A [not needed computationally, ;; but included for readability of output] ;; cadr Boolean: do we currently think A can -->* epsilon ;; caddr (current guess at) FIRST(A) - {epsilon} ;; cadddr (current guess at) FOLLOW(A) - {epsilon} ;; (define initial-knowledge (lambda (grammar) ; Return knowledge structure with empty FIRST and FOLLOW sets ; and false gen-epsilon estimate for all symbols. (map (lambda (A) (list A #f '() '())) (nonterminals grammar)))) (define symbol-knowledge (lambda (A knowledge) ; Return knowledge vector for A. (assoc A knowledge))) (define generates-epsilon? (lambda (w knowledge grammar) ; Can w generate epsilon based on current estimates? ; if w is a terminal, no ; if w is a nonterminal, look it up ; if w is an empty list, yes ; if w is a non-empty list, "iterate" over elements (cond ((terminal? w grammar) #f) ((list? w) (or (null? w) (and (generates-epsilon? (car w) knowledge grammar) (generates-epsilon? (cdr w) knowledge grammar)))) (else (cadr (symbol-knowledge w knowledge)))))) (define first (lambda (w knowledge grammar) ; Return FIRST(w) - {epsilon}, based on current estimates. ; if w is a terminal, return (w) ; if w is a nonterminal, look it up ; if w is an empty list, return () [empty set] ; if w is a non-empty list, "iterate" over elements (cond ((terminal? w grammar) (list w)) ((null? w) '()) ((list? w) (union (first (car w) knowledge grammar) (if (generates-epsilon? (car w) knowledge grammar) (if (null? (cdr w)) '() (first (cdr w) knowledge grammar)) '()))) (else (caddr (symbol-knowledge w knowledge)))))) (define follow (lambda (A knowledge) ; Return FOLLOW(A) - {epsilon}, based on current estimates. ; Simply look it up. (cadddr (symbol-knowledge A knowledge)))) (define get-knowledge (lambda (grammar) ; Return knowledge structure for grammar. ; Start with (initial-knowledge grammar) and "iterate", until ; the structure doesn't change. ; Uses (right-context B grammar), for all nonterminals B, ; to help compute follow sets. (let* ((nts (nonterminals grammar)) (right-contexts (map (lambda (s) (right-context s grammar)) nts))) (letrec ((helper (lambda (knowledge) (let* ((update (lambda (old-symbol-knowledge symbol-productions symbol-right-context) (let* ((my-first (lambda (s) (first s knowledge grammar))) (my-gen-ep? (lambda (s) (generates-epsilon? s knowledge grammar))) (filtered-follow (lambda (p) (if (my-gen-ep? (cadr p)) (follow (car p) knowledge) '())))) (list (car old-symbol-knowledge) ; nonterminal itself (or (cadr old-symbol-knowledge) (eval (cons 'or (map my-gen-ep? (cdr symbol-productions))) (interaction-environment))) (union (caddr old-symbol-knowledge) ; previous estimate (apply union (map my-first (cdr symbol-productions)))) (union (cadddr old-symbol-knowledge) ; previous estimate (apply union (map my-first (map cadr symbol-right-context))) (apply union (map filtered-follow symbol-right-context))))))) (new-knowledge (map update knowledge grammar right-contexts))) (if (equal? new-knowledge knowledge) ; recursive comparison knowledge (begin ; (write new-knowledge) ; for debugging ; (read) ; for debugging (helper new-knowledge))))))) (helper (initial-knowledge grammar)))))) (define parse-table (lambda (grammar) ; Return parse table for grammar. ; Uses the get-knowledge routine above. (let ((knowledge (get-knowledge grammar))) (map (lambda (prods) (let ((lhs (car prods)) (rhss (cdr prods))) (cons lhs (map (lambda (rhs) (cons (union (first rhs knowledge grammar) (if (generates-epsilon? rhs knowledge grammar) (follow lhs knowledge) '())) (list rhs))) rhss)))) grammar)))) (define lookup (lambda (nt t parse-tab) ; Double-index to find prediction (list of RHS symbols) for ; nonterminal nt and terminal t. ; Return #f if not found. (letrec ((helper (lambda (L) (cond ((null? L) #f) ((member t (caar L)) (cadar L)) (else (helper (cdr L))))))) (helper (cdr (assoc nt parse-tab)))))) (define display-list (lambda (L) ; Print list to standard output. ; Yes, this is imperative. (if (not (null? L)) (begin (display (string-append " " (car L))) (display-list (cdr L)))))) ;; ;; The main parse routine below returns a parse tree (or #f if the input program ;; is syntactically invalid). To build that tree it employs a simplified version ;; of the "attribute stack" described in Section 4.5.2 (pages 44-47) of the PLP CD. ;; ;; When it predicts A -> B C D, the parser pops A from the parse stack ;; and then, before pushing D, C, and B (in that order), it pushes a ;; number (in this case 3) indicating the length of the right hand side. ;; It also pushes A into the attribute stack. ;; ;; When it matches a token, the parser pushes this into the attribute ;; stack as well. ;; ;; Finally, when it encounters a number (say k) in the stack (as opposed ;; to a character string), the parser pops k+1 symbols from the ;; attribute stack, joins them together into a list, and pushes the list ;; back into the attribute stack. ;; ;; These rules suffice to accumulate a complete parse tree into the ;; attribute stack at the end of the parse. ;; ;; Note that everything is done functionally. We don't really modify ;; the stacks; we pass new versions to a tail recursive routine. ;; (define reduce-1-prod (lambda (astack rhs-len) ; Pop rhs-len + 1 symbols off the attribute stack, ; assemble into a production, and push back onto the stack. (letrec ((helper (lambda (astack k prod) (if (= 0 k) (cons prod astack) (helper (cdr astack) (- k 1) (cons (car astack) prod)))))) (helper astack (+ 1 rhs-len) '())))) (define parse (lambda (grammar program) ; Parse program according to grammar. ; Print predictions and matches (imperatively) along the way. ; Return parse tree if the program is in the language; #f if it's not. (letrec ((die (lambda (s) (begin (display "syntax error: ") (display s) (newline) #f))) (parse-tab (parse-table grammar)) (helper (lambda (pstack tokens astack) (if (null? pstack) (if (null? tokens) (car astack) (die "extra input beyond end of program")) (let ((tos (car pstack))) (cond ((number? tos) ;; We've reached the end of a production. Pop lhs and rhs ;; symbols off astack, join into list, and push back into astack. (helper (cdr pstack) tokens (reduce-1-prod astack tos))) ((null? tokens) (die "unexpected end of program")) (else (let ((term (caar tokens)) (tok (cadar tokens))) ;; if tok is an individual identifier or number, ;; term will be a generic "id" or "num" (if (terminal? tos grammar) (if (equal? tos term) (begin ; (display " match ") ; (display tos) ; (if (not (equal? tos tok)) ; (display (string-append " (" tok ")"))) ; (newline) (helper (cdr pstack) (cdr tokens) (cons tok astack))) ;; note push of tok into astack (die (string-append "expected " tos "; saw " tok))) ;; else nonterminal (let ((rhs (lookup tos term parse-tab))) (if rhs (begin ; (display (string-append " predict " tos " ->")) ; (display-list rhs) (newline) (helper (append rhs (list (length rhs)) (cdr pstack)) tokens (cons tos astack))) ;; note push of lhs into astack (die (string-append "no prediction for " tos " when seeing " tok))))))))))))) (helper (list (start-symbol grammar)) (tokenize program grammar) '())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define ASTize-P (lambda (P) ; root of tree ; ... )) (define ASTize-SL (lambda (SL) ; statement list (chain of statements) ; ... ; (ASTize-S first) ; (ASTize-SL rest) ; ... )) (define ASTize-S (lambda (S) ; ... (cond ((string=? first "read") ; ... ) ((string=? first "write") ; ... ) ((string=? first "if") ; ... ) ((string=? first "while") ; ... ) (else ; := ; ... ) ))) (define ASTize-expr ; called on an E, T, or F parse tree node (lambda (E) ; ... )) (define ASTize-expr-tail ; called on a TT or FT parse tree node (lambda (lhs rest) ; lhs is inherited attribute; ; ... ; rest is node and children: )) ; (TT), (FT), (TT op T TT), or (FT op F FT) (define ASTize-C (lambda (C) ; C -> E op E ; ... )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define interpret (lambda (grammar program input) (interpret-AST (ASTize-P (parse grammar program)) input))) ;; This routine is complete. ;; It illustrates how you can pull return values out of a list ;; (define interpret-AST (lambda (ast input) (let* ((result (interpret-SL ast '() input '())) (ok (car result)) (new-env (cadr result)) (output (cadddr result))) output))) (define interpret-SL ; returns ok, new-env, new-input, new-output (lambda (SL env input output) ; ... )) ;; This routine is also complete. ;; You can call it on any statement node and it figures out what more ;; specific case to invoke. ;; (define interpret-S ; returns ok, new-env, new-input, new-output (lambda (S env input output) (let ((tp (car S))) (cond ((string=? tp ":=") (interpret-assign (cadr S) (caddr S) env input output)) ((string=? tp "read") (interpret-read (cadr S) env input output)) ((string=? tp "write") (interpret-write (cadr S) env input output)) ((string=? tp "if") (interpret-if (cadr S) (caddr S) env input output)) ((string=? tp "while") (interpret-while (cadr S) (caddr S) env input output)))))) (define interpret-assign ; returns ok, new-env, input, new-output (lambda (lhs rhs env input output) ; ... )) (define interpret-read ; returns ok, new-env, new-input, new-output (lambda (id env input output) ; ... )) (define interpret-write ; returns ok, new-env, input, new-output (lambda (E env input output) ; ... )) (define interpret-if ; returns ok, new-env, new-input, new-output (lambda (C SL env input output) ; ... )) ;; Hint: the code for interpret-if and interpret-while is _very_ similar ;; (define interpret-while ; returns ok, new-env, new-input, new-output (lambda (C SL env input output) ; ... )) (define interpret-expr ; returns val/err, new-env (lambda (E env) ; ... )) ;; Utility routines follow. ;; Environment is a list of triples: (id val used?) (define lookup-env ; returns (cons val-or-error new-env) (lambda (id env) ; ... )) (define update-env ; returns new-env (lambda (id val env) ; ... ))