diff --git a/codegen/flatten.rkt b/codegen/flatten.rkt old mode 100755 new mode 100644 index 5ac54b6..47392d0 --- a/codegen/flatten.rkt +++ b/codegen/flatten.rkt @@ -7,10 +7,10 @@ prim-rule) (define (make-fresh-name) - (let ([n 0]) - (λ () - (set! n (add1 n)) - (string->symbol (format "%rule~a" n))))) + (define n 0) + (λ () + (set! n (add1 n)) + (string->symbol (format "%rule~a" n)))) (define default-fresh-name (make-fresh-name)) @@ -161,10 +161,10 @@ ;; Then the pattern-inference process treats them separately. (define (pattern->hash-key a-pat) (let loop ([x a-pat]) - (let ([maybe-stx-list (syntax->list x)]) - (if maybe-stx-list - (cons (syntax-property x 'hide) (map loop maybe-stx-list)) - (syntax->datum x))))) + (define maybe-stx-list (syntax->list x)) + (if maybe-stx-list + (cons (syntax-property x 'hide) (map loop maybe-stx-list)) + (syntax->datum x)))) ;; Returns true if the pattern looks primitive diff --git a/codegen/runtime.rkt b/codegen/runtime.rkt old mode 100755 new mode 100644 index aaa95e9..80e72fd --- a/codegen/runtime.rkt +++ b/codegen/runtime.rkt @@ -147,11 +147,10 @@ (lex:position-line start-pos) (lex:position-col start-pos) (lex:position-offset start-pos) - (if (and (number? (lex:position-offset end-pos)) - (number? (lex:position-offset start-pos))) - (- (lex:position-offset end-pos) - (lex:position-offset start-pos)) - #f))) + (and (and (number? (lex:position-offset end-pos)) + (number? (lex:position-offset start-pos))) + (- (lex:position-offset end-pos) + (lex:position-offset start-pos))))) #| MB: the next three functions control the parse tree output. diff --git a/parser-tools/cfg-parser.rkt b/parser-tools/cfg-parser.rkt old mode 100755 new mode 100644 index f1087d8..b7094b9 --- a/parser-tools/cfg-parser.rkt +++ b/parser-tools/cfg-parser.rkt @@ -70,13 +70,14 @@ (let loop () (when (ormap-all #f (λ (nt pats) - (let ([old (bound-identifier-mapping-get nts nt)]) - (let ([new (proc nt pats old)]) - (if (equal? old new) - #f - (begin - (bound-identifier-mapping-put! nts nt new) - #t))))) + (define old (bound-identifier-mapping-get nts nt)) + (define new (proc nt pats old)) + (cond + [(equal? old new) + #f] + [else + (bound-identifier-mapping-put! nts nt new) + #t])) nt-ids patss) (loop)))) @@ -334,13 +335,11 @@ null)) #,(loop (cdr pat) (add1 pos))))) stream last-consumed-token depth - #,(let ([cnt (apply + - (map (λ (item) - (cond - [(bound-identifier-mapping-get nts item (λ () #f)) - => (λ (l) (car l))] - [else 1])) - (cdr pat)))]) + #,(let ([cnt (for/sum ([item (in-list (cdr pat))]) + (cond + [(bound-identifier-mapping-get nts item (λ () #f)) + => (λ (l) (car l))] + [else 1]))]) #`(- end #,cnt)) success-k fail-k max-depth tasks)] [else @@ -523,56 +522,56 @@ (nt-fixpoint nts (λ (nt pats old-list) - (let ([new-cnt - (apply min (for/list ([pat (in-list pats)]) - (for/sum ([elem (in-list pat)]) - (car (bound-identifier-mapping-get - nts elem (λ () (list 1)))))))]) - (if (new-cnt . > . (car old-list)) - (cons new-cnt (cdr old-list)) - old-list))) + (define new-cnt + (apply min (for/list ([pat (in-list pats)]) + (for/sum ([elem (in-list pat)]) + (car (bound-identifier-mapping-get + nts elem (λ () (list 1)))))))) + (if (new-cnt . > . (car old-list)) + (cons new-cnt (cdr old-list)) + old-list)) nt-ids patss) ;; Compute set of toks that must appear at the beginning ;; for a non-terminal (nt-fixpoint nts (λ (nt pats old-list) - (let ([new-list - (apply - append - (for/list ([pat (in-list pats)]) - (let loop ([pat pat]) - (if (pair? pat) - (let ([l (bound-identifier-mapping-get - nts - (car pat) - (λ () - (list 1 (map-token toks (car pat)))))]) - ;; If the non-terminal can match 0 things, - ;; then it might match something from the - ;; next pattern element. Otherwise, it must - ;; match the first element: - (if (zero? (car l)) - (append (cdr l) (loop (cdr pat))) - (cdr l))) - null))))]) - (let ([new (filter (λ (id) - (andmap (λ (id2) - (not (eq? id id2))) - (cdr old-list))) - new-list)]) - (if (pair? new) - ;; Drop dups in new list: - (let ([new (let loop ([new new]) - (if (null? (cdr new)) - new - (if (ormap (λ (id) - (eq? (car new) id)) - (cdr new)) - (loop (cdr new)) - (cons (car new) (loop (cdr new))))))]) - (cons (car old-list) (append new (cdr old-list)))) - old-list)))) + (define new-list + (apply + append + (for/list ([pat (in-list pats)]) + (let loop ([pat pat]) + (if (pair? pat) + (let ([l (bound-identifier-mapping-get + nts + (car pat) + (λ () + (list 1 (map-token toks (car pat)))))]) + ;; If the non-terminal can match 0 things, + ;; then it might match something from the + ;; next pattern element. Otherwise, it must + ;; match the first element: + (if (zero? (car l)) + (append (cdr l) (loop (cdr pat))) + (cdr l))) + null))))) + (define new + (filter (λ (id) + (andmap (λ (id2) + (not (eq? id id2))) + (cdr old-list))) + new-list)) + (if (pair? new) + ;; Drop dups in new list: + (let ([new (let loop ([new new]) + (cond + [(null? (cdr new)) new] + [(ormap (λ (id) + (eq? (car new) id)) + (cdr new)) (loop (cdr new))] + [else (cons (car new) (loop (cdr new)))]))]) + (cons (car old-list) (append new (cdr old-list)))) + old-list)) nt-ids patss) ;; Determine left-recursive clauses: (for-each (λ (nt pats) diff --git a/parser-tools/lex-sre.rkt b/parser-tools/lex-sre.rkt index ec3bd6a..efed8fb 100644 --- a/parser-tools/lex-sre.rkt +++ b/parser-tools/lex-sre.rkt @@ -83,12 +83,12 @@ [(_ RANGE ...) (let ([chars (apply append (for/list ([r (in-list (syntax->list #'(RANGE ...)))]) - (let ([x (syntax-e r)]) - (cond - [(char? x) (list x)] - [(string? x) (string->list x)] - [else - (raise-syntax-error #f "not a char or string" stx r)]))))]) + (define x (syntax-e r)) + (cond + [(char? x) (list x)] + [(string? x) (string->list x)] + [else + (raise-syntax-error #f "not a char or string" stx r)])))]) (unless (even? (length chars)) (raise-syntax-error #f "not given an even number of characters" stx)) #`(/-only-chars #,@chars))])) diff --git a/parser-tools/lex.rkt b/parser-tools/lex.rkt index 5bf0736..806560e 100644 --- a/parser-tools/lex.rkt +++ b/parser-tools/lex.rkt @@ -127,7 +127,7 @@ [(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)] [(ACT-NAME ...) (vector->list action-names)] [SPEC-ACT-STX (wrap-action spec-act src-loc-style)] - [HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)] + [HAS-COMMENT-ACT?-STX (and (syntax-e spec-comment-act) #t)] [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)] [EOF-ACT-STX (wrap-action eof-act src-loc-style)]) (syntax/loc stx (let ([NAME ACT] ...) @@ -200,7 +200,7 @@ (define r1 (vector-ref el 0)) (define r2 (vector-ref el 1)) (cond - [(and (>= char r1) (<= char r2)) (vector-ref el 2)] + [(<= r1 char r2) (vector-ref el 2)] [(< char r1) (get-next-state-helper char min try table)] [else (get-next-state-helper char (add1 try) max table)])])) @@ -351,18 +351,16 @@ (with-syntax ([(CHAR ...) (string->list (syntax-e #'STR))]) #'(union CHAR ...))])) -(define-syntax provide-lex-keyword - (syntax-rules () - [(_ ID ...) - (begin - (define-syntax-parameter ID - (make-set!-transformer - (λ (stx) - (raise-syntax-error - 'provide-lex-keyword - (format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID) - stx)))) - ... - (provide ID ...))])) +(define-syntax-rule (provide-lex-keyword ID ...) + (begin + (define-syntax-parameter ID + (make-set!-transformer + (λ (stx) + (raise-syntax-error + 'provide-lex-keyword + (format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID) + stx)))) + ... + (provide ID ...))) (provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc) diff --git a/parser-tools/private-lex/deriv.rkt b/parser-tools/private-lex/deriv.rkt index 151c75e..404fb9b 100644 --- a/parser-tools/private-lex/deriv.rkt +++ b/parser-tools/private-lex/deriv.rkt @@ -279,14 +279,12 @@ (printf "number of states: ~a\n" (dfa-num-states x)) (printf "start state: ~a\n" (dfa-start-state x)) (printf "final states: ~a\n" (map car (dfa-final-states/actions x))) - (for-each (λ (trans) - (printf "state: ~a\n" (car trans)) - (for-each (λ (rule) - (printf " -~a-> ~a\n" - (is:integer-set-contents (car rule)) - (cdr rule))) - (cdr trans))) - (dfa-transitions x))) + (for ([trans (in-list (dfa-transitions x))]) + (printf "state: ~a\n" (car trans)) + (for ([rule (in-list (cdr trans))]) + (printf " -~a-> ~a\n" + (is:integer-set-contents (car rule)) + (cdr rule))))) (define (build-test-dfa rs) (define c (make-cache)) diff --git a/parser-tools/private-lex/front.rkt b/parser-tools/private-lex/front.rkt index 550a03a..0fd16e0 100644 --- a/parser-tools/private-lex/front.rkt +++ b/parser-tools/private-lex/front.rkt @@ -10,12 +10,10 @@ (provide build-lexer) -(define-syntax time-label - (syntax-rules () - ((_ l e ...) - (begin - (printf "~a: " l) - (time (begin e ...)))))) +(define-syntax-rule (time-label l e ...) + (begin + (printf "~a: " l) + (time (begin e ...)))) ;; A table is either ;; - (vector-of (union #f nat)) @@ -89,7 +87,7 @@ (vector-set! no-look (car trans) #f)) no-look) -(test-block ((d1 (dfa 1 1 (list) (list))) +(test-block ((d1 (dfa 1 1 '() '())) (d2 (dfa 4 1 (list (cons 2 2) (cons 3 3)) (list (cons 1 (list (cons (is:make-range 49 50) 1) (cons (is:make-range 51) 2))) diff --git a/parser-tools/private-lex/re.rkt b/parser-tools/private-lex/re.rkt index f8c7111..8e1cfc0 100644 --- a/parser-tools/private-lex/re.rkt +++ b/parser-tools/private-lex/re.rkt @@ -81,7 +81,8 @@ [`(intersection ,rs ...) (build-and (flatten-res (map (λ (r) (->re r cache)) rs) andR? andR-res (λ (a b) - (let-values (((i _ __) (loc:split a b))) i)) + (define-values (i _ __) (loc:split a b)) + i) cache) cache)] [`(complement ,r) (build-neg (->re r cache) cache)] @@ -316,9 +317,9 @@ orR? orR-res is:union c)))) (isc (is:make-range (char->integer #\1) (char->integer #\7)))) ((flatten-res `(,r1 ,r2) andR? andR-res (λ (x y) - (let-values (((i _ __) - (is:split x y))) - i)) + (define-values (i _ __) + (is:split x y)) + i) c) (list z))) diff --git a/parser-tools/private-lex/stx.rkt b/parser-tools/private-lex/stx.rkt index e1f2136..51a9832 100644 --- a/parser-tools/private-lex/stx.rkt +++ b/parser-tools/private-lex/stx.rkt @@ -36,86 +36,86 @@ (let loop ([stx stx] ;; seen-lex-abbrevs: id-table [seen-lex-abbrevs (make-immutable-free-id-table)]) - (let ([recur (λ (s) - (loop (syntax-rearm s stx) - seen-lex-abbrevs))] - [recur/abbrev (λ (s id) - (loop (syntax-rearm s stx) - (free-id-table-set seen-lex-abbrevs id id)))]) - (syntax-case (disarm stx) (repetition union intersection complement concatenation - char-range char-complement) - [_ - (identifier? stx) - (let ([expansion (syntax-local-value/record stx (λ (v) #t))]) - (unless (lex-abbrev? expansion) - (raise-syntax-error 'regular-expression - "undefined abbreviation" - stx)) - ;; Check for cycles. - (when (free-id-table-ref seen-lex-abbrevs stx (λ () #f)) - (raise-syntax-error 'regular-expression - "illegal lex-abbrev cycle detected" - stx - #f - (list (free-id-table-ref seen-lex-abbrevs stx)))) - (recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))] - [_ - (or (char? (syntax-e stx)) (string? (syntax-e stx))) - (syntax-e stx)] - [(repetition ARG ...) - (let ([arg-list (syntax->list #'(ARG ...))]) - (unless (= 3 (length arg-list)) - (bad-args stx 2)) - (define low (syntax-e (car arg-list))) - (define high (syntax-e (cadr arg-list))) - (define re (caddr arg-list)) - (unless (and (number? low) (exact? low) (integer? low) (>= low 0)) - (raise-syntax-error #f "not a non-negative exact integer" stx (car arg-list))) - (unless (or (and (number? high) (exact? high) (integer? high) (>= high 0)) - (eqv? high +inf.0)) - (raise-syntax-error #f "not a non-negative exact integer or +inf.0" stx (cadr arg-list))) - (unless (<= low high) - (raise-syntax-error #f "the first argument is not less than or equal to the second argument" stx)) - `(repetition ,low ,high ,(recur re)))] - [(union RE ...) - `(union ,@(map recur (syntax->list #'(RE ...))))] - [(intersection RE ...) - `(intersection ,@(map recur (syntax->list #'(RE ...))))] - [(complement RE ...) - (let ([re-list (syntax->list #'(RE ...))]) - (unless (= 1 (length re-list)) - (bad-args stx 1)) - `(complement ,(recur (car re-list))))] - [(concatenation RE ...) - `(concatenation ,@(map recur (syntax->list #'(RE ...))))] - [(char-range ARG ...) - (let ((arg-list (syntax->list #'(ARG ...)))) - (unless (= 2 (length arg-list)) - (bad-args stx 2)) - (let ([i1 (char-range-arg (car arg-list) stx)] - [i2 (char-range-arg (cadr arg-list) stx)]) - (if (<= i1 i2) - `(char-range ,(integer->char i1) ,(integer->char i2)) - (raise-syntax-error #f "the first argument does not precede or equal second argument" stx))))] - [(char-complement ARG ...) - (let ([arg-list (syntax->list #'(ARG ...))]) - (unless (= 1 (length arg-list)) - (bad-args stx 1)) - (define parsed (recur (car arg-list))) - (unless (char-set? parsed) - (raise-syntax-error #f "not a character set" stx (car arg-list))) - `(char-complement ,parsed))] - ((OP form ...) - (identifier? #'OP) - (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))]) - (cond - [(lex-trans? expansion) - (recur ((lex-trans-f expansion) (disarm stx)))] - [expansion - (raise-syntax-error 'regular-expression "not a lex-trans" stx)] - [else - (raise-syntax-error 'regular-expression "undefined operator" stx)]))) - [_ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" stx)])))) + (define (recur s) + (loop (syntax-rearm s stx) + seen-lex-abbrevs)) + (define (recur/abbrev s id) + (loop (syntax-rearm s stx) + (free-id-table-set seen-lex-abbrevs id id))) + (syntax-case (disarm stx) (repetition union intersection complement concatenation + char-range char-complement) + [_ + (identifier? stx) + (let ([expansion (syntax-local-value/record stx (λ (v) #t))]) + (unless (lex-abbrev? expansion) + (raise-syntax-error 'regular-expression + "undefined abbreviation" + stx)) + ;; Check for cycles. + (when (free-id-table-ref seen-lex-abbrevs stx (λ () #f)) + (raise-syntax-error 'regular-expression + "illegal lex-abbrev cycle detected" + stx + #f + (list (free-id-table-ref seen-lex-abbrevs stx)))) + (recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))] + [_ + (or (char? (syntax-e stx)) (string? (syntax-e stx))) + (syntax-e stx)] + [(repetition ARG ...) + (let ([arg-list (syntax->list #'(ARG ...))]) + (unless (= 3 (length arg-list)) + (bad-args stx 2)) + (define low (syntax-e (car arg-list))) + (define high (syntax-e (cadr arg-list))) + (define re (caddr arg-list)) + (unless (and (number? low) (exact? low) (integer? low) (>= low 0)) + (raise-syntax-error #f "not a non-negative exact integer" stx (car arg-list))) + (unless (or (and (number? high) (exact? high) (integer? high) (>= high 0)) + (eqv? high +inf.0)) + (raise-syntax-error #f "not a non-negative exact integer or +inf.0" stx (cadr arg-list))) + (unless (<= low high) + (raise-syntax-error #f "the first argument is not less than or equal to the second argument" stx)) + `(repetition ,low ,high ,(recur re)))] + [(union RE ...) + `(union ,@(map recur (syntax->list #'(RE ...))))] + [(intersection RE ...) + `(intersection ,@(map recur (syntax->list #'(RE ...))))] + [(complement RE ...) + (let ([re-list (syntax->list #'(RE ...))]) + (unless (= 1 (length re-list)) + (bad-args stx 1)) + `(complement ,(recur (car re-list))))] + [(concatenation RE ...) + `(concatenation ,@(map recur (syntax->list #'(RE ...))))] + [(char-range ARG ...) + (let ((arg-list (syntax->list #'(ARG ...)))) + (unless (= 2 (length arg-list)) + (bad-args stx 2)) + (define i1 (char-range-arg (car arg-list) stx)) + (define i2 (char-range-arg (cadr arg-list) stx)) + (if (<= i1 i2) + `(char-range ,(integer->char i1) ,(integer->char i2)) + (raise-syntax-error #f "the first argument does not precede or equal second argument" stx)))] + [(char-complement ARG ...) + (let ([arg-list (syntax->list #'(ARG ...))]) + (unless (= 1 (length arg-list)) + (bad-args stx 1)) + (define parsed (recur (car arg-list))) + (unless (char-set? parsed) + (raise-syntax-error #f "not a character set" stx (car arg-list))) + `(char-complement ,parsed))] + ((OP form ...) + (identifier? #'OP) + (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))]) + (cond + [(lex-trans? expansion) + (recur ((lex-trans-f expansion) (disarm stx)))] + [expansion + (raise-syntax-error 'regular-expression "not a lex-trans" stx)] + [else + (raise-syntax-error 'regular-expression "undefined operator" stx)]))) + [_ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" stx)]))) diff --git a/parser-tools/private-lex/util.rkt b/parser-tools/private-lex/util.rkt index 82347a1..8a279e6 100644 --- a/parser-tools/private-lex/util.rkt +++ b/parser-tools/private-lex/util.rkt @@ -32,12 +32,9 @@ ;; returned. ;; Xs are compared with equal? (define (make-cache) - (let ([table (make-hash)]) - (λ (key build) - (hash-ref table key (λ () - (let ([new (build)]) - (hash-set! table key new) - new)))))) + (define table (make-hash)) + (λ (key build) + (hash-ref! table key build))) (module+ test (define cache (make-cache)) @@ -94,7 +91,7 @@ ;; Sorts l according to index and removes the entries with duplicate ;; indexes. (define (do-simple-equiv l index) - (define ordered (sort l (λ (a b) (< (index a) (index b))))) + (define ordered (sort l < #:key index)) (remove-dups ordered index null)) (module+ test diff --git a/parser-tools/private-yacc/grammar.rkt b/parser-tools/private-yacc/grammar.rkt index 41ed445..2204867 100644 --- a/parser-tools/private-yacc/grammar.rkt +++ b/parser-tools/private-yacc/grammar.rkt @@ -88,11 +88,11 @@ ;; print-item: LR-item -> (define (item->string it) - (define print-sym (λ (i) - (let ((gs (vector-ref (prod-rhs (item-prod it)) i))) - (cond - ((term? gs) (format "~a " (term-sym gs))) - (else (format "~a " (non-term-sym gs))))))) + (define (print-sym i) + (define gs (vector-ref (prod-rhs (item-prod it)) i)) + (cond + ((term? gs) (format "~a " (term-sym gs))) + (else (format "~a " (non-term-sym gs))))) (string-append (format "~a -> " (non-term-sym (prod-lhs (item-prod it)))) (let loop ((i 0)) diff --git a/parser-tools/private-yacc/graph.rkt b/parser-tools/private-yacc/graph.rkt index bac6736..620ebb9 100644 --- a/parser-tools/private-yacc/graph.rkt +++ b/parser-tools/private-yacc/graph.rkt @@ -31,14 +31,13 @@ (define d (depth)) (set-N x d) (hash-set! results x (f- x)) - (for-each (λ (y) - (when (= 0 (get-N y)) - (traverse y)) - (hash-set! results - x - (union (f x) (f y))) - (set-N x (min (get-N x) (get-N y)))) - (edges x)) + (for ([y (in-list (edges x))]) + (when (= 0 (get-N y)) + (traverse y)) + (hash-set! results + x + (union (f x) (f y))) + (set-N x (min (get-N x) (get-N y)))) (when (= d (get-N x)) (let loop ([p (pop)]) (set-N p +inf.0) diff --git a/parser-tools/private-yacc/input-file-parser.rkt b/parser-tools/private-yacc/input-file-parser.rkt index ccf201c..0535494 100644 --- a/parser-tools/private-yacc/input-file-parser.rkt +++ b/parser-tools/private-yacc/input-file-parser.rkt @@ -219,12 +219,11 @@ p #f (let loop ([i (sub1 (vector-length p))]) - (if (>= i 0) - (let ([gs (vector-ref p i)]) - (if (term? gs) - (term-prec gs) - (loop (sub1 i)))) - #f)) + (and (>= i 0) + (let ([gs (vector-ref p i)]) + (if (term? gs) + (term-prec gs) + (loop (sub1 i)))))) (parse-action #'PROD-RHS #'ACTION)))] [(PROD-RHS (PREC TERM) ACTION) (identifier? #'TERM) diff --git a/parser-tools/private-yacc/lalr.rkt b/parser-tools/private-yacc/lalr.rkt index 0730c92..b65ea5e 100644 --- a/parser-tools/private-yacc/lalr.rkt +++ b/parser-tools/private-yacc/lalr.rkt @@ -140,35 +140,29 @@ (printf "~a:\n" name) (send a for-each-state (λ (state) - (for-each - (λ (non-term) - (let ([res (f (trans-key state non-term))]) - (when (not (null? res)) - (printf "~a(~a, ~a) = ~a\n" - name - state - (gram-sym-symbol non-term) - (print-output res))))) - (send g get-non-terms)))) + (for ([non-term (in-list (send g get-non-terms))]) + (define res (f (trans-key state non-term))) + (when (not (null? res)) + (printf "~a(~a, ~a) = ~a\n" + name + state + (gram-sym-symbol non-term) + (print-output res)))))) (newline)) (define (print-input-st-prod f name a g print-output) (printf "~a:\n" name) (send a for-each-state (λ (state) - (for-each - (λ (non-term) - (for-each - (λ (prod) - (let ([res (f state prod)]) - (when (not (null? res)) - (printf "~a(~a, ~a) = ~a\n" - name - (kernel-index state) - (prod-index prod) - (print-output res))))) - (send g get-prods-for-non-term non-term))) - (send g get-non-terms))))) + (for ([non-term (in-list (send g get-non-terms))]) + (for ([prod (in-list (send g get-prods-for-non-term non-term))]) + (define res (f state prod)) + (when (not (null? res)) + (printf "~a(~a, ~a) = ~a\n" + name + (kernel-index state) + (prod-index prod) + (print-output res)))))))) (define (print-output-terms r) (map gram-sym-symbol r)) @@ -232,12 +226,11 @@ (let ([d (depth)]) (set-N x d) (set-f x (f- x)) - (for-each (λ (y) - (when (= 0 (get-N y)) - (traverse y)) - (set-f x (bitwise-ior (get-f x) (get-f y))) - (set-N x (min (get-N x) (get-N y)))) - (edges x)) + (for ([y (in-list (edges x))]) + (when (= 0 (get-N y)) + (traverse y)) + (set-f x (bitwise-ior (get-f x) (get-f y))) + (set-N x (min (get-N x) (get-N y)))) (when (= d (get-N x)) (let loop ([p (pop)]) (set-N p +inf.0) diff --git a/parser-tools/private-yacc/lr0.rkt b/parser-tools/private-yacc/lr0.rkt index 6a25256..325878a 100644 --- a/parser-tools/private-yacc/lr0.rkt +++ b/parser-tools/private-yacc/lr0.rkt @@ -30,13 +30,13 @@ (cond [(null? sorted) null] [(null? (cdr sorted)) sorted] + [(and (= (non-term-index (trans-key-gs (car sorted))) + (non-term-index (trans-key-gs (cadr sorted)))) + (= (kernel-index (trans-key-st (car sorted))) + (kernel-index (trans-key-st (cadr sorted))))) + (loop (cdr sorted))] [else - (if (and (= (non-term-index (trans-key-gs (car sorted))) - (non-term-index (trans-key-gs (cadr sorted)))) - (= (kernel-index (trans-key-st (car sorted))) - (kernel-index (trans-key-st (cadr sorted))))) - (loop (cdr sorted)) - (cons (car sorted) (loop (cdr sorted))))]))) + (cons (car sorted) (loop (cdr sorted)))]))) ;; build-transition-table : int (listof (cons/c trans-key X) -> diff --git a/parser-tools/private-yacc/table.rkt b/parser-tools/private-yacc/table.rkt index f914687..beb7825 100644 --- a/parser-tools/private-yacc/table.rkt +++ b/parser-tools/private-yacc/table.rkt @@ -147,13 +147,13 @@ (define RR-conflicts 0) (define table (table-map (λ (gs actions) - (let-values ([(action SR? RR?) - (resolve-conflict actions)]) - (when SR? - (set! SR-conflicts (add1 SR-conflicts))) - (when RR? - (set! RR-conflicts (add1 RR-conflicts))) - action)) + (define-values (action SR? RR?) + (resolve-conflict actions)) + (when SR? + (set! SR-conflicts (add1 SR-conflicts))) + (when RR? + (set! RR-conflicts (add1 RR-conflicts))) + action) grouped-table)) (unless suppress (when (> SR-conflicts 0) @@ -237,15 +237,11 @@ (bit-vector-for-each (λ (term-index) (unless (start-item? item) - (let ((r (hash-ref reduce-cache item-prod - (λ () - (let ((r (reduce item-prod))) - (hash-set! reduce-cache item-prod r) - r))))) - (table-add! table - (kernel-index state) - (vector-ref term-vector term-index) - r)))) + (define r (hash-ref! reduce-cache item-prod (λ () (reduce item-prod)))) + (table-add! table + (kernel-index state) + (vector-ref term-vector term-index) + r))) (get-lookahead state item-prod)))))) (define grouped-table (resolve-prec-conflicts table)) diff --git a/parser-tools/yacc-to-scheme.rkt b/parser-tools/yacc-to-scheme.rkt index 184610c..e6b4692 100644 --- a/parser-tools/yacc-to-scheme.rkt +++ b/parser-tools/yacc-to-scheme.rkt @@ -114,9 +114,9 @@ (regexp-match "%%" i) (begin0 (let ([gram ((parse-grammar enter-term enter-empty-term enter-non-term) - (λ () - (let ((t (get-token-grammar i))) - t)))]) + (λ () + (define t (get-token-grammar i)) + t))]) `(begin (define-tokens t ,(sort (hash-map terms (λ (k v) k)) symboldatum grammar) - tokens - (map syntax->datum start) - (and precs (syntax->datum precs)) - port)) - #:exists 'truncate))) - (with-syntax ([check-syntax-fix check-syntax-fix] - [err error] - [ends end] - [starts start] - [debug debug] - [table (convert-parse-table table)] - [all-term-syms all-term-syms] - [actions actions] - [src-pos src-pos]) - #'(begin - check-syntax-fix - (parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos)))))] + (define-values (table all-term-syms actions check-syntax-fix) + (build-parser (if debug debug "") + src-pos + suppress + tokens + start + end + precs + grammar)) + (when (and yacc-output (not (string=? yacc-output ""))) + (with-handlers [(exn:fail:filesystem? + (λ (e) (eprintf "Cannot write yacc-output to file \"~a\"\n" yacc-output)))] + (call-with-output-file yacc-output + (λ (port) + (display-yacc (syntax->datum grammar) + tokens + (map syntax->datum start) + (and precs (syntax->datum precs)) + port)) + #:exists 'truncate))) + (with-syntax ([check-syntax-fix check-syntax-fix] + [err error] + [ends end] + [starts start] + [debug debug] + [table (convert-parse-table table)] + [all-term-syms all-term-syms] + [actions actions] + [src-pos src-pos]) + #'(begin + check-syntax-fix + (parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos))))] [_ (raise-syntax-error #f "parser must have the form (parser args ...)" stx)])) (define (reduce-stack stack num ret-vals src-pos) @@ -237,31 +237,29 @@ stack)] [else ;; (printf "discard input:~a\n" tok) - (let-values ([(tok val start-pos end-pos) - (extract (get-token))]) - (remove-input tok val start-pos end-pos))]))))) + (call-with-values (λ () (extract (get-token))) remove-input)]))))) (let remove-states () - (let ([a (find-action stack 'error #f start-pos end-pos)]) - (cond - [(runtime-shift? a) - ;; (printf "shift:~a\n" (runtime-shift-state a)) - (set! stack - (cons - (stack-frame (runtime-shift-state a) - #f - start-pos - end-pos) - stack)) - (remove-input tok val start-pos end-pos)] - [else - ;; (printf "discard state:~a\n" (car stack)) - (cond - [(< (length stack) 2) - (raise-read-error "parser: Cannot continue after error" - #f #f #f #f #f)] - [else - (set! stack (cdr stack)) - (remove-states)])]))))) + (define a (find-action stack 'error #f start-pos end-pos)) + (cond + [(runtime-shift? a) + ;; (printf "shift:~a\n" (runtime-shift-state a)) + (set! stack + (cons + (stack-frame (runtime-shift-state a) + #f + start-pos + end-pos) + stack)) + (remove-input tok val start-pos end-pos)] + [else + ;; (printf "discard state:~a\n" (car stack)) + (cond + [(< (length stack) 2) + (raise-read-error "parser: Cannot continue after error" + #f #f #f #f #f)] + [else + (set! stack (cdr stack)) + (remove-states)])])))) (define (find-action stack tok val start-pos end-pos) (unless (hash-ref all-term-syms tok #f) @@ -278,55 +276,55 @@ (error 'get-token "expected a nullary procedure, got ~e" get-token)) (let parsing-loop ([stack (make-empty-stack start-number)] [ip (get-token)]) - (let-values ([(tok val start-pos end-pos) (extract ip)]) - (let ([action (find-action stack tok val start-pos end-pos)]) - (cond - [(runtime-shift? action) - ;; (printf "shift:~a\n" (runtime-shift-state action)) - (parsing-loop (cons (stack-frame (runtime-shift-state action) - val - start-pos - end-pos) - stack) - (get-token))] - [(runtime-reduce? action) - ;; (printf "reduce:~a\n" (runtime-reduce-prod-num action)) - (let-values ([(new-stack args) - (reduce-stack stack - (runtime-reduce-rhs-length action) - null - src-pos)]) - (let ([goto - (runtime-goto-state - (hash-ref - (vector-ref table (stack-frame-state (car new-stack))) - (runtime-reduce-lhs action)))]) - (parsing-loop - (cons - (if src-pos - (stack-frame - goto - (apply (vector-ref actions (runtime-reduce-prod-num action)) args) - (if (null? args) start-pos (cadr args)) - (if (null? args) - end-pos - (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1)))) - (stack-frame - goto - (apply (vector-ref actions (runtime-reduce-prod-num action)) args) - #f - #f)) - new-stack) - ip)))] - [(runtime-accept? action) - ;; (printf "accept\n") - (stack-frame-value (car stack))] - [else + (define-values (tok val start-pos end-pos) (extract ip)) + (define action (find-action stack tok val start-pos end-pos)) + (cond + [(runtime-shift? action) + ;; (printf "shift:~a\n" (runtime-shift-state action)) + (parsing-loop (cons (stack-frame (runtime-shift-state action) + val + start-pos + end-pos) + stack) + (get-token))] + [(runtime-reduce? action) + ;; (printf "reduce:~a\n" (runtime-reduce-prod-num action)) + (let-values ([(new-stack args) + (reduce-stack stack + (runtime-reduce-rhs-length action) + null + src-pos)]) + (define goto + (runtime-goto-state + (hash-ref + (vector-ref table (stack-frame-state (car new-stack))) + (runtime-reduce-lhs action)))) + (parsing-loop + (cons (if src-pos - (err #t tok val start-pos end-pos) - (err #t tok val)) - (parsing-loop (fix-error stack tok val start-pos end-pos get-token) - (get-token))])))))) + (stack-frame + goto + (apply (vector-ref actions (runtime-reduce-prod-num action)) args) + (if (null? args) start-pos (cadr args)) + (if (null? args) + end-pos + (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1)))) + (stack-frame + goto + (apply (vector-ref actions (runtime-reduce-prod-num action)) args) + #f + #f)) + new-stack) + ip))] + [(runtime-accept? action) + ;; (printf "accept\n") + (stack-frame-value (car stack))] + [else + (if src-pos + (err #t tok val start-pos end-pos) + (err #t tok val)) + (parsing-loop (fix-error stack tok val start-pos end-pos get-token) + (get-token))])))) (cond [(null? (cdr starts)) (make-parser 0)] [else diff --git a/private/colorer.rkt b/private/colorer.rkt index 165e79e..b5db32a 100644 --- a/private/colorer.rkt +++ b/private/colorer.rkt @@ -38,8 +38,8 @@ (define-syntax-rule (values->list EXPR) (call-with-values (λ () EXPR) list)) (define (apply-colorer str) (for/list ([annotation (in-port (λ (p) - (let ([xs (values->list (color-brag p))]) - (if (eof-object? (car xs)) eof xs))) + (define xs (values->list (color-brag p))) + (if (eof-object? (car xs)) eof xs)) (open-input-string str))]) annotation)) diff --git a/rules/parser.rkt b/rules/parser.rkt old mode 100755 new mode 100644 index 5e97010..5229f35 --- a/rules/parser.rkt +++ b/rules/parser.rkt @@ -169,7 +169,7 @@ [(list all min range? max) (let* ([min (if min (string->number min) 0)] [max (cond [(and range? max) (string->number max)] - [(and (not range?) (not max)) (if (zero? min) + [(not (or range? max)) (if (zero? min) #f ; {} -> {0,} min)] ; {3} -> {3,3} [else #f])]) @@ -298,8 +298,7 @@ (pos-line start-pos) (pos-col start-pos) (pos-offset start-pos) - (if (and (number? (pos-offset end-pos)) - (number? (pos-offset start-pos))) - (- (pos-offset end-pos) - (pos-offset start-pos)) - #f)))))))) + (and (and (number? (pos-offset end-pos)) + (number? (pos-offset start-pos))) + (- (pos-offset end-pos) + (pos-offset start-pos)))))))))) diff --git a/rules/stx.rkt b/rules/stx.rkt old mode 100755 new mode 100644 index 01484ef..51a3feb --- a/rules/stx.rkt +++ b/rules/stx.rkt @@ -14,21 +14,19 @@ (pos-line (lhs-id-start (rule-lhs a-rule))) (pos-col (lhs-id-start (rule-lhs a-rule))) (pos-offset (lhs-id-start (rule-lhs a-rule))) - (if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule)))) - (number? (pos-offset (lhs-id-end (rule-lhs a-rule))))) - (- (pos-offset (lhs-id-end (rule-lhs a-rule))) - (pos-offset (lhs-id-start (rule-lhs a-rule)))) - #f))) + (and (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule)))) + (number? (pos-offset (lhs-id-end (rule-lhs a-rule))))) + (- (pos-offset (lhs-id-end (rule-lhs a-rule))) + (pos-offset (lhs-id-start (rule-lhs a-rule))))))) 'hide-or-splice-lhs-id (lhs-id-splice (rule-lhs a-rule)))) (define pattern-stx (pattern->stx source (rule-pattern a-rule))) (define line (pos-line (rule-start a-rule))) (define column (pos-col (rule-start a-rule))) (define position (pos-offset (rule-start a-rule))) - (define span (if (and (number? (pos-offset (rule-start a-rule))) - (number? (pos-offset (rule-end a-rule)))) - (- (pos-offset (rule-end a-rule)) - (pos-offset (rule-start a-rule))) - #f)) + (define span (and (and (number? (pos-offset (rule-start a-rule))) + (number? (pos-offset (rule-end a-rule)))) + (- (pos-offset (rule-end a-rule)) + (pos-offset (rule-start a-rule))))) (datum->syntax #f `(rule ,id-stx ,pattern-stx) (list source line column position span))) diff --git a/tests/test-flatten.rkt b/tests/test-flatten.rkt old mode 100755 new mode 100644 index aa4073b..d710153 --- a/tests/test-flatten.rkt +++ b/tests/test-flatten.rkt @@ -8,10 +8,10 @@ (define (make-fresh-name) - (let ([n 0]) - (lambda () - (set! n (add1 n)) - (string->symbol (format "r~a" n))))) + (define n 0) + (lambda () + (set! n (add1 n)) + (string->symbol (format "r~a" n)))) ;; Simple literals diff --git a/token.rkt b/token.rkt index 8b8c994..ce12b11 100644 --- a/token.rkt +++ b/token.rkt @@ -46,16 +46,16 @@ 'token (λ (this) (append (list (token-type this)) - (if (token-value this) (list (token-value this)) (list)) + (if (token-value this) (list (token-value this)) '()) (if (token-location this) (list (sequence-markup (list (unquoted-printing-string "#:location") (token-location this)))) - (list)) + '()) (if (token-skip? this) (list (sequence-markup (list (unquoted-printing-string "#:skip?") (token-skip? this)))) - (list))))))]) + '())))))]) (define (source-location #:source [source #false]