From 68e805029f65970efe75761863f8abd4dd32a4b4 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 23 Sep 2009 04:27:14 +0000 Subject: [PATCH] syntax/parse: added disappeared-use properties svn: r16113 --- collects/syntax/private/stxparse/parse.ss | 74 ++++++++++++----------- collects/syntax/private/stxparse/rep.ss | 70 ++++++++++++++++----- 2 files changed, 92 insertions(+), 52 deletions(-) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index dea714cfd3..3f77edd171 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -5,6 +5,7 @@ syntax/stx syntax/id-table syntax/keyword + syntax/private/util/misc "rep-data.ss" "rep.ss" "codegen-data.ss" @@ -137,42 +138,43 @@ (define-syntax (parse:clauses stx) (syntax-case stx () [(parse:clauses x clauses ctx) - (let () - (define-values (chunks clauses-stx) - (parse-keyword-options #'clauses parse-directive-table - #:context #'ctx - #:no-duplicates? #t)) - (define context - (options-select-value chunks '#:context #:default #'x)) - (define-values (decls0 defs) - (get-decls+defs chunks #t #:context #'ctx)) - (define (for-clause clause) - (syntax-case clause () - [[p . rest] - (let-values ([(rest decls2 defs2 sides) - (parse-pattern-directives #'rest - #:allow-declare? #t - #:decls decls0 - #:context #'ctx)]) - (with-syntax ([rest rest] - [fc (empty-frontier #'x)] - [pattern - (parse-whole-pattern #'p decls2 #:context #'ctx)] - [(local-def ...) defs2]) - #`(let () - local-def ... - (parse:S x fc pattern - (convert-sides x #,sides - (clause-success () (let () . rest)))))))])) - (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx)) - (raise-syntax-error #f "expected non-empty sequence of clauses" stx)) - (with-syntax ([(def ...) defs] - [(alternative ...) - (map for-clause (stx->list clauses-stx))]) - #`(let ([fail (syntax-patterns-fail #,context)]) - def ... - (with-enclosing-fail* fail - (try alternative ...)))))])) + (with-disappeared-uses + (let () + (define-values (chunks clauses-stx) + (parse-keyword-options #'clauses parse-directive-table + #:context #'ctx + #:no-duplicates? #t)) + (define context + (options-select-value chunks '#:context #:default #'x)) + (define-values (decls0 defs) + (get-decls+defs chunks #t #:context #'ctx)) + (define (for-clause clause) + (syntax-case clause () + [[p . rest] + (let-values ([(rest decls2 defs2 sides) + (parse-pattern-directives #'rest + #:allow-declare? #t + #:decls decls0 + #:context #'ctx)]) + (with-syntax ([rest rest] + [fc (empty-frontier #'x)] + [pattern + (parse-whole-pattern #'p decls2 #:context #'ctx)] + [(local-def ...) defs2]) + #`(let () + local-def ... + (parse:S x fc pattern + (convert-sides x #,sides + (clause-success () (let () . rest)))))))])) + (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx)) + (raise-syntax-error #f "expected non-empty sequence of clauses" stx)) + (with-syntax ([(def ...) defs] + [(alternative ...) + (map for-clause (stx->list clauses-stx))]) + #`(let ([fail (syntax-patterns-fail #,context)]) + def ... + (with-enclosing-fail* fail + (try alternative ...))))))])) (define-for-syntax (wash-literal stx) (syntax-case stx () diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 6b8162f61b..d22ce083df 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -7,6 +7,7 @@ syntax/id-table syntax/stx syntax/keyword + syntax/private/util/misc "../util.ss" "rep-data.ss" "codegen-data.ss") @@ -63,7 +64,8 @@ (define (id-predicate kw) (lambda (stx) (and (identifier? stx) - (free-identifier=? stx kw)))) + (free-identifier=? stx kw) + (begin (disappeared! stx) #t)))) (define wildcard? (id-predicate (quote-syntax _))) (define epsilon? (id-predicate (quote-syntax ||))) @@ -102,6 +104,18 @@ ;; --- +(define (disappeared! x) + (cond [(identifier? x) + (record-disappeared-uses (list x))] + [(and (stx-pair? x) (identifier? (stx-car x))) + (record-disappeared-uses (list (stx-car x)))] + [else + (raise-type-error 'disappeared! + "identifier or syntax with leading identifier" + x)])) + +;; --- + ;; parse-rhs : stx boolean boolean stx -> RHS ;; If strict? is true, then referenced stxclasses must be defined and ;; literals must be bound. Set to #f for pass1 (attr collection); @@ -141,8 +155,9 @@ (define (gather-patterns stx) (syntax-case stx (pattern) [((pattern . _) . rest) - (cons (parse-variant (stx-car stx) splicing? decls) - (gather-patterns #'rest))] + (begin (disappeared! (stx-car stx)) + (cons (parse-variant (stx-car stx) splicing? decls) + (gather-patterns #'rest)))] [(bad-variant . rest) (wrong-syntax #'bad-variant "expected syntax-class variant")] [() @@ -167,13 +182,14 @@ (new-declenv literals #:conventions convention-rules)) (define (check-literals-bound lits strict?) + (define phase (syntax-local-phase-level)) (when strict? (for ([p lits]) ;; FIXME: hack... - (unless (or (identifier-binding (cadr p) 0) - (identifier-binding (cadr p) 1) - (identifier-binding (cadr p) #f) - (identifier-binding (cadr p) (syntax-local-phase-level))) + (unless (or (identifier-binding (cadr p) phase) + (identifier-binding (cadr p) (add1 phase)) + (identifier-binding (cadr p) (sub1 phase)) + (identifier-binding (cadr p) #f)) (wrong-syntax (cadr p) "unbound identifier not allowed as literal")))) lits) @@ -222,6 +238,7 @@ (parse-pattern-directives #'rest #:allow-declare? #t #:decls decls0)]) + (disappeared! stx) (unless (stx-null? rest) (wrong-syntax (if (pair? rest) (car rest) rest) "unexpected terms after pattern directives")) @@ -284,8 +301,10 @@ ~seq ~optional ~! ~bind ~fail ~parse) [wildcard (wildcard? #'wildcard) - (create-pat:any)] + (begin (disappeared! stx) + (create-pat:any))] [~! + (disappeared! stx) (check-ghost! (create-ghost:cut))] [reserved @@ -298,37 +317,50 @@ (atomic-datum? #'datum) (create-pat:datum (syntax->datum #'datum))] [(~var . rest) + (disappeared! stx) (parse-pat:var stx decls allow-head?)] [(~literal . rest) + (disappeared! stx) (parse-pat:literal stx decls)] [(~and . rest) + (disappeared! stx) (parse-pat:and stx decls allow-head? allow-ghost?)] [(~or . rest) + (disappeared! stx) (parse-pat:or stx decls allow-head?)] [(~not . rest) + (disappeared! stx) (parse-pat:not stx decls)] [(~rest . rest) + (disappeared! stx) (parse-pat:rest stx decls)] [(~describe . rest) + (disappeared! stx) (parse-pat:describe stx decls allow-head?)] [(~seq . rest) + (disappeared! stx) (check-head! (parse-hpat:seq stx #'rest decls))] [(~optional . rest) + (disappeared! stx) (check-head! (parse-hpat:optional stx decls))] [(~bind . rest) + (disappeared! stx) (check-ghost! (parse-pat:bind stx decls))] [(~fail . rest) + (disappeared! stx) (check-ghost! (parse-pat:fail stx decls))] [(~parse . rest) + (disappeared! stx) (check-ghost! (parse-pat:parse stx decls))] [(head dots . tail) (dots? #'dots) - (parse-pat:dots stx #'head #'tail decls)] + (begin (disappeared! #'dots) + (parse-pat:dots stx #'head #'tail decls))] [(head . tail) (let ([headp (parse-*-pattern #'head decls #t #t)] [tailp (parse-single-pattern #'tail decls)]) @@ -360,10 +392,13 @@ (define (parse-ellipsis-head-pattern stx decls) (syntax-case stx (~bounds ~optional ~once) [(~optional . _) + (disappeared! stx) (parse-ehpat/optional stx decls)] [(~once . _) + (disappeared! stx) (parse-ehpat/once stx decls)] [(~bounds . _) + (disappeared! stx) (parse-ehpat/bounds stx decls)] [_ (let ([head (parse-head-pattern stx decls)]) @@ -867,7 +902,8 @@ (identifier? #'id) (list #'id #'id)] [_ - (raise-syntax-error #f "expected literal (identifier or pair of identifiers)" ctx stx)])) + (raise-syntax-error #f "expected literal (identifier or pair of identifiers)" + ctx stx)])) (define (check-literal-sets-list stx ctx) (unless (stx-list? stx) @@ -877,9 +913,10 @@ (define (check-literal-set-entry stx ctx) (define (elaborate litset-id lctx) - (let ([litset (syntax-local-value litset-id (lambda () #f))]) - (unless (literalset? litset) - (raise-syntax-error #f "expected identifier defined as a literal-set" ctx litset-id)) + (let ([litset (syntax-local-value/catch litset-id literalset?)]) + (unless litset + (raise-syntax-error #f "expected identifier defined as a literal-set" + ctx litset-id)) (elaborate-litset litset lctx stx))) (syntax-case stx () [(litset #:at lctx) @@ -904,9 +941,10 @@ (define (check-conventions stx ctx) (define (elaborate conventions-id) - (let ([cs (syntax-local-value conventions-id (lambda () #f))]) - (unless (conventions? cs) - (raise-syntax-error #f "expected identifier defined as a conventions" ctx conventions-id)) + (let ([cs (syntax-local-value/catch conventions-id conventions?)]) + (unless cs + (raise-syntax-error #f "expected identifier defined as a conventions" + ctx conventions-id)) (conventions-rules cs))) (syntax-case stx () [conventions