From 52bd998e5d52f755272a85d84659846b90a8da5e Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 11 Feb 2009 22:17:39 +0000 Subject: [PATCH] stxclass: added #:attributes, disappeared-uses svn: r13520 --- collects/stxclass/private/codegen.ss | 19 ++--- collects/stxclass/private/lib.ss | 2 +- collects/stxclass/private/rep-data.ss | 34 +++++---- collects/stxclass/private/rep.ss | 73 +++++++++++------- collects/stxclass/private/sc.ss | 40 +++++----- collects/stxclass/stxclass.scrbl | 106 ++++++++++++++------------ collects/stxclass/util/error.ss | 2 +- collects/stxclass/util/misc.ss | 30 ++++++++ 8 files changed, 187 insertions(+), 119 deletions(-) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index d552f8f6ef..0f56744759 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -86,15 +86,16 @@ (define (rhs-pattern->pks rhs relsattrs main-var) (match rhs [(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) - (list (make-pk (list pattern) - (expr:convert-sides sides - (pattern-attrs pattern) - main-var - (lambda (iattrs) - (expr:sc iattrs - relsattrs - remap - main-var)))))])) + (parameterize ((current-syntax-context orig-stx)) + (list (make-pk (list pattern) + (expr:convert-sides sides + (pattern-attrs pattern) + main-var + (lambda (iattrs) + (expr:sc iattrs + relsattrs + remap + main-var))))))])) ;; expr:convert-sides : (listof SideClause) (listof IAttr) id stx -> stx (define (expr:convert-sides sides iattrs main-var k) diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss index 4f509327bc..4a71dae7f0 100644 --- a/collects/stxclass/private/lib.ss +++ b/collects/stxclass/private/lib.ss @@ -65,8 +65,8 @@ (define-syntax-class (static-of name pred) #:description name + #:attributes ([value 0]) (basic-syntax-class - ([value 0]) (lambda (x name pred) (let/ec escape (define (bad) (escape #f)) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index 4791ca110d..6a10eefa5b 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -127,7 +127,7 @@ ([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))] [intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))] [flatten-attrs* any/c] - [append-attrs ((listof (listof iattr?)) syntax? . -> . (listof iattr?))] + [append-attrs ((listof (listof iattr?)) . -> . (listof iattr?))] [lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))] [lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))] ) @@ -163,10 +163,10 @@ (if (allow-unbound-stxclasses) (make-empty-sc id) (wrong-syntax id "not defined as syntax class"))) - (let ([sc (syntax-local-value id no-good)]) - (unless (or (sc? sc) (ssc? sc)) - (no-good)) - sc)) + (let ([sc (syntax-local-value/catch id sc?)]) + (if (sc? sc) + sc + (no-good)))) (define (split-id/get-stxclass id0 decls) (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) @@ -233,6 +233,7 @@ ;; reorder-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr) ;; Reorders iattrs (and restricts) based on relsattrs +;; If a relsattr is not found, or if depth or contents mismatches, raises error. (define (reorder-iattrs relsattrs iattrs remap) (let ([ht (make-hasheq)]) (for-each (lambda (iattr) @@ -244,12 +245,16 @@ ['() null] [(cons (struct attr (name depth inner)) rest) (let ([iattr (hash-ref ht name #f)]) - (if iattr - (cons (make attr (attr-name iattr) - (attr-depth iattr) - (intersect-sattrs inner (attr-inner iattr))) - (loop rest)) - (loop rest)))])))) + (unless iattr + (wrong-syntax #f "required attribute is not defined: ~s" name)) + (unless (= (attr-depth iattr) depth) + (wrong-syntax (attr-name iattr) + "attribute has wrong depth (expected ~s, found ~s)" + depth (attr-depth iattr))) + (cons (make attr (attr-name iattr) + (attr-depth iattr) + (intersect-sattrs inner (attr-inner iattr))) + (loop rest)))])))) ;; restrict-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr) ;; Preserves order of iattrs @@ -309,14 +314,13 @@ (flatten-attrs* nested (+ depth depth-delta) prefixed-name ctx) (flatten-attrs* rest depth-delta prefix ctx)))])) - -;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr) -(define (append-attrs attrss stx) +;; append-attrs : (listof (listof IAttr)) -> (listof IAttr) +(define (append-attrs attrss) (let* ([all (apply append attrss)] [names (map attr-name all)] [dup (check-duplicate-identifier names)]) (when dup - (raise-syntax-error 'syntax-class "duplicate pattern variable" stx dup)) + (wrong-syntax dup "duplicate pattern variable")) all)) (define (lookup-sattr name sattrs) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index cb32e4d1c6..204e8268db 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -53,24 +53,17 @@ (define lits0 (assq '#:literals chunks)) (define desc0 (assq '#:description chunks)) (define trans0 (assq '#:transparent chunks)) + (define attrs0 (assq '#:attributes chunks)) (define literals (if lits0 (caddr lits0) null)) (define description (and desc0 (caddr desc0))) (define transparent? (and trans0 #t)) + (define attributes (and attrs0 (caddr attrs0))) (define (parse-rhs*-basic rest) (syntax-case rest (basic-syntax-class) - [((basic-syntax-class (attr-decl ...) parser-expr)) - (make rhs:basic ctx - (for/list ([attr-stx (syntax->list #'(attr-decl ...))]) - (syntax-case attr-stx () - [(attr depth) - (begin - (unless (and (identifier? #'attr) - (exact-nonnegative-integer? (syntax-e #'depth))) - (wrong-syntax attr-stx "bad attribute declaration")) - (make-attr (syntax-e #'attr) (syntax-e #'depth) null))] - [_ - (wrong-syntax attr-stx "bad attribute declaration")])) + [((basic-syntax-class parser-expr)) + (make rhs:basic ctx + (or attributes null) transparent? description #'parser-expr)])) @@ -86,7 +79,9 @@ (define patterns (gather-patterns rest)) (when (null? patterns) (wrong-syntax ctx "syntax class has no variants")) - (let ([sattrs (intersect-attrss (map rhs:pattern-attrs patterns) ctx)]) + (let ([sattrs + (or attributes + (intersect-attrss (map rhs:pattern-attrs patterns) ctx))]) (make rhs:union stx sattrs transparent? description @@ -116,17 +111,10 @@ (clause:with-pattern c))] [attrs (append-attrs (cons (pattern-attrs pattern) - (map pattern-attrs with-patterns)) - stx)] + (map pattern-attrs with-patterns)))] [sattrs (iattrs->sattrs attrs remap)]) (make rhs:pattern stx sattrs pattern decls remap clauses))))])) -;; rhs-directive-table -(define rhs-directive-table - (list (list '#:literals check-idlist) - (list '#:description values) - (list '#:transparent))) - ;; parse-pattern : stx(Pattern) env number -> Pattern (define (parse-pattern stx decls depth) (syntax-case stx () @@ -159,20 +147,20 @@ (gdots? #'gdots) (let* ([heads (parse-heads #'heads decls depth)] [tail (parse-pattern #'tail decls depth)] - [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)] + [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)))] [tattrs (pattern-attrs tail)]) - (make pat:gseq stx (append-attrs (list hattrs tattrs) stx) depth heads tail))] + (make pat:gseq stx (append-attrs (list hattrs tattrs)) depth heads tail))] [(head dots . tail) (dots? #'dots) (let* ([headp (parse-pattern #'head decls (add1 depth))] [tail (parse-pattern #'tail decls depth)] [head (pattern->head headp)] - [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)) stx)]) + [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)))]) (make pat:gseq stx attrs depth (list head) tail))] [(a . b) (let ([pa (parse-pattern #'a decls depth)] [pb (parse-pattern #'b decls depth)]) - (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)) stx)]) + (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))]) (make pat:pair stx attrs depth pa pb)))])) (define (pattern->head p) @@ -246,7 +234,7 @@ (for/list ([p (syntax->list pstx)]) (parse-pattern p decls depth))] [heads-attrs - (append-attrs (map pattern-attrs heads) pstx)]) + (append-attrs (map pattern-attrs heads))]) (when default-row (unless (and (= (length heads-attrs) 1) (= enclosing-depth (attr-depth (car heads-attrs))) @@ -258,7 +246,7 @@ (list (make-attr occurs-pvar depth null)) null)]) (make head pstx - (append-attrs (list occurs-attrs heads-attrs) pstx) + (append-attrs (list occurs-attrs heads-attrs)) depth heads min max as-list? @@ -340,3 +328,34 @@ decls remap (reverse rclauses)))) + +;; check-attr-arity-list : stx -> (listof SAttr) +(define (check-attr-arity-list stx) + (unless (stx-list? stx) + (wrong-syntax stx "expected list of attribute declarations")) + (let ([iattrs (map check-attr-arity (stx->list stx))]) + (iattrs->sattrs (append-attrs (map list iattrs)) syntax-e))) + +;; check-attr-arity : stx -> IAttr +(define (check-attr-arity stx) + (syntax-case stx () + [attr + (identifier? #'attr) + (make-attr #'attr 0 null)] + [(attr depth) + (check-attr-arity #'(attr depth ()))] + [(attr depth inners) + (begin (unless (identifier? #'attr) + (wrong-syntax #'attr "expected attribute name")) + (unless (exact-nonnegative-integer? (syntax-e #'depth)) + (wrong-syntax #'depth "expected depth (nonnegative integer)")) + (make-attr #'attr (syntax-e #'depth) (check-attr-arity-list #'inners)))] + [_ + (wrong-syntax stx "expected attribute arity declaration")])) + +;; rhs-directive-table +(define rhs-directive-table + (list (list '#:literals check-idlist) + (list '#:description values) + (list '#:transparent) + (list '#:attributes check-attr-arity-list))) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 884105bf0d..463ff1dc6a 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -116,22 +116,23 @@ ([attr-name attr-depth] ...) parser-expr) (define-syntax-class (name arg ...) + #:attributes ([attr-name attr-depth] ...) (basic-syntax-class - ([attr-name attr-depth] ...) (let ([name parser-expr]) name)))])) (define-syntax (rhs->parser+description stx) (syntax-case stx () [(rhs->parser+description name rhss (arg ...) ctx) - (parameterize ((current-syntax-context #'ctx)) - (let ([rhs (parse-rhs #'rhss #f #'ctx)] - [sc (syntax-local-value #'name)]) - #`(values #,(parse:rhs rhs - (sc-attrs sc) - (syntax->list #'(arg ...))) - (lambda (arg ...) - #,(or (rhs-description rhs) - #'(symbol->string 'name))))))])) + (with-disappeared-uses + (parameterize ((current-syntax-context #'ctx)) + (let ([rhs (parse-rhs #'rhss #f #'ctx)] + [sc (syntax-local-value #'name)]) + #`(values #,(parse:rhs rhs + (sc-attrs sc) + (syntax->list #'(arg ...))) + (lambda (arg ...) + #,(or (rhs-description rhs) + #'(symbol->string 'name)))))))])) (define-syntax (parse-sc stx) (syntax-case stx () @@ -176,15 +177,16 @@ (define-syntax (syntax-parse* stx) (syntax-case stx () [(syntax-parse report-as expr . clauses) - (parameterize ((current-syntax-context - (syntax-property stx - 'report-errors-as - (syntax-e #'report-as)))) - #`(let ([x expr]) - (let ([fail (syntax-patterns-fail x)]) - (parameterize ((current-expression (or (current-expression) x))) - #,(parse:clauses #'clauses #'x #'fail)))))])) - + (with-disappeared-uses + (parameterize ((current-syntax-context + (syntax-property stx + 'report-errors-as + (syntax-e #'report-as)))) + #`(let ([x expr]) + (let ([fail (syntax-patterns-fail x)]) + (parameterize ((current-expression (or (current-expression) x))) + #,(parse:clauses #'clauses #'x #'fail))))))])) + (define-syntax with-patterns (syntax-rules () [(with-patterns () . b) diff --git a/collects/stxclass/stxclass.scrbl b/collects/stxclass/stxclass.scrbl index 7c97908223..6ba7dce562 100644 --- a/collects/stxclass/stxclass.scrbl +++ b/collects/stxclass/stxclass.scrbl @@ -2,7 +2,8 @@ @(require scribble/manual scribble/struct scribble/decode - (for-label scheme/base + (for-label scheme/base + scheme/contract stxclass stxclass/util)) @@ -60,11 +61,8 @@ The grammar of patterns accepted by @scheme[syntax-parse] and literal-id atomic-datum (syntax-pattern . syntax-pattern) - #| (syntax-splice-pattern . syntax-pattern) |# (syntax-pattern #,ellipses . syntax-pattern) ((head ...+) ...* . syntax-pattern)] - #| [syntax-splice-pattern - pvar-id:syntax-splice-class-id] |# [pvar-id _ id]] @@ -268,8 +266,12 @@ depth is fixed for each syntax class. (define-syntax-class (name-id arg-id ...) stxclass-option ... stxclass-variant ...+)] ([stxclass-options + (code:line #:attributes (attr-arity-decl ...)) (code:line #:description description) (code:line #:transparent)] + [attr-arity-decl + attr-name-id + (attr-name-id depth)] [stxclass-variant (pattern syntax-pattern pattern-directive ...)])]{ @@ -284,8 +286,21 @@ present in every variant. Each such attribute must be defined with the same ellipsis nesting depth and the same sub-attributes in each component. -@TODO{Eliminate attribute inference, require explicit attribute -declaration?} +@specsubform[(code:line #:attributes (attr-arity-decl ...))]{ + +Declares the attributes of the syntax class. An attribute arity +declaration consists of the attribute name and optionally its ellipsis +depth (zero if not explicitly specified). + +If the attributes are not explicitly listed, they are +inferred. Attribute inference does not take into account attributes +from the current syntax class and from syntax classes that have not +yet been defined. The full set of attributes is available, however, to +@scheme[#:with] and @scheme[#:when] expressions. This treatment of +recursive and forward references prevents infinitely nested +attributes. + +} @specsubform[(code:line #:description description)]{ @@ -314,12 +329,14 @@ structure of the syntax class. Accepts syntax matching the given pattern with the accompanying pattern directives as in @scheme[syntax-parse]. -Provides an attribute for every pattern variable defined in the -pattern and the @scheme[#:with] clauses. The name of the attribute is -the symbolic name of the pattern variable, except when the name is -explicitly given via a @scheme[#:rename] clause. Pattern variables -declared with a syntax class yield derived pattern variables for that -syntax class's attributes. These are propagated as nested attributes. +The attributes of the pattern are the pattern variables within the +@scheme[pattern] form together with all pattern variables bound by +@scheme[#:with] clauses, including nested attributes produced by +syntax classes associated with the pattern variables. + +The name of an attribute is the symbolic name of the pattern variable, +except when the name is explicitly given via a @scheme[#:rename] +clause. @specsubform[(code:line #:rename internal-id external-id)]{ @@ -329,41 +346,6 @@ the attribute named @scheme[external-id]. } } -Within the syntax-class body, recursive references to the enclosing -syntax class and forward references to syntax classes defined in the -same scope are allowed. For the purpose of calculating provided -attributes, recursive and forward syntax-class references generate no -nested attributes. The full set of attributes is available, however, -to @scheme[#:with] and @scheme[#:when] expressions. - -This treatment of recursive and forward references prevents infinitely -nested attributes. - -@TODO{Eliminate attribute inference. Explicit attribute declaration -eliminates infinitely nested attributes just as well.} - -} -@;{ -@defform*[[(define-syntax-splice-class (name-id arg-id ...) stxclass-body) - (define-syntax-splice-class name-id stxclass-body)]]{ - -Defines @scheme[name-id] as a syntax splice class. When the -@scheme[arg-id]s are present, they are bound as variables (not pattern -variables) in the body. - -The @scheme[stxclass-body] is like the body of -@scheme[define-syntax-class], except that all patterns within it must -match only proper lists: - -@schemegrammar[#:literals (... ...*) - proper-list-pattern - () - (syntax-pattern . proper-list-pattern) - (syntax-splice-pattern . proper-list-pattern) - (syntax-pattern ... . proper-list-pattern) - ((head ...+) ...* . proper-list-pattern)] - -} } @defidform[pattern]{ @@ -699,6 +681,36 @@ Generates a list of @scheme[n] fresh identifiers. } +@defform[(with-catching-disappeared-uses body-expr)]{ + +Evaluates the @scheme[body-expr], catching identifiers looked up using +@scheme[syntax-local-value/catch]. Returns two values: the result of +@scheme[body-expr] and the list of caught identifiers. + +} + +@defform[(with-disappeared-uses stx-expr)]{ + +Evaluates the @scheme[stx-expr], catching identifiers looked up using +@scheme[syntax-local-value/catch]. Adds the caught identifiers to the +@scheme['disappeared-uses] syntax property of the resulting syntax +object. + +} + +@defproc[(syntax-local-value/catch [id identifier?] [predicate (-> any/c boolean?)]) + any/c]{ + +Looks up @scheme[id] in the syntactic environment (as +@scheme[syntax-local-value]). If the lookup succeeds and returns a +value satisfying the predicate, the value is returned and @scheme[id] +is recorded (``caught'') as a disappeared use. If the lookup fails or +if the value does not satisfy the predicate, @scheme[#f] is returned +and the identifier is not recorded as a disappeared use. + +} + + @defproc[(chunk-kw-seq [stx syntax?] [table (listof (cons/c keyword? diff --git a/collects/stxclass/util/error.ss b/collects/stxclass/util/error.ss index 803832d861..ce68ff55fc 100644 --- a/collects/stxclass/util/error.ss +++ b/collects/stxclass/util/error.ss @@ -12,4 +12,4 @@ (raise-syntax-error (if (symbol? blame) blame #f) (apply format format-string args) ctx - stx))) + (or stx ctx)))) diff --git a/collects/stxclass/util/misc.ss b/collects/stxclass/util/misc.ss index 3e1341e5a0..13aba13abc 100644 --- a/collects/stxclass/util/misc.ss +++ b/collects/stxclass/util/misc.ss @@ -10,6 +10,11 @@ generate-temporary generate-n-temporaries + current-caught-disappeared-uses + with-catching-disappeared-uses + with-disappeared-uses + syntax-local-value/catch + format-symbol chunk-kw-seq/no-dups @@ -26,6 +31,31 @@ (begin (define var expr) (define-syntax name (make-syntax-mapping '0 (quote-syntax var))))) +;; Statics and disappeared uses + +(define current-caught-disappeared-uses (make-parameter #f)) + +(define-syntax-rule (with-catching-disappeared-uses . body) + (parameterize ((current-caught-disappeared-uses null)) + (let ([result (let () . body)]) + (values result (current-caught-disappeared-uses))))) + +(define-syntax-rule (with-disappeared-uses stx-expr) + (let-values ([(stx disappeared-uses) + (with-catching-disappeared-uses stx-expr)]) + (syntax-property stx + 'disappeared-use + (append (or (syntax-property stx 'disappeared-use) null) + disappeared-uses)))) + +(define (syntax-local-value/catch id pred) + (let ([value (syntax-local-value id (lambda () #f))]) + (and (pred value) + (begin (let ([uses (current-caught-disappeared-uses)]) + (when uses (current-caught-disappeared-uses (cons id uses)))) + value)))) + + ;; Generating temporaries ;; with-temporaries