mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

Run `resyntax` over everything

Browse Source
remotes/jackfirth/master
Jack Firth 3 years ago
parent e18a3399fe
commit 9d48ab7152
23 changed files with 380 additions and 408 deletions
Show Stats Download Patch File Download Diff File

16
codegen/flatten.rkt
Unescape Escape View File

@ -7,10 +7,10 @@
prim-rule) prim-rule)
(define (make-fresh-name) (define (make-fresh-name)
(let ([n 0]) (define n 0)
(λ () (λ ()
(set! n (add1 n)) (set! n (add1 n))
(string->symbol (format "%rule~a" n))))) (string->symbol (format "%rule~a" n))))
(define default-fresh-name (make-fresh-name)) (define default-fresh-name (make-fresh-name))
@ -161,10 +161,10 @@
;; Then the pattern-inference process treats them separately. ;; Then the pattern-inference process treats them separately.
(define (pattern->hash-key a-pat) (define (pattern->hash-key a-pat)
(let loop ([x a-pat]) (let loop ([x a-pat])
(let ([maybe-stx-list (syntax->list x)]) (define maybe-stx-list (syntax->list x))
(if maybe-stx-list (if maybe-stx-list
(cons (syntax-property x 'hide) (map loop maybe-stx-list)) (cons (syntax-property x 'hide) (map loop maybe-stx-list))
(syntax->datum x))))) (syntax->datum x))))
;; Returns true if the pattern looks primitive ;; Returns true if the pattern looks primitive

9
codegen/runtime.rkt
Unescape Escape View File

@ -147,11 +147,10 @@
(lex:position-line start-pos) (lex:position-line start-pos)
(lex:position-col start-pos) (lex:position-col start-pos)
(lex:position-offset start-pos) (lex:position-offset start-pos)
(if (and (number? (lex:position-offset end-pos)) (and (and (number? (lex:position-offset end-pos))
(number? (lex:position-offset start-pos))) (number? (lex:position-offset start-pos)))
(- (lex:position-offset end-pos) (- (lex:position-offset end-pos)
(lex:position-offset start-pos)) (lex:position-offset start-pos)))))
#f)))
#| #|
MB: the next three functions control the parse tree output. MB: the next three functions control the parse tree output.

115
parser-tools/cfg-parser.rkt
Unescape Escape View File

