diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 15f36b0..07a2b93 100644 --- a/collects/parser-tools/lex.ss +++ b/collects/parser-tools/lex.ss @@ -85,7 +85,7 @@ ids))) (_ #t))) spec/re-act-lst))) - (let-values (((trans start actions no-look) + (let-values (((trans start actions no-look disappeared-uses) (build-lexer re-act-lst))) (with-syntax ((start-state-stx start) (trans-table-stx trans) @@ -104,17 +104,20 @@ (wrap-action spec-comment-act)) (eof-act-stx (wrap-action eof-act)) (wrap? wrap?)) - (syntax - (lexer-body start-state-stx - trans-table-stx - actions-stx - no-lookahead-stx - spec-act-stx - spec-error-act-stx - has-comment-act?-stx - spec-comment-act-stx - eof-act-stx - wrap?)))))))))) + (syntax-property + (syntax/loc stx + (lexer-body start-state-stx + trans-table-stx + actions-stx + no-lookahead-stx + spec-act-stx + spec-error-act-stx + has-comment-act?-stx + spec-comment-act-stx + eof-act-stx + wrap?)) + 'disappeared-use + disappeared-uses))))))))) (define-syntax lexer (make-lexer-trans #f)) (define-syntax lexer-src-pos (make-lexer-trans #t)) @@ -123,7 +126,7 @@ (syntax-case stx () ((_ name re) (identifier? (syntax name)) - (syntax + (syntax/loc stx (define-syntax name (make-lex-abbrev (quote-syntax re))))) (_ @@ -141,7 +144,7 @@ (syntax-case a () ((name re) (identifier? (syntax name)) - (syntax (define-lex-abbrev name re))) + (syntax/loc a (define-lex-abbrev name re))) (_ (raise-syntax-error #f "form should be (define-lex-abbrevs (name re) ...)" diff --git a/collects/parser-tools/private-lex/actions.ss b/collects/parser-tools/private-lex/actions.ss index e334cd5..dfbeeae 100644 --- a/collects/parser-tools/private-lex/actions.ss +++ b/collects/parser-tools/private-lex/actions.ss @@ -1,6 +1,6 @@ (module actions mzscheme (provide (all-defined)) - (require (lib "stx.ss" "syntax")) + ;(require (lib "stx.ss" "syntax")) ;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object ;; Returns the first action from a rule of the form ((which-special) action) diff --git a/collects/parser-tools/private-lex/front.ss b/collects/parser-tools/private-lex/front.ss index 417cafd..6e74b95 100644 --- a/collects/parser-tools/private-lex/front.ss +++ b/collects/parser-tools/private-lex/front.ss @@ -126,11 +126,13 @@ ((dfa->no-look d1) (vector #t)) ((dfa->no-look d2) (vector #t #f #f #t))) - ;; build-lexer : syntax-object list -> (values table nat (vector-of (union #f syntax-object)) (vector-of bool)) + ;; build-lexer : syntax-object list -> + ;; (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) - (let* ((s-re-acts (map (lambda (so) - (cons (parse (car (syntax->list so))) + (let* ((disappeared-uses (box null)) + (s-re-acts (map (lambda (so) + (cons (parse (car (syntax->list so)) disappeared-uses) (cadr (syntax->list so)))) sos)) @@ -144,5 +146,6 @@ (dfa (build-dfa re-acts cache))) ;(print-dfa dfa) ;(printf "states: ~a~n" (dfa-num-states dfa)) - (values (dfa->1d-table dfa) (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa)))) + (values (dfa->1d-table dfa) (dfa-start-state dfa) (dfa->actions dfa) (dfa->no-look dfa) + (unbox disappeared-uses)))) ) diff --git a/collects/parser-tools/private-lex/stx.ss b/collects/parser-tools/private-lex/stx.ss index f9975f7..04b5dbc 100644 --- a/collects/parser-tools/private-lex/stx.ss +++ b/collects/parser-tools/private-lex/stx.ss @@ -1,5 +1,6 @@ (module stx mzscheme - (require "util.ss") + (require (lib "boundmap.ss" "syntax") + "util.ss") (provide parse) @@ -28,10 +29,13 @@ ((char-range-arg #'"1" #'here) (char->integer #\1))) - ;; parse : syntax-object -> s-re (see re.ss) + ;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.ss) ;; checks for errors and generates the plain s-exp form for s ;; Expands lex-abbrevs and applies lex-trans. - (define (parse stx) + (define (parse stx disappeared-uses) + (let ((parse + (lambda (stx) + (parse stx disappeared-uses)))) (syntax-case stx (repetition union intersection complement concatenation char-range char-complement) (_ @@ -41,6 +45,7 @@ (raise-syntax-error 'regular-expression "undefined abbreviation" stx)) + (set-box! disappeared-uses (cons stx (unbox disappeared-uses))) (parse (lex-abbrev-abbrev expansion)))) (_ (or (char? (syntax-e stx)) (string? (syntax-e stx))) @@ -105,7 +110,9 @@ `(char-complement ,parsed)))) ((op form ...) (identifier? (syntax op)) - (let ((expansion (syntax-local-value (syntax op) (lambda () #f)))) + (let* ((o (syntax op)) + (expansion (syntax-local-value o (lambda () #f)))) + (set-box! disappeared-uses (cons o (unbox disappeared-uses))) (cond ((lex-trans? expansion) (parse ((lex-trans-f expansion) stx))) @@ -121,7 +128,7 @@ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" - stx)))) + stx)))))