Fixes Check Syntax arrows for lexer generator.

There was a bug in disappeared-use tracking--a missing
syntax-local-introduce. This change uses `with-disappeared-uses` and
`syntax-local-value/record`, instead of the (broken) manual tracking
that was present before.

I believe that non-BR parser-tools also has this bug, but I haven't
ported the fix yet.
pull/6/head
Jesse A. Tov 5 years ago
parent f8c3f37646
commit a1d0b422c8
No known key found for this signature in database
GPG Key ID: C5668BA5047AE6BD

@ -4,6 +4,7 @@
;; create and use the buffer that the lexer reads from. See docs.
(require (for-syntax racket/list
racket/syntax
syntax/stx
syntax/define
syntax/boundmap
@ -69,12 +70,20 @@
[input-port (make-rename-transformer #'input-port-p)]
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
action-stx)))))
(begin-for-syntax
; This macro only exists to keep the indentation below the same,
; in order to make the diff easier to read. So it probably makes
; sense to inline it after reading.
(define-syntax-rule (begin-with-disappeared-uses body0 body ...)
(with-disappeared-uses
(let () body0 body ...))))
(define-for-syntax (make-lexer-macro caller src-loc-style)
(λ (stx)
(syntax-case stx ()
[(_ . RE+ACTS)
(let ()
(begin-with-disappeared-uses
(define spec/re-acts (syntax->list #'RE+ACTS))
(for/and ([x (in-list spec/re-acts)])
(syntax-case x ()
@ -101,7 +110,7 @@
(define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names))
(when (null? spec/re-acts)
(raise-syntax-error caller "expected at least one action" stx))
(define-values (trans start action-names no-look disappeared-uses) (build-lexer re-actnames))
(define-values (trans start action-names no-look) (build-lexer re-actnames))
(when (vector-ref action-names start) ;; Start state is final
(unless (and
;; All the successor states are final
@ -130,19 +139,17 @@
[HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)]
[SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
[EOF-ACT-STX (wrap-action eof-act src-loc-style)])
(syntax-property
(syntax/loc stx (let ([NAME ACT] ...)
(let ([proc (lexer-body START-STATE-STX
TRANS-TABLE-STX
(vector ACT-NAME ...)
NO-LOOKAHEAD-STX
SPEC-ACT-STX
HAS-COMMENT-ACT?-STX
SPEC-COMMENT-ACT-STX
EOF-ACT-STX)])
;; reverse eta to get named procedures:
(λ (port) (proc port)))))
'disappeared-use disappeared-uses)))])))
(syntax/loc stx (let ([NAME ACT] ...)
(let ([proc (lexer-body START-STATE-STX
TRANS-TABLE-STX
(vector ACT-NAME ...)
NO-LOOKAHEAD-STX
SPEC-ACT-STX
HAS-COMMENT-ACT?-STX
SPEC-COMMENT-ACT-STX
EOF-ACT-STX)])
;; reverse eta to get named procedures:
(λ (port) (proc port)))))))])))
(define-syntax lexer (make-lexer-macro 'lexer #f))
(define-syntax lexer-src-pos (make-lexer-macro 'lexer-src-pos 'lexer-src-pos))

@ -125,9 +125,8 @@
;; (values table nat (vector-of (union #f syntax-object)) (vector-of bool) (list-of syntax-object))
;; each syntax object has the form (re action)
(define (build-lexer sos)
(define disappeared-uses (box null))
(define s-re-acts (for/list ([so (in-list sos)])
(cons (parse (stx-car so) disappeared-uses)
(cons (parse (stx-car so))
(stx-car (stx-cdr so)))))
(define cache (make-cache))
(define re-acts (for/list ([s-re-act (in-list s-re-acts)])
@ -156,6 +155,5 @@
num-states
(/ (* 4.0 (+ 2 num-states (* 2 num-vectors) num-entries
(* 5 num-different-entries))) 1024)))
(values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa)
(unbox disappeared-uses)))
(values table (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa)))

@ -1,5 +1,5 @@
#lang racket/base
(require "util.rkt" syntax/id-table)
(require "util.rkt" syntax/id-table racket/syntax)
(provide parse)
(define (bad-args stx num)
@ -32,24 +32,21 @@
;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt)
;; checks for errors and generates the plain s-exp form for s
;; Expands lex-abbrevs and applies lex-trans.
(define (parse stx disappeared-uses)
(define (parse stx)
(let loop ([stx stx]
[disappeared-uses disappeared-uses]
;; seen-lex-abbrevs: id-table
[seen-lex-abbrevs (make-immutable-free-id-table)])
(let ([recur (λ (s)
(loop (syntax-rearm s stx)
disappeared-uses
seen-lex-abbrevs))]
[recur/abbrev (λ (s id)
(loop (syntax-rearm s stx)
disappeared-uses
(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 stx (λ () #f))])
(let ([expansion (syntax-local-value/record stx (λ (v) #t))])
(unless (lex-abbrev? expansion)
(raise-syntax-error 'regular-expression
"undefined abbreviation"
@ -61,7 +58,6 @@
stx
#f
(list (free-id-table-ref seen-lex-abbrevs stx))))
(set-box! disappeared-uses (cons stx (unbox disappeared-uses)))
(recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))]
[_
(or (char? (syntax-e stx)) (string? (syntax-e stx)))
@ -111,8 +107,7 @@
`(char-complement ,parsed))]
((OP form ...)
(identifier? #'OP)
(let* ([expansion (syntax-local-value #'OP (λ () #f))])
(set-box! disappeared-uses (cons #'OP (unbox disappeared-uses)))
(let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))])
(cond
[(lex-trans? expansion)
(recur ((lex-trans-f expansion) (disarm stx)))]

Loading…
Cancel
Save