@ -70,13 +70,14 @@
(let loop () (let loop ()
(when (ormap-all #f (when (ormap-all #f
(λ (nt pats) (λ (nt pats)
(let ([old (bound-identifier-mapping-get nts nt)]) (define old (bound-identifier-mapping-get nts nt))
(let ([new (proc nt pats old)]) (define new (proc nt pats old))
(if (equal? old new) (cond
#f [(equal? old new)
(begin #f]
(bound-identifier-mapping-put! nts nt new) [else
#t))))) (bound-identifier-mapping-put! nts nt new)
#t]))
nt-ids patss) nt-ids patss)
(loop)))) (loop))))
@ -334,13 +335,11 @@
null)) null))
#,(loop (cdr pat) (add1 pos))))) #,(loop (cdr pat) (add1 pos)))))
stream last-consumed-token depth stream last-consumed-token depth
#,(let ([cnt (apply + #,(let ([cnt (for/sum ([item (in-list (cdr pat))])
(map (λ (item) (cond
(cond [(bound-identifier-mapping-get nts item (λ () #f))
[(bound-identifier-mapping-get nts item (λ () #f)) => (λ (l) (car l))]
=> (λ (l) (car l))] [else 1]))])
[else 1]))
(cdr pat)))])
#`(- end #,cnt)) #`(- end #,cnt))
success-k fail-k max-depth tasks)] success-k fail-k max-depth tasks)]
[else [else
@ -523,56 +522,56 @@
(nt-fixpoint (nt-fixpoint
nts nts
(λ (nt pats old-list) (λ (nt pats old-list)
(let ([new-cnt (define new-cnt
(apply min (for/list ([pat (in-list pats)]) (apply min (for/list ([pat (in-list pats)])
(for/sum ([elem (in-list pat)]) (for/sum ([elem (in-list pat)])
(car (bound-identifier-mapping-get (car (bound-identifier-mapping-get
nts elem (λ () (list 1)))))))]) nts elem (λ () (list 1))))))))
(if (new-cnt . > . (car old-list)) (if (new-cnt . > . (car old-list))
(cons new-cnt (cdr old-list)) (cons new-cnt (cdr old-list))
old-list))) old-list))
nt-ids patss) nt-ids patss)
;; Compute set of toks that must appear at the beginning ;; Compute set of toks that must appear at the beginning
;; for a non-terminal ;; for a non-terminal
(nt-fixpoint (nt-fixpoint
nts nts
(λ (nt pats old-list) (λ (nt pats old-list)
(let ([new-list (define new-list
(apply (apply
append append
(for/list ([pat (in-list pats)]) (for/list ([pat (in-list pats)])
(let loop ([pat pat]) (let loop ([pat pat])
(if (pair? pat) (if (pair? pat)
(let ([l (bound-identifier-mapping-get (let ([l (bound-identifier-mapping-get
nts nts
(car pat) (car pat)
(λ () (λ ()
(list 1 (map-token toks (car pat)))))]) (list 1 (map-token toks (car pat)))))])
;; If the non-terminal can match 0 things, ;; If the non-terminal can match 0 things,
;; then it might match something from the ;; then it might match something from the
;; next pattern element. Otherwise, it must ;; next pattern element. Otherwise, it must
;; match the first element: ;; match the first element:
(if (zero? (car l)) (if (zero? (car l))
(append (cdr l) (loop (cdr pat))) (append (cdr l) (loop (cdr pat)))
(cdr l))) (cdr l)))
null))))]) null)))))
(let ([new (filter (λ (id) (define new
(andmap (λ (id2) (filter (λ (id)
(not (eq? id id2))) (andmap (λ (id2)
(cdr old-list))) (not (eq? id id2)))
new-list)]) (cdr old-list)))
(if (pair? new) new-list))
;; Drop dups in new list: (if (pair? new)
(let ([new (let loop ([new new]) ;; Drop dups in new list:
(if (null? (cdr new)) (let ([new (let loop ([new new])
new (cond
(if (ormap (λ (id) [(null? (cdr new)) new]
(eq? (car new) id)) [(ormap (λ (id)
(cdr new)) (eq? (car new) id))
(loop (cdr new)) (cdr new)) (loop (cdr new))]
(cons (car new) (loop (cdr new))))))]) [else (cons (car new) (loop (cdr new)))]))])
(cons (car old-list) (append new (cdr old-list)))) (cons (car old-list) (append new (cdr old-list))))
old-list)))) old-list))
nt-ids patss) nt-ids patss)
;; Determine left-recursive clauses: ;; Determine left-recursive clauses:
(for-each (λ (nt pats) (for-each (λ (nt pats)

12
parser-tools/lex-sre.rkt
Unescape Escape View File

@ -83,12 +83,12 @@
[(_ RANGE ...) [(_ RANGE ...)
(let ([chars (let ([chars
(apply append (for/list ([r (in-list (syntax->list #'(RANGE ...)))]) (apply append (for/list ([r (in-list (syntax->list #'(RANGE ...)))])
(let ([x (syntax-e r)]) (define x (syntax-e r))
(cond (cond
[(char? x) (list x)] [(char? x) (list x)]
[(string? x) (string->list x)] [(string? x) (string->list x)]
[else [else
(raise-syntax-error #f "not a char or string" stx r)]))))]) (raise-syntax-error #f "not a char or string" stx r)])))])
(unless (even? (length chars)) (unless (even? (length chars))
(raise-syntax-error #f "not given an even number of characters" stx)) (raise-syntax-error #f "not given an even number of characters" stx))
#`(/-only-chars #,@chars))])) #`(/-only-chars #,@chars))]))

28
parser-tools/lex.rkt
Unescape Escape View File

@ -127,7 +127,7 @@
[(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)] [(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)]
[(ACT-NAME ...) (vector->list action-names)] [(ACT-NAME ...) (vector->list action-names)]
[SPEC-ACT-STX (wrap-action spec-act src-loc-style)] [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)] [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
[EOF-ACT-STX (wrap-action eof-act src-loc-style)]) [EOF-ACT-STX (wrap-action eof-act src-loc-style)])
(syntax/loc stx (let ([NAME ACT] ...) (syntax/loc stx (let ([NAME ACT] ...)
@ -200,7 +200,7 @@
(define r1 (vector-ref el 0)) (define r1 (vector-ref el 0))
(define r2 (vector-ref el 1)) (define r2 (vector-ref el 1))
(cond (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)] [(< char r1) (get-next-state-helper char min try table)]
[else (get-next-state-helper char (add1 try) max table)])])) [else (get-next-state-helper char (add1 try) max table)])]))
@ -351,18 +351,16 @@
(with-syntax ([(CHAR ...) (string->list (syntax-e #'STR))]) (with-syntax ([(CHAR ...) (string->list (syntax-e #'STR))])
#'(union CHAR ...))])) #'(union CHAR ...))]))
(define-syntax provide-lex-keyword (define-syntax-rule (provide-lex-keyword ID ...)
(syntax-rules () (begin
[(_ ID ...) (define-syntax-parameter ID
(begin (make-set!-transformer
(define-syntax-parameter ID (λ (stx)
(make-set!-transformer (raise-syntax-error
(λ (stx) 'provide-lex-keyword
(raise-syntax-error (format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID)
'provide-lex-keyword stx))))
(format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID) ...
stx)))) (provide ID ...)))
...
(provide ID ...))]))
(provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc) (provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc)

14
parser-tools/private-lex/deriv.rkt
Unescape Escape View File

@ -279,14 +279,12 @@
(printf "number of states: ~a\n" (dfa-num-states x)) (printf "number of states: ~a\n" (dfa-num-states x))
(printf "start state: ~a\n" (dfa-start-state x)) (printf "start state: ~a\n" (dfa-start-state x))
(printf "final states: ~a\n" (map car (dfa-final-states/actions x))) (printf "final states: ~a\n" (map car (dfa-final-states/actions x)))
(for-each (λ (trans) (for ([trans (in-list (dfa-transitions x))])
(printf "state: ~a\n" (car trans)) (printf "state: ~a\n" (car trans))
(for-each (λ (rule) (for ([rule (in-list (cdr trans))])
(printf " -~a-> ~a\n" (printf " -~a-> ~a\n"
(is:integer-set-contents (car rule)) (is:integer-set-contents (car rule))
(cdr rule))) (cdr rule)))))
(cdr trans)))
(dfa-transitions x)))
(define (build-test-dfa rs) (define (build-test-dfa rs)
(define c (make-cache)) (define c (make-cache))

12
parser-tools/private-lex/front.rkt
Unescape Escape View File

@ -10,12 +10,10 @@
(provide build-lexer) (provide build-lexer)
(define-syntax time-label (define-syntax-rule (time-label l e ...)
(syntax-rules () (begin
((_ l e ...) (printf "~a: " l)
(begin (time (begin e ...))))
(printf "~a: " l)
(time (begin e ...))))))
;; A table is either ;; A table is either
;; - (vector-of (union #f nat)) ;; - (vector-of (union #f nat))
@ -89,7 +87,7 @@
(vector-set! no-look (car trans) #f)) (vector-set! no-look (car trans) #f))
no-look) 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)) (d2 (dfa 4 1 (list (cons 2 2) (cons 3 3))
(list (cons 1 (list (cons (is:make-range 49 50) 1) (list (cons 1 (list (cons (is:make-range 49 50) 1)
(cons (is:make-range 51) 2))) (cons (is:make-range 51) 2)))

9
parser-tools/private-lex/re.rkt
Unescape Escape View File

@ -81,7 +81,8 @@
[`(intersection ,rs ...) [`(intersection ,rs ...)
(build-and (flatten-res (map (λ (r) (->re r cache)) rs) (build-and (flatten-res (map (λ (r) (->re r cache)) rs)
andR? andR-res (λ (a b) andR? andR-res (λ (a b)
(let-values (((i _ __) (loc:split a b))) i)) (define-values (i _ __) (loc:split a b))
i)
cache) cache)
cache)] cache)]
[`(complement ,r) (build-neg (->re r cache) cache)] [`(complement ,r) (build-neg (->re r cache) cache)]
@ -316,9 +317,9 @@
orR? orR-res is:union c)))) orR? orR-res is:union c))))
(isc (is:make-range (char->integer #\1) (char->integer #\7)))) (isc (is:make-range (char->integer #\1) (char->integer #\7))))
((flatten-res `(,r1 ,r2) andR? andR-res (λ (x y) ((flatten-res `(,r1 ,r2) andR? andR-res (λ (x y)
(let-values (((i _ __) (define-values (i _ __)
(is:split x y))) (is:split x y))
i)) i)
c) c)
(list z))) (list z)))

160
parser-tools/private-lex/stx.rkt
Unescape Escape View File

@ -36,86 +36,86 @@
(let loop ([stx stx] (let loop ([stx stx]
;; seen-lex-abbrevs: id-table ;; seen-lex-abbrevs: id-table
[seen-lex-abbrevs (make-immutable-free-id-table)]) [seen-lex-abbrevs (make-immutable-free-id-table)])
(let ([recur (λ (s) (define (recur s)
(loop (syntax-rearm s stx) (loop (syntax-rearm s stx)
seen-lex-abbrevs))] seen-lex-abbrevs))
[recur/abbrev (λ (s id) (define (recur/abbrev s id)
(loop (syntax-rearm s stx) (loop (syntax-rearm s stx)
(free-id-table-set seen-lex-abbrevs id id)))]) (free-id-table-set seen-lex-abbrevs id id)))
(syntax-case (disarm stx) (repetition union intersection complement concatenation (syntax-case (disarm stx) (repetition union intersection complement concatenation
char-range char-complement) char-range char-complement)
[_ [_
(identifier? stx) (identifier? stx)
(let ([expansion (syntax-local-value/record stx (λ (v) #t))]) (let ([expansion (syntax-local-value/record stx (λ (v) #t))])
(unless (lex-abbrev? expansion) (unless (lex-abbrev? expansion)
(raise-syntax-error 'regular-expression (raise-syntax-error 'regular-expression
"undefined abbreviation" "undefined abbreviation"
stx)) stx))
;; Check for cycles. ;; Check for cycles.
(when (free-id-table-ref seen-lex-abbrevs stx (λ () #f)) (when (free-id-table-ref seen-lex-abbrevs stx (λ () #f))
(raise-syntax-error 'regular-expression (raise-syntax-error 'regular-expression
"illegal lex-abbrev cycle detected" "illegal lex-abbrev cycle detected"
stx stx
#f #f
(list (free-id-table-ref seen-lex-abbrevs stx)))) (list (free-id-table-ref seen-lex-abbrevs stx))))
(recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))] (recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))]
[_ [_
(or (char? (syntax-e stx)) (string? (syntax-e stx))) (or (char? (syntax-e stx)) (string? (syntax-e stx)))
(syntax-e stx)] (syntax-e stx)]
[(repetition ARG ...) [(repetition ARG ...)
(let ([arg-list (syntax->list #'(ARG ...))]) (let ([arg-list (syntax->list #'(ARG ...))])
(unless (= 3 (length arg-list)) (unless (= 3 (length arg-list))
(bad-args stx 2)) (bad-args stx 2))
(define low (syntax-e (car arg-list))) (define low (syntax-e (car arg-list)))
(define high (syntax-e (cadr arg-list))) (define high (syntax-e (cadr arg-list)))
(define re (caddr arg-list)) (define re (caddr arg-list))
(unless (and (number? low) (exact? low) (integer? low) (>= low 0)) (unless (and (number? low) (exact? low) (integer? low) (>= low 0))
(raise-syntax-error #f "not a non-negative exact integer" stx (car arg-list))) (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)) (unless (or (and (number? high) (exact? high) (integer? high) (>= high 0))
(eqv? high +inf.0)) (eqv? high +inf.0))
(raise-syntax-error #f "not a non-negative exact integer or +inf.0" stx (cadr arg-list))) (raise-syntax-error #f "not a non-negative exact integer or +inf.0" stx (cadr arg-list)))
(unless (<= low high) (unless (<= low high)
(raise-syntax-error #f "the first argument is not less than or equal to the second argument" stx)) (raise-syntax-error #f "the first argument is not less than or equal to the second argument" stx))
`(repetition ,low ,high ,(recur re)))] `(repetition ,low ,high ,(recur re)))]
[(union RE ...) [(union RE ...)
`(union ,@(map recur (syntax->list #'(RE ...))))] `(union ,@(map recur (syntax->list #'(RE ...))))]
[(intersection RE ...) [(intersection RE ...)
`(intersection ,@(map recur (syntax->list #'(RE ...))))] `(intersection ,@(map recur (syntax->list #'(RE ...))))]
[(complement RE ...) [(complement RE ...)
(let ([re-list (syntax->list #'(RE ...))]) (let ([re-list (syntax->list #'(RE ...))])
(unless (= 1 (length re-list)) (unless (= 1 (length re-list))
(bad-args stx 1)) (bad-args stx 1))
`(complement ,(recur (car re-list))))] `(complement ,(recur (car re-list))))]
[(concatenation RE ...) [(concatenation RE ...)
`(concatenation ,@(map recur (syntax->list #'(RE ...))))] `(concatenation ,@(map recur (syntax->list #'(RE ...))))]
[(char-range ARG ...) [(char-range ARG ...)
(let ((arg-list (syntax->list #'(ARG ...)))) (let ((arg-list (syntax->list #'(ARG ...))))
(unless (= 2 (length arg-list)) (unless (= 2 (length arg-list))
(bad-args stx 2)) (bad-args stx 2))
(let ([i1 (char-range-arg (car arg-list) stx)] (define i1 (char-range-arg (car arg-list) stx))
[i2 (char-range-arg (cadr arg-list) stx)]) (define i2 (char-range-arg (cadr arg-list) stx))
(if (<= i1 i2) (if (<= i1 i2)
`(char-range ,(integer->char i1) ,(integer->char i2)) `(char-range ,(integer->char i1) ,(integer->char i2))
(raise-syntax-error #f "the first argument does not precede or equal second argument" stx))))] (raise-syntax-error #f "the first argument does not precede or equal second argument" stx)))]
[(char-complement ARG ...) [(char-complement ARG ...)
(let ([arg-list (syntax->list #'(ARG ...))]) (let ([arg-list (syntax->list #'(ARG ...))])
(unless (= 1 (length arg-list)) (unless (= 1 (length arg-list))
(bad-args stx 1)) (bad-args stx 1))
(define parsed (recur (car arg-list))) (define parsed (recur (car arg-list)))
(unless (char-set? parsed) (unless (char-set? parsed)
(raise-syntax-error #f "not a character set" stx (car arg-list))) (raise-syntax-error #f "not a character set" stx (car arg-list)))
`(char-complement ,parsed))] `(char-complement ,parsed))]
((OP form ...) ((OP form ...)
(identifier? #'OP) (identifier? #'OP)
(let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))]) (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))])
(cond (cond
[(lex-trans? expansion) [(lex-trans? expansion)
(recur ((lex-trans-f expansion) (disarm stx)))] (recur ((lex-trans-f expansion) (disarm stx)))]
[expansion [expansion
(raise-syntax-error 'regular-expression "not a lex-trans" stx)] (raise-syntax-error 'regular-expression "not a lex-trans" stx)]
[else [else
(raise-syntax-error 'regular-expression "undefined operator" stx)]))) (raise-syntax-error 'regular-expression "undefined operator" stx)])))
[_ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" stx)])))) [_ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" stx)])))

11
parser-tools/private-lex/util.rkt
Unescape Escape View File

@ -32,12 +32,9 @@
;; returned. ;; returned.
;; Xs are compared with equal? ;; Xs are compared with equal?
(define (make-cache) (define (make-cache)
(let ([table (make-hash)]) (define table (make-hash))
(λ (key build) (λ (key build)
(hash-ref table key (λ () (hash-ref! table key build)))
(let ([new (build)])
(hash-set! table key new)
new))))))
(module+ test (module+ test
(define cache (make-cache)) (define cache (make-cache))
@ -94,7 +91,7 @@
;; Sorts l according to index and removes the entries with duplicate ;; Sorts l according to index and removes the entries with duplicate
;; indexes. ;; indexes.
(define (do-simple-equiv l index) (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)) (remove-dups ordered index null))
(module+ test (module+ test

10
parser-tools/private-yacc/grammar.rkt
Unescape Escape View File

@ -88,11 +88,11 @@
;; print-item: LR-item -> ;; print-item: LR-item ->
(define (item->string it) (define (item->string it)
(define print-sym (λ (i) (define (print-sym i)
(let ((gs (vector-ref (prod-rhs (item-prod it)) i))) (define gs (vector-ref (prod-rhs (item-prod it)) i))
(cond (cond
((term? gs) (format "~a " (term-sym gs))) ((term? gs) (format "~a " (term-sym gs)))
(else (format "~a " (non-term-sym gs))))))) (else (format "~a " (non-term-sym gs)))))
(string-append (string-append
(format "~a -> " (non-term-sym (prod-lhs (item-prod it)))) (format "~a -> " (non-term-sym (prod-lhs (item-prod it))))
(let loop ((i 0)) (let loop ((i 0))

15
parser-tools/private-yacc/graph.rkt
Unescape Escape View File

@ -31,14 +31,13 @@
(define d (depth)) (define d (depth))
(set-N x d) (set-N x d)
(hash-set! results x (f- x)) (hash-set! results x (f- x))
(for-each (λ (y) (for ([y (in-list (edges x))])
(when (= 0 (get-N y)) (when (= 0 (get-N y))
(traverse y)) (traverse y))
(hash-set! results (hash-set! results
x x
(union (f x) (f y))) (union (f x) (f y)))
(set-N x (min (get-N x) (get-N y)))) (set-N x (min (get-N x) (get-N y))))
(edges x))
(when (= d (get-N x)) (when (= d (get-N x))
(let loop ([p (pop)]) (let loop ([p (pop)])
(set-N p +inf.0) (set-N p +inf.0)

11
parser-tools/private-yacc/input-file-parser.rkt
Unescape Escape View File

@ -219,12 +219,11 @@
p p
#f #f
(let loop ([i (sub1 (vector-length p))]) (let loop ([i (sub1 (vector-length p))])
(if (>= i 0) (and (>= i 0)
(let ([gs (vector-ref p i)]) (let ([gs (vector-ref p i)])
(if (term? gs) (if (term? gs)
(term-prec gs) (term-prec gs)
(loop (sub1 i)))) (loop (sub1 i))))))
#f))
(parse-action #'PROD-RHS #'ACTION)))] (parse-action #'PROD-RHS #'ACTION)))]
[(PROD-RHS (PREC TERM) ACTION) [(PROD-RHS (PREC TERM) ACTION)
(identifier? #'TERM) (identifier? #'TERM)

51
parser-tools/private-yacc/lalr.rkt
Unescape Escape View File

@ -140,35 +140,29 @@
(printf "~a:\n" name) (printf "~a:\n" name)
(send a for-each-state (send a for-each-state
(λ (state) (λ (state)
(for-each (for ([non-term (in-list (send g get-non-terms))])
(λ (non-term) (define res (f (trans-key state non-term)))
(let ([res (f (trans-key state non-term))]) (when (not (null? res))
(when (not (null? res)) (printf "~a(~a, ~a) = ~a\n"
(printf "~a(~a, ~a) = ~a\n" name
name state
state (gram-sym-symbol non-term)
(gram-sym-symbol non-term) (print-output res))))))
(print-output res)))))
(send g get-non-terms))))
(newline)) (newline))
(define (print-input-st-prod f name a g print-output) (define (print-input-st-prod f name a g print-output)
(printf "~a:\n" name) (printf "~a:\n" name)
(send a for-each-state (send a for-each-state
(λ (state) (λ (state)
(for-each (for ([non-term (in-list (send g get-non-terms))])
(λ (non-term) (for ([prod (in-list (send g get-prods-for-non-term non-term))])
(for-each (define res (f state prod))
(λ (prod) (when (not (null? res))
(let ([res (f state prod)]) (printf "~a(~a, ~a) = ~a\n"
(when (not (null? res)) name
(printf "~a(~a, ~a) = ~a\n" (kernel-index state)
name (prod-index prod)
(kernel-index state) (print-output res))))))))
(prod-index prod)
(print-output res)))))
(send g get-prods-for-non-term non-term)))
(send g get-non-terms)))))
(define (print-output-terms r) (define (print-output-terms r)
(map gram-sym-symbol r)) (map gram-sym-symbol r))
@ -232,12 +226,11 @@
(let ([d (depth)]) (let ([d (depth)])
(set-N x d) (set-N x d)
(set-f x (f- x)) (set-f x (f- x))
(for-each (λ (y) (for ([y (in-list (edges x))])
(when (= 0 (get-N y)) (when (= 0 (get-N y))
(traverse y)) (traverse y))
(set-f x (bitwise-ior (get-f x) (get-f y))) (set-f x (bitwise-ior (get-f x) (get-f y)))
(set-N x (min (get-N x) (get-N y)))) (set-N x (min (get-N x) (get-N y))))
(edges x))
(when (= d (get-N x)) (when (= d (get-N x))
(let loop ([p (pop)]) (let loop ([p (pop)])
(set-N p +inf.0) (set-N p +inf.0)

12
parser-tools/private-yacc/lr0.rkt
Unescape Escape View File

@ -30,13 +30,13 @@
(cond (cond
[(null? sorted) null] [(null? sorted) null]
[(null? (cdr sorted)) sorted] [(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 [else
(if (and (= (non-term-index (trans-key-gs (car sorted))) (cons (car sorted) (loop (cdr 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))))])))
;; build-transition-table : int (listof (cons/c trans-key X) -> ;; build-transition-table : int (listof (cons/c trans-key X) ->

28
parser-tools/private-yacc/table.rkt
Unescape Escape View File

@ -147,13 +147,13 @@
(define RR-conflicts 0) (define RR-conflicts 0)
(define table (table-map (define table (table-map
(λ (gs actions) (λ (gs actions)
(let-values ([(action SR? RR?) (define-values (action SR? RR?)
(resolve-conflict actions)]) (resolve-conflict actions))
(when SR? (when SR?
(set! SR-conflicts (add1 SR-conflicts))) (set! SR-conflicts (add1 SR-conflicts)))
(when RR? (when RR?
(set! RR-conflicts (add1 RR-conflicts))) (set! RR-conflicts (add1 RR-conflicts)))
action)) action)
grouped-table)) grouped-table))
(unless suppress (unless suppress
(when (> SR-conflicts 0) (when (> SR-conflicts 0)
@ -237,15 +237,11 @@
(bit-vector-for-each (bit-vector-for-each
(λ (term-index) (λ (term-index)
(unless (start-item? item) (unless (start-item? item)
(let ((r (hash-ref reduce-cache item-prod (define r (hash-ref! reduce-cache item-prod (λ () (reduce item-prod))))
(λ () (table-add! table
(let ((r (reduce item-prod))) (kernel-index state)
(hash-set! reduce-cache item-prod r) (vector-ref term-vector term-index)
r))))) r)))
(table-add! table
(kernel-index state)
(vector-ref term-vector term-index)
r))))
(get-lookahead state item-prod)))))) (get-lookahead state item-prod))))))
(define grouped-table (resolve-prec-conflicts table)) (define grouped-table (resolve-prec-conflicts table))

4
parser-tools/yacc-to-scheme.rkt
Unescape Escape View File

@ -115,8 +115,8 @@
(begin0 (begin0
(let ([gram ((parse-grammar enter-term enter-empty-term enter-non-term) (let ([gram ((parse-grammar enter-term enter-empty-term enter-non-term)
(λ () (λ ()
(let ((t (get-token-grammar i))) (define t (get-token-grammar i))
t)))]) t))])
`(begin `(begin
(define-tokens t ,(sort (hash-map terms (λ (k v) k)) symbol<?)) (define-tokens t ,(sort (hash-map terms (λ (k v) k)) symbol<?))
(define-empty-tokens et ,(sort (hash-map eterms (λ (k v) k)) symbol<?)) (define-empty-tokens et ,(sort (hash-map eterms (λ (k v) k)) symbol<?))

222
parser-tools/yacc.rkt
Unescape Escape View File

@ -78,14 +78,14 @@
(for ([sym (in-list symbols)] (for ([sym (in-list symbols)]
#:unless (identifier? sym)) #:unless (identifier? sym))
(raise-syntax-error #f "End token must be a symbol" stx sym)) (raise-syntax-error #f "End token must be a symbol" stx sym))
(let ([d (duplicate-list? (map syntax-e symbols))]) (define d (duplicate-list? (map syntax-e symbols)))
(when d (when d
(raise-syntax-error #f (format "Duplicate end token definition for ~a" d) stx arg)) (raise-syntax-error #f (format "Duplicate end token definition for ~a" d) stx arg))
(when (null? symbols) (when (null? symbols)
(raise-syntax-error #f "end declaration must contain at least 1 token" stx arg)) (raise-syntax-error #f "end declaration must contain at least 1 token" stx arg))
(when end (when end
(raise-syntax-error #f "Multiple end declarations" stx)) (raise-syntax-error #f "Multiple end declarations" stx))
(set! end symbols)))] (set! end symbols))]
[(precs DECLS ...) [(precs DECLS ...)
(if precs (if precs
(raise-syntax-error #f "Multiple precs declarations" stx) (raise-syntax-error #f "Multiple precs declarations" stx)
@ -113,38 +113,38 @@
(raise-syntax-error #f "missing end declaration" stx)) (raise-syntax-error #f "missing end declaration" stx))
(unless start (unless start
(raise-syntax-error #f "missing start declaration" stx)) (raise-syntax-error #f "missing start declaration" stx))
(let-values ([(table all-term-syms actions check-syntax-fix) (define-values (table all-term-syms actions check-syntax-fix)
(build-parser (if debug debug "") (build-parser (if debug debug "")
src-pos src-pos
suppress suppress
tokens tokens
start start
end end
precs precs
grammar)]) grammar))
(when (and yacc-output (not (string=? yacc-output ""))) (when (and yacc-output (not (string=? yacc-output "")))
(with-handlers [(exn:fail:filesystem? (with-handlers [(exn:fail:filesystem?
(λ (e) (eprintf "Cannot write yacc-output to file \"~a\"\n" yacc-output)))] (λ (e) (eprintf "Cannot write yacc-output to file \"~a\"\n" yacc-output)))]
(call-with-output-file yacc-output (call-with-output-file yacc-output
(λ (port) (λ (port)
(display-yacc (syntax->datum grammar) (display-yacc (syntax->datum grammar)
tokens tokens
(map syntax->datum start) (map syntax->datum start)
(and precs (syntax->datum precs)) (and precs (syntax->datum precs))
port)) port))
#:exists 'truncate))) #:exists 'truncate)))
(with-syntax ([check-syntax-fix check-syntax-fix] (with-syntax ([check-syntax-fix check-syntax-fix]
[err error] [err error]
[ends end] [ends end]
[starts start] [starts start]
[debug debug] [debug debug]
[table (convert-parse-table table)] [table (convert-parse-table table)]
[all-term-syms all-term-syms] [all-term-syms all-term-syms]
[actions actions] [actions actions]
[src-pos src-pos]) [src-pos src-pos])
#'(begin #'(begin
check-syntax-fix check-syntax-fix
(parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos)))))] (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)])) [_ (raise-syntax-error #f "parser must have the form (parser args ...)" stx)]))
(define (reduce-stack stack num ret-vals src-pos) (define (reduce-stack stack num ret-vals src-pos)
@ -237,31 +237,29 @@
stack)] stack)]
[else [else
;; (printf "discard input:~a\n" tok) ;; (printf "discard input:~a\n" tok)
(let-values ([(tok val start-pos end-pos) (call-with-values (λ () (extract (get-token))) remove-input)])))))
(extract (get-token))])
(remove-input tok val start-pos end-pos))])))))
(let remove-states () (let remove-states ()
(let ([a (find-action stack 'error #f start-pos end-pos)]) (define a (find-action stack 'error #f start-pos end-pos))
(cond (cond
[(runtime-shift? a) [(runtime-shift? a)
;; (printf "shift:~a\n" (runtime-shift-state a)) ;; (printf "shift:~a\n" (runtime-shift-state a))
(set! stack (set! stack
(cons (cons
(stack-frame (runtime-shift-state a) (stack-frame (runtime-shift-state a)
#f #f
start-pos start-pos
end-pos) end-pos)
stack)) stack))
(remove-input tok val start-pos end-pos)] (remove-input tok val start-pos end-pos)]
[else [else
;; (printf "discard state:~a\n" (car stack)) ;; (printf "discard state:~a\n" (car stack))
(cond (cond
[(< (length stack) 2) [(< (length stack) 2)
(raise-read-error "parser: Cannot continue after error" (raise-read-error "parser: Cannot continue after error"
#f #f #f #f #f)] #f #f #f #f #f)]
[else [else
(set! stack (cdr stack)) (set! stack (cdr stack))
(remove-states)])]))))) (remove-states)])]))))
(define (find-action stack tok val start-pos end-pos) (define (find-action stack tok val start-pos end-pos)
(unless (hash-ref all-term-syms tok #f) (unless (hash-ref all-term-syms tok #f)
@ -278,55 +276,55 @@
(error 'get-token "expected a nullary procedure, got ~e" get-token)) (error 'get-token "expected a nullary procedure, got ~e" get-token))
(let parsing-loop ([stack (make-empty-stack start-number)] (let parsing-loop ([stack (make-empty-stack start-number)]
[ip (get-token)]) [ip (get-token)])
(let-values ([(tok val start-pos end-pos) (extract ip)]) (define-values (tok val start-pos end-pos) (extract ip))
(let ([action (find-action stack tok val start-pos end-pos)]) (define action (find-action stack tok val start-pos end-pos))
(cond (cond
[(runtime-shift? action) [(runtime-shift? action)
;; (printf "shift:~a\n" (runtime-shift-state action)) ;; (printf "shift:~a\n" (runtime-shift-state action))
(parsing-loop (cons (stack-frame (runtime-shift-state action) (parsing-loop (cons (stack-frame (runtime-shift-state action)
val val
start-pos start-pos
end-pos) end-pos)
stack) stack)
(get-token))] (get-token))]
[(runtime-reduce? action) [(runtime-reduce? action)
;; (printf "reduce:~a\n" (runtime-reduce-prod-num action)) ;; (printf "reduce:~a\n" (runtime-reduce-prod-num action))
(let-values ([(new-stack args) (let-values ([(new-stack args)
(reduce-stack stack (reduce-stack stack
(runtime-reduce-rhs-length action) (runtime-reduce-rhs-length action)
null null
src-pos)]) src-pos)])
(let ([goto (define goto
(runtime-goto-state (runtime-goto-state
(hash-ref (hash-ref
(vector-ref table (stack-frame-state (car new-stack))) (vector-ref table (stack-frame-state (car new-stack)))
(runtime-reduce-lhs action)))]) (runtime-reduce-lhs action))))
(parsing-loop (parsing-loop
(cons (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
(if src-pos (if src-pos
(err #t tok val start-pos end-pos) (stack-frame
(err #t tok val)) goto
(parsing-loop (fix-error stack tok val start-pos end-pos get-token) (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
(get-token))])))))) (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 (cond
[(null? (cdr starts)) (make-parser 0)] [(null? (cdr starts)) (make-parser 0)]
[else [else

4
private/colorer.rkt
Unescape Escape View File

@ -38,8 +38,8 @@
(define-syntax-rule (values->list EXPR) (call-with-values (λ () EXPR) list)) (define-syntax-rule (values->list EXPR) (call-with-values (λ () EXPR) list))
(define (apply-colorer str) (define (apply-colorer str)
(for/list ([annotation (in-port (λ (p) (for/list ([annotation (in-port (λ (p)
(let ([xs (values->list (color-brag p))]) (define xs (values->list (color-brag p)))
(if (eof-object? (car xs)) eof xs))) (if (eof-object? (car xs)) eof xs))
(open-input-string str))]) (open-input-string str))])
annotation)) annotation))

11
rules/parser.rkt
Unescape Escape View File

@ -169,7 +169,7 @@
[(list all min range? max) (let* ([min (if min (string->number min) 0)] [(list all min range? max) (let* ([min (if min (string->number min) 0)]
[max (cond [max (cond
[(and range? max) (string->number max)] [(and range? max) (string->number max)]
[(and (not range?) (not max)) (if (zero? min) [(not (or range? max)) (if (zero? min)
#f ; {} -> {0,} #f ; {} -> {0,}
min)] ; {3} -> {3,3} min)] ; {3} -> {3,3}
[else #f])]) [else #f])])
@ -298,8 +298,7 @@
(pos-line start-pos) (pos-line start-pos)
(pos-col start-pos) (pos-col start-pos)
(pos-offset start-pos) (pos-offset start-pos)
(if (and (number? (pos-offset end-pos)) (and (and (number? (pos-offset end-pos))
(number? (pos-offset start-pos))) (number? (pos-offset start-pos)))
(- (pos-offset end-pos) (- (pos-offset end-pos)
(pos-offset start-pos)) (pos-offset start-pos))))))))))
#f))))))))

18
rules/stx.rkt
Unescape Escape View File

@ -14,21 +14,19 @@
(pos-line (lhs-id-start (rule-lhs a-rule))) (pos-line (lhs-id-start (rule-lhs a-rule)))
(pos-col (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))) (pos-offset (lhs-id-start (rule-lhs a-rule)))
(if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule)))) (and (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
(number? (pos-offset (lhs-id-end (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-end (rule-lhs a-rule)))
(pos-offset (lhs-id-start (rule-lhs a-rule)))) (pos-offset (lhs-id-start (rule-lhs a-rule)))))))
#f)))
'hide-or-splice-lhs-id (lhs-id-splice (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 pattern-stx (pattern->stx source (rule-pattern a-rule)))
(define line (pos-line (rule-start a-rule))) (define line (pos-line (rule-start a-rule)))
(define column (pos-col (rule-start a-rule))) (define column (pos-col (rule-start a-rule)))
(define position (pos-offset (rule-start a-rule))) (define position (pos-offset (rule-start a-rule)))
(define span (if (and (number? (pos-offset (rule-start a-rule))) (define span (and (and (number? (pos-offset (rule-start a-rule)))
(number? (pos-offset (rule-end a-rule)))) (number? (pos-offset (rule-end a-rule))))
(- (pos-offset (rule-end a-rule)) (- (pos-offset (rule-end a-rule))
(pos-offset (rule-start a-rule))) (pos-offset (rule-start a-rule)))))
#f))
(datum->syntax #f (datum->syntax #f
`(rule ,id-stx ,pattern-stx) `(rule ,id-stx ,pattern-stx)
(list source line column position span))) (list source line column position span)))

8
tests/test-flatten.rkt
Unescape Escape View File

@ -8,10 +8,10 @@
(define (make-fresh-name) (define (make-fresh-name)
(let ([n 0]) (define n 0)
(lambda () (lambda ()
(set! n (add1 n)) (set! n (add1 n))
(string->symbol (format "r~a" n))))) (string->symbol (format "r~a" n))))
;; Simple literals ;; Simple literals

6
token.rkt
Unescape Escape View File

@ -46,16 +46,16 @@
'token 'token
(λ (this) (λ (this)
(append (list (token-type 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) (if (token-location this)
(list (list
(sequence-markup (sequence-markup
(list (unquoted-printing-string "#:location") (token-location this)))) (list (unquoted-printing-string "#:location") (token-location this))))
(list)) '())
(if (token-skip? this) (if (token-skip? this)
(list (list
(sequence-markup (list (unquoted-printing-string "#:skip?") (token-skip? this)))) (sequence-markup (list (unquoted-printing-string "#:skip?") (token-skip? this))))
(list))))))]) '())))))])
(define (source-location #:source [source #false] (define (source-location #:source [source #false]

Write Preview
Loading…
Cancel
Save