From 8525a6ab43aa3da75725551ae3d7fb0848d202ca Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Mon, 12 Nov 2001 23:31:48 +0000 Subject: [PATCH] *** empty log message *** original commit: 6b32165ccb7a18f2ef44c454684ea8d3df46da6b --- .../private-yacc/input-file-parser.ss | 16 +- collects/parser-tools/private-yacc/lalr.ss | 143 ++++++-- collects/parser-tools/private-yacc/lr0.ss | 14 +- collects/parser-tools/private-yacc/table.ss | 324 +++++++++--------- collects/parser-tools/yacc.ss | 4 +- 5 files changed, 293 insertions(+), 208 deletions(-) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index d211701..2615e41 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -119,7 +119,9 @@ (list-of-terms - (syntax-case term-defs (tokens) + (syntax-case* term-defs (tokens) + (lambda (a b) + (eq? (syntax-object->datum a) (syntax-object->datum b))) ((tokens term-def ...) (andmap identifier? (syntax->list (syntax (term-def ...)))) (remove-duplicates @@ -148,7 +150,9 @@ ;; Get the list of terminals out of input-terms (list-of-non-terms - (syntax-case prods (grammar) + (syntax-case* prods (grammar) + (lambda (a b) + (eq? (syntax-object->datum a) (syntax-object->datum b))) ((grammar (non-term production ...) ...) (begin (for-each @@ -179,7 +183,9 @@ ;; Check the precedence declarations for errors and turn them into data (precs - (syntax-case prec-decls (precs) + (syntax-case* prec-decls (precs) + (lambda (a b) + (eq? (syntax-object->datum a) (syntax-object->datum b))) ((precs (type term ...) ...) (let ((p-terms (apply append (syntax-object->datum @@ -286,7 +292,9 @@ ;; parse-prod+action: non-term * syntax-object -> production (parse-prod+action (lambda (nt prod-so) - (syntax-case prod-so (prec) + (syntax-case* prod-so (prec) + (lambda (a b) + (eq? (syntax-object->datum a) (syntax-object->datum b))) ((prod-rhs action) (let ((p (parse-prod (syntax prod-rhs)))) (set! counter (add1 counter)) diff --git a/collects/parser-tools/private-yacc/lalr.ss b/collects/parser-tools/private-yacc/lalr.ss index 524fd49..0f11d06 100644 --- a/collects/parser-tools/private-yacc/lalr.ss +++ b/collects/parser-tools/private-yacc/lalr.ss @@ -53,47 +53,46 @@ ;; lr0-automaton * grammar -> (value (trans-key -> trans-key list) ;; (kernel * prod -> trans-key list)) (define (compute-includes-and-lookback a g) - (let* ((states (lr0-states a)) - (non-terms (grammar-non-terms g)) - (num-states (vector-length states)) + (let* ((non-terms (grammar-non-terms g)) + (num-states (vector-length (lr0-states a))) (num-non-terms (length non-terms)) (includes (make-array2d num-states num-non-terms null)) (lookback (make-array2d num-states (grammar-num-prods g) null))) - (let loop ((state 0)) - (if (< state num-states) - (begin - (for-each - (lambda (non-term) - (for-each - (lambda (prod) - (let loop ((i (make-item prod 0)) - (p (vector-ref states state))) - (if (and p i) - (begin - (if (and (non-term? (sym-at-dot i)) - (nullable-after-dot? (move-dot-right i) - g)) - (array2d-add! includes - (kernel-index p) - (gram-sym-index - (sym-at-dot i)) - (make-trans-key - (vector-ref states state) - non-term))) - (if (not (move-dot-right i)) - (array2d-add! lookback - (kernel-index p) - (prod-index prod) - (make-trans-key - (vector-ref states state) - non-term))) - (loop (move-dot-right i) - (run-automaton p (sym-at-dot i) a)))))) - (get-nt-prods g non-term))) - non-terms) - (loop (add1 state))))) + + (for-each-state + (lambda (state) + (for-each + (lambda (non-term) + (for-each + (lambda (prod) + (let loop ((i (make-item prod 0)) + (p state)) + (if (and p i) + (begin + (if (and (non-term? (sym-at-dot i)) + (nullable-after-dot? (move-dot-right i) + g)) + (array2d-add! includes + (kernel-index p) + (gram-sym-index + (sym-at-dot i)) + (make-trans-key + state + non-term))) + (if (not (move-dot-right i)) + (array2d-add! lookback + (kernel-index p) + (prod-index prod) + (make-trans-key + state + non-term))) + (loop (move-dot-right i) + (run-automaton p (sym-at-dot i) a)))))) + (get-nt-prods g non-term))) + non-terms)) + a) (values (lambda (tk) (array2d-ref includes (kernel-index (trans-key-st tk)) @@ -118,9 +117,79 @@ (define (compute-LA a g) (let-values (((includes lookback) (compute-includes-and-lookback a g))) (let ((follow (compute-follow a g includes))) + (print-lookback lookback a g) + (print-follow follow a g) (lambda (k p) (let* ((l (lookback k p)) (f (map follow l))) (apply append f)))))) + + + (define (print-DR dr a g) + (print-input-st-sym dr "DR" a g print-output-terms)) + (define (print-Read Read a g) + (print-input-st-sym Read "Read" a g print-output-terms)) + (define (print-includes i a g) + (print-input-st-sym i "includes" a g print-output-st-nt)) + (define (print-lookback l a g) + (print-input-st-prod l "lookback" a g print-output-st-nt)) + (define (print-follow f a g) + (print-input-st-sym f "follow" a g print-output-terms)) + (define (print-LA l a g) + (print-input-st-prod l "LA" a g print-output-terms)) + + (define (print-input-st-sym f name a g print-output) + (printf "~a:~n" name) + (for-each-state + (lambda (state) + (for-each + (lambda (non-term) + (let ((res (f (make-trans-key state non-term)))) + (if (not (null? res)) + (printf "~a(~a, ~a) = ~a~n" + name + state + (gram-sym-symbol non-term) + (print-output res))))) + (grammar-non-terms g))) + a) + (newline)) + + (define (print-input-st-prod f name a g print-output) + (printf "~a:~n" name) + (for-each-state + (lambda (state) + (for-each + (lambda (non-term) + (for-each + (lambda (prod) + (let ((res (f state prod))) + (if (not (null? res)) + (printf "~a(~a, ~a) = ~a~n" + name + (kernel-index state) + (prod-index prod) + (print-output res))))) + (get-nt-prods g non-term))) + (grammar-non-terms g))) + a)) + + (define (print-output-terms r) + (map + (lambda (p) + (gram-sym-symbol p)) + r)) -) \ No newline at end of file + (define (print-output-st-nt r) + (map + (lambda (p) + (list + (kernel-index (trans-key-st p)) + (gram-sym-symbol (trans-key-gs p)))) + r)) + + +) + + + diff --git a/collects/parser-tools/private-yacc/lr0.ss b/collects/parser-tools/private-yacc/lr0.ss index 461a70f..634ddca 100644 --- a/collects/parser-tools/private-yacc/lr0.ss +++ b/collects/parser-tools/private-yacc/lr0.ss @@ -8,7 +8,7 @@ (lib "list.ss")) (provide union build-lr0-automaton run-automaton (struct trans-key (st gs)) - lr0-transitions lr0-states kernel-items kernel-index) + lr0-transitions lr0-states kernel-items kernel-index for-each-state) (define (union comp (eq? a b) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index a1dba32..5eaf57e 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -39,11 +39,9 @@ ;; action array2d * term vector * non-term vector * kernel vector * ;; output-port -> ;; Prints out the parser given by table. - (define (display-parser table terms non-terms states prods port) + (define (display-parser a table terms non-terms prods port) (let* ((num-terms (vector-length terms)) (num-non-terms (vector-length non-terms)) - (num-gram-syms (+ num-terms num-non-terms)) - (num-states (vector-length states)) (SR-conflicts 0) (RR-conflicts 0)) (for-each @@ -54,62 +52,62 @@ (gram-sym-symbol (prod-lhs prod)) (map gram-sym-symbol (vector->list (prod-rhs prod))))) prods) - (let loop ((i 0)) - (if (< i num-states) - (begin - (fprintf port "State ~a~n" i) - (for-each (lambda (item) - (fprintf port "\t~a~n" (item->string item))) - (kernel-items (vector-ref states i))) - (newline port) - (let loop ((j 0)) - (if (< j num-terms) - (begin - (let ((act (array2d-ref - table - i - (+ j num-non-terms)))) - (cond - ((list? act) - (fprintf port "begin conflict:~n") - (if (> (count reduce? act) 1) - (set! RR-conflicts (add1 RR-conflicts))) - (if (> (count shift? act) 0) - (set! SR-conflicts (add1 SR-conflicts))) - (map (lambda (x) - (print-entry - (gram-sym-symbol (vector-ref terms j)) - x - port)) - act) - (fprintf port "end conflict~n")) - (act (print-entry - (gram-sym-symbol (vector-ref terms j)) - act - port)))) - (loop (add1 j))))) - - (newline port) - - (let loop ((j 0)) - (if (< j num-non-terms) - (begin - (let ((s (array2d-ref table i j))) - (if s - (print-entry - (gram-sym-symbol (vector-ref non-terms j)) - s - port))) - (loop (add1 j))))) + (for-each-state + (lambda (state) + (fprintf port "State ~a~n" (kernel-index state)) + (for-each (lambda (item) + (fprintf port "\t~a~n" (item->string item))) + (kernel-items state)) + (newline port) + (let loop ((j 0)) + (if (< j num-terms) + (begin + (let ((act (array2d-ref + table + (kernel-index state) + (+ j num-non-terms)))) + (cond + ((list? act) + (fprintf port "begin conflict:~n") + (if (> (count reduce? act) 1) + (set! RR-conflicts (add1 RR-conflicts))) + (if (> (count shift? act) 0) + (set! SR-conflicts (add1 SR-conflicts))) + (map (lambda (x) + (print-entry + (gram-sym-symbol (vector-ref terms j)) + x + port)) + act) + (fprintf port "end conflict~n")) + (act (print-entry + (gram-sym-symbol (vector-ref terms j)) + act + port)))) + (loop (add1 j))))) + + (newline port) + + (let loop ((j 0)) + (if (< j num-non-terms) + (begin + (let ((s (array2d-ref table (kernel-index state) j))) + (if s + (print-entry + (gram-sym-symbol (vector-ref non-terms j)) + s + port))) + (loop (add1 j))))) + + (newline port)) + a) - (newline port) - (loop (add1 i))))) (if (> SR-conflicts 0) (fprintf port "~a shift/reduce conflicts~n" SR-conflicts)) (if (> RR-conflicts 0) (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts)))) - (define (resolve-conflicts table num-states num-terms num-non-terms) + (define (resolve-conflicts a table num-terms num-non-terms) (letrec ((SR-conflicts 0) (RR-conflicts 0) (get-action @@ -130,19 +128,19 @@ (loop (car rest) (cdr rest))) (else (loop current-guess (cdr rest)))))) (else entry))))) - (let loop ((state 0)) - (if (< state num-states) - (begin - (let loop ((term 0)) - (if (< term num-terms) - (begin - (array2d-set! table state (+ num-non-terms term) - (get-action - (array2d-ref table - state - (+ num-non-terms term)))) - (loop (add1 term))))) - (loop (add1 state))))) + (for-each-state + (lambda (state) + (let loop ((term 0)) + (if (< term num-terms) + (begin + (array2d-set! table (kernel-index state) (+ num-non-terms term) + (get-action + (array2d-ref table + (kernel-index state) + (+ num-non-terms term)))) + (loop (add1 term)))))) + a) + (if (> SR-conflicts 0) (fprintf (current-error-port) "~a shift/reduce conflicts~n" @@ -154,53 +152,52 @@ - (define (resolve-prec-conflicts table get-term get-prod - num-states num-terms num-non-terms) - (let loop ((state 0)) - (if (< state num-states) - (begin - (let loop ((term 0)) - (if (< term num-terms) - (begin - (let ((action (array2d-ref table - state - (+ num-non-terms term)))) - (if (and (list? action) - (= 2 (length action)) - (or (shift? (car action)) - (shift? (cadr action)))) - (let* ((shift (if (shift? (car action)) - (car action) - (cadr action))) - (reduce (if (shift? (car action)) - (cadr action) - (car action))) - (s-prec (term-prec - (vector-ref get-term - term))) - (r-prec (prod-prec - (vector-ref - get-prod - (reduce-prod-num reduce))))) - (if (and s-prec r-prec) - (array2d-set! - table - state - (+ num-non-terms term) - (cond - ((< (prec-num s-prec) - (prec-num r-prec)) - reduce) - ((> (prec-num s-prec) - (prec-num r-prec)) - shift) - ((eq? 'left (prec-assoc s-prec)) - reduce) - ((eq? 'right (prec-assoc s-prec)) - shift) - (else #f))))))) - (loop (add1 term))))) - (loop (add1 state)))))) + (define (resolve-prec-conflicts a table get-term get-prod + num-terms num-non-terms) + (for-each-state + (lambda (state) + (let loop ((term 0)) + (if (< term num-terms) + (begin + (let ((action (array2d-ref table + (kernel-index state) + (+ num-non-terms term)))) + (if (and (list? action) + (= 2 (length action)) + (or (shift? (car action)) + (shift? (cadr action)))) + (let* ((shift (if (shift? (car action)) + (car action) + (cadr action))) + (reduce (if (shift? (car action)) + (cadr action) + (car action))) + (s-prec (term-prec + (vector-ref get-term + term))) + (r-prec (prod-prec + (vector-ref + get-prod + (reduce-prod-num reduce))))) + (if (and s-prec r-prec) + (array2d-set! + table + (kernel-index state) + (+ num-non-terms term) + (cond + ((< (prec-num s-prec) + (prec-num r-prec)) + reduce) + ((> (prec-num s-prec) + (prec-num r-prec)) + shift) + ((eq? 'left (prec-assoc s-prec)) + reduce) + ((eq? 'right (prec-assoc s-prec)) + shift) + (else #f))))))) + (loop (add1 term)))))) + a)) ;; In the result table the first index is the state and the second is the ;; term/non-term index (with the non-terms coming first) @@ -234,56 +231,53 @@ (array2d-set! v i1 i2 (list a old)))))))) (get-lookahead (compute-LA a g))) - (let loop ((state 0)) - (if (< state num-states) - (begin - (let loop ((i 0)) - (if (< i num-gram-syms) - (begin - (let* ((s (if (< i num-non-terms) - (vector-ref get-non-term i) - (vector-ref get-term (- i num-non-terms)))) - (goto - (run-automaton (vector-ref get-state state) - s - a))) - (if goto - (array2d-set! table - state - i - (cond - ((< i num-non-terms) - (kernel-index goto)) - ((member i end-term-indexes) - (make-accept)) - (else - (make-shift - (kernel-index goto))))))) - (loop (add1 i))))) - (let ((items - (filter (lambda (item) - (not (move-dot-right item))) - (kernel-items - (vector-ref get-state state))))) - (for-each - (lambda (item) - (for-each - (lambda (t) - (array2d-add! table - state - (+ num-non-terms (gram-sym-index t)) - (cond - ((not (start-item? item)) - (make-reduce - (item-prod-index item) - (gram-sym-index (prod-lhs (item-prod item))) - (vector-length (prod-rhs (item-prod item)))))))) - (get-lookahead (vector-ref get-state state) - (item-prod item)))) - items)) - (loop (add1 state))))) - (resolve-prec-conflicts table get-term get-prod num-states num-terms - num-non-terms) + (for-each-state + (lambda (state) + (let loop ((i 0)) + (if (< i num-gram-syms) + (begin + (let* ((s (if (< i num-non-terms) + (vector-ref get-non-term i) + (vector-ref get-term (- i num-non-terms)))) + (goto + (run-automaton (vector-ref get-state (kernel-index state)) + s + a))) + (if goto + (array2d-set! table + (kernel-index state) + i + (cond + ((< i num-non-terms) + (kernel-index goto)) + ((member i end-term-indexes) + (make-accept)) + (else + (make-shift + (kernel-index goto))))))) + (loop (add1 i))))) + (for-each + (lambda (item) + (for-each + (lambda (t) + (array2d-add! table + (kernel-index state) + (+ num-non-terms (gram-sym-index t)) + (cond + ((not (start-item? item)) + (make-reduce + (item-prod-index item) + (gram-sym-index (prod-lhs (item-prod item))) + (vector-length (prod-rhs (item-prod item)))))))) + (get-lookahead (vector-ref get-state (kernel-index state)) + (item-prod item)))) + (filter (lambda (item) + (not (move-dot-right item))) + (kernel-items + (vector-ref get-state (kernel-index state)))))) + a) + (resolve-prec-conflicts a table get-term get-prod num-terms + num-non-terms) (if (not (string=? file "")) (with-handlers [(exn:i/o:filesystem? (lambda (e) @@ -294,9 +288,9 @@ (exn:i/o:filesystem-detail e))))] (call-with-output-file file (lambda (port) - (display-parser table get-term get-non-term get-state (grammar-prods g) + (display-parser a table get-term get-non-term (grammar-prods g) port))))) - (resolve-conflicts table num-states num-terms num-non-terms) + (resolve-conflicts a table num-terms num-non-terms) table)) ) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 629e1ae..612cef5 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -23,7 +23,9 @@ (grammar #f)) (for-each (lambda (arg) - (syntax-case arg (debug error tokens start end precs grammar) + (syntax-case* arg (debug error tokens start end precs grammar) + (lambda (a b) + (eq? (syntax-object->datum a) (syntax-object->datum b))) ((debug filename) (cond ((not (string? (syntax-object->datum (syntax filename))))