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

8
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

5
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.

47
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]
[else
(bound-identifier-mapping-put! nts nt new) (bound-identifier-mapping-put! nts nt new)
#t))))) #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,21 +522,21 @@
(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)])
@ -555,24 +554,24 @@
(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
(filter (λ (id)
(andmap (λ (id2) (andmap (λ (id2)
(not (eq? id id2))) (not (eq? id id2)))
(cdr old-list))) (cdr old-list)))
new-list)]) new-list))
(if (pair? new) (if (pair? new)
;; Drop dups in new list: ;; Drop dups in new list:
(let ([new (let loop ([new new]) (let ([new (let loop ([new new])
(if (null? (cdr new)) (cond
new [(null? (cdr new)) new]
(if (ormap (λ (id) [(ormap (λ (id)
(eq? (car new) id)) (eq? (car new) id))
(cdr new)) (cdr new)) (loop (cdr new))]
(loop (cdr new)) [else (cons (car new) (loop (cdr new)))]))])
(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)

4
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))]))

10
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,9 +351,7 @@
(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 ()
[(_ ID ...)
(begin (begin
(define-syntax-parameter ID (define-syntax-parameter ID
(make-set!-transformer (make-set!-transformer
@ -363,6 +361,6 @@
(format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID) (format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID)
stx)))) 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)

8
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))

8
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 ()
((_ l e ...)
(begin (begin
(printf "~a: " l) (printf "~a: " l)
(time (begin e ...)))))) (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)))

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

@ -36,12 +36,12 @@
(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)
[_ [_
@ -92,11 +92,11 @@
(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))
@ -115,7 +115,7 @@
(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)])))

9
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

6
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))

3
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)

5
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)

23
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)
(let ([res (f state prod)])
(when (not (null? res)) (when (not (null? res))
(printf "~a(~a, ~a) = ~a\n" (printf "~a(~a, ~a) = ~a\n"
name name
(kernel-index state) (kernel-index state)
(prod-index prod) (prod-index prod)
(print-output res))))) (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)

8
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]
[else [(and (= (non-term-index (trans-key-gs (car sorted)))
(if (and (= (non-term-index (trans-key-gs (car sorted)))
(non-term-index (trans-key-gs (cadr sorted)))) (non-term-index (trans-key-gs (cadr sorted))))
(= (kernel-index (trans-key-st (car sorted))) (= (kernel-index (trans-key-st (car sorted)))
(kernel-index (trans-key-st (cadr sorted))))) (kernel-index (trans-key-st (cadr sorted)))))
(loop (cdr sorted)) (loop (cdr sorted))]
(cons (car sorted) (loop (cdr sorted))))]))) [else
(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) ->

14
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))))
(λ ()
(let ((r (reduce item-prod)))
(hash-set! reduce-cache item-prod r)
r)))))
(table-add! table (table-add! table
(kernel-index state) (kernel-index state)
(vector-ref term-vector term-index) (vector-ref term-vector term-index)
r)))) 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<?))

30
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,7 +113,7 @@
(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
@ -121,7 +121,7 @@
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)))]
@ -144,7 +144,7 @@
[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,11 +237,9 @@
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))
@ -261,7 +259,7 @@
#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,8 +276,8 @@
(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))
@ -296,11 +294,11 @@
(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 (if src-pos
@ -317,7 +315,7 @@
#f #f
#f)) #f))
new-stack) new-stack)
ip)))] ip))]
[(runtime-accept? action) [(runtime-accept? action)
;; (printf "accept\n") ;; (printf "accept\n")
(stack-frame-value (car stack))] (stack-frame-value (car stack))]
@ -326,7 +324,7 @@
(err #t tok val start-pos end-pos) (err #t tok val start-pos end-pos)
(err #t tok val)) (err #t tok val))
(parsing-loop (fix-error stack tok val start-pos end-pos get-token) (parsing-loop (fix-error stack tok val start-pos end-pos get-token)
(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))

7
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))))))))

10
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)))

4
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