suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

stxclass: added #:attributes, disappeared-uses

Browse Source 
svn: r13520
This commit is contained in:
Ryan Culpepper 2009-02-11 22:17:39 +00:00
parent 3ee1a899ee
commit 52bd998e5d
8 changed files with 187 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/stxclass/private/codegen.ss
View File

@ -86,15 +86,16 @@
(define (rhs-pattern->pks rhs relsattrs main-var) (define (rhs-pattern->pks rhs relsattrs main-var)
(match rhs (match rhs
[(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) [(struct rhs:pattern (orig-stx attrs pattern decls remap sides))
(list (make-pk (list pattern) (parameterize ((current-syntax-context orig-stx))
(expr:convert-sides sides (list (make-pk (list pattern)
(pattern-attrs pattern) (expr:convert-sides sides
main-var (pattern-attrs pattern)
(lambda (iattrs) main-var
(expr:sc iattrs (lambda (iattrs)
relsattrs (expr:sc iattrs
remap relsattrs
main-var)))))])) remap
main-var))))))]))
;; expr:convert-sides : (listof SideClause) (listof IAttr) id stx -> stx ;; expr:convert-sides : (listof SideClause) (listof IAttr) id stx -> stx
(define (expr:convert-sides sides iattrs main-var k) (define (expr:convert-sides sides iattrs main-var k)

2
collects/stxclass/private/lib.ss
View File

@ -65,8 +65,8 @@
(define-syntax-class (static-of name pred) (define-syntax-class (static-of name pred)
#:description name #:description name
#:attributes ([value 0])
(basic-syntax-class (basic-syntax-class
([value 0])
(lambda (x name pred) (lambda (x name pred)
(let/ec escape (let/ec escape
(define (bad) (escape #f)) (define (bad) (escape #f))

34
collects/stxclass/private/rep-data.ss
View File

@ -127,7 +127,7 @@
([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))] ([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))]
[intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))] [intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))]
[flatten-attrs* any/c] [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-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))]
[lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))] [lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))]
) )
@ -163,10 +163,10 @@
(if (allow-unbound-stxclasses) (if (allow-unbound-stxclasses)
(make-empty-sc id) (make-empty-sc id)
(wrong-syntax id "not defined as syntax class"))) (wrong-syntax id "not defined as syntax class")))
(let ([sc (syntax-local-value id no-good)]) (let ([sc (syntax-local-value/catch id sc?)])
(unless (or (sc? sc) (ssc? sc)) (if (sc? sc)
(no-good)) sc
sc)) (no-good))))
(define (split-id/get-stxclass id0 decls) (define (split-id/get-stxclass id0 decls)
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
@ -233,6 +233,7 @@
;; reorder-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr) ;; reorder-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr)
;; Reorders iattrs (and restricts) based on relsattrs ;; 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) (define (reorder-iattrs relsattrs iattrs remap)
(let ([ht (make-hasheq)]) (let ([ht (make-hasheq)])
(for-each (lambda (iattr) (for-each (lambda (iattr)
@ -244,12 +245,16 @@
['() null] ['() null]
[(cons (struct attr (name depth inner)) rest) [(cons (struct attr (name depth inner)) rest)
(let ([iattr (hash-ref ht name #f)]) (let ([iattr (hash-ref ht name #f)])
(if iattr (unless iattr
(cons (make attr (attr-name iattr) (wrong-syntax #f "required attribute is not defined: ~s" name))
(attr-depth iattr) (unless (= (attr-depth iattr) depth)
(intersect-sattrs inner (attr-inner iattr))) (wrong-syntax (attr-name iattr)
(loop rest)) "attribute has wrong depth (expected ~s, found ~s)"
(loop rest)))])))) 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) ;; restrict-iattrs : (listof SAttr) (listof IAttr) env -> (listof IAttr)
;; Preserves order of iattrs ;; Preserves order of iattrs
@ -309,14 +314,13 @@
(flatten-attrs* nested (+ depth depth-delta) prefixed-name ctx) (flatten-attrs* nested (+ depth depth-delta) prefixed-name ctx)
(flatten-attrs* rest depth-delta prefix ctx)))])) (flatten-attrs* rest depth-delta prefix ctx)))]))
;; append-attrs : (listof (listof IAttr)) -> (listof IAttr)
;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr) (define (append-attrs attrss)
(define (append-attrs attrss stx)
(let* ([all (apply append attrss)] (let* ([all (apply append attrss)]
[names (map attr-name all)] [names (map attr-name all)]
[dup (check-duplicate-identifier names)]) [dup (check-duplicate-identifier names)])
(when dup (when dup
(raise-syntax-error 'syntax-class "duplicate pattern variable" stx dup)) (wrong-syntax dup "duplicate pattern variable"))
all)) all))
(define (lookup-sattr name sattrs) (define (lookup-sattr name sattrs)

73
collects/stxclass/private/rep.ss
View File

@ -53,24 +53,17 @@
(define lits0 (assq '#:literals chunks)) (define lits0 (assq '#:literals chunks))
(define desc0 (assq '#:description chunks)) (define desc0 (assq '#:description chunks))
(define trans0 (assq '#:transparent chunks)) (define trans0 (assq '#:transparent chunks))
(define attrs0 (assq '#:attributes chunks))
(define literals (if lits0 (caddr lits0) null)) (define literals (if lits0 (caddr lits0) null))
(define description (and desc0 (caddr desc0))) (define description (and desc0 (caddr desc0)))
(define transparent? (and trans0 #t)) (define transparent? (and trans0 #t))
(define attributes (and attrs0 (caddr attrs0)))
(define (parse-rhs*-basic rest) (define (parse-rhs*-basic rest)
(syntax-case rest (basic-syntax-class) (syntax-case rest (basic-syntax-class)
[((basic-syntax-class (attr-decl ...) parser-expr)) [((basic-syntax-class parser-expr))
(make rhs:basic ctx (make rhs:basic ctx
(for/list ([attr-stx (syntax->list #'(attr-decl ...))]) (or attributes null)
(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")]))
transparent? transparent?
description description
#'parser-expr)])) #'parser-expr)]))
@ -86,7 +79,9 @@
(define patterns (gather-patterns rest)) (define patterns (gather-patterns rest))
(when (null? patterns) (when (null? patterns)
(wrong-syntax ctx "syntax class has no variants")) (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 (make rhs:union stx sattrs
transparent? transparent?
description description
@ -116,17 +111,10 @@
(clause:with-pattern c))] (clause:with-pattern c))]
[attrs (append-attrs [attrs (append-attrs
(cons (pattern-attrs pattern) (cons (pattern-attrs pattern)
(map pattern-attrs with-patterns)) (map pattern-attrs with-patterns)))]
stx)]
[sattrs (iattrs->sattrs attrs remap)]) [sattrs (iattrs->sattrs attrs remap)])
(make rhs:pattern stx sattrs pattern decls remap clauses))))])) (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 ;; parse-pattern : stx(Pattern) env number -> Pattern
(define (parse-pattern stx decls depth) (define (parse-pattern stx decls depth)
(syntax-case stx () (syntax-case stx ()
@ -159,20 +147,20 @@
(gdots? #'gdots) (gdots? #'gdots)
(let* ([heads (parse-heads #'heads decls depth)] (let* ([heads (parse-heads #'heads decls depth)]
[tail (parse-pattern #'tail 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)]) [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) [(head dots . tail)
(dots? #'dots) (dots? #'dots)
(let* ([headp (parse-pattern #'head decls (add1 depth))] (let* ([headp (parse-pattern #'head decls (add1 depth))]
[tail (parse-pattern #'tail decls depth)] [tail (parse-pattern #'tail decls depth)]
[head (pattern->head headp)] [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))] (make pat:gseq stx attrs depth (list head) tail))]
[(a . b) [(a . b)
(let ([pa (parse-pattern #'a decls depth)] (let ([pa (parse-pattern #'a decls depth)]
[pb (parse-pattern #'b 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)))])) (make pat:pair stx attrs depth pa pb)))]))
(define (pattern->head p) (define (pattern->head p)
@ -246,7 +234,7 @@
(for/list ([p (syntax->list pstx)]) (for/list ([p (syntax->list pstx)])
(parse-pattern p decls depth))] (parse-pattern p decls depth))]
[heads-attrs [heads-attrs
(append-attrs (map pattern-attrs heads) pstx)]) (append-attrs (map pattern-attrs heads))])
(when default-row (when default-row
(unless (and (= (length heads-attrs) 1) (unless (and (= (length heads-attrs) 1)
(= enclosing-depth (attr-depth (car heads-attrs))) (= enclosing-depth (attr-depth (car heads-attrs)))
@ -258,7 +246,7 @@
(list (make-attr occurs-pvar depth null)) (list (make-attr occurs-pvar depth null))
null)]) null)])
(make head pstx (make head pstx
(append-attrs (list occurs-attrs heads-attrs) pstx) (append-attrs (list occurs-attrs heads-attrs))
depth depth
heads heads
min max as-list? min max as-list?
@ -340,3 +328,34 @@
decls decls
remap remap
(reverse rclauses)))) (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)))

40
collects/stxclass/private/sc.ss
View File

@ -116,22 +116,23 @@
([attr-name attr-depth] ...) ([attr-name attr-depth] ...)
parser-expr) parser-expr)
(define-syntax-class (name arg ...) (define-syntax-class (name arg ...)
#:attributes ([attr-name attr-depth] ...)
(basic-syntax-class (basic-syntax-class
([attr-name attr-depth] ...)
(let ([name parser-expr]) name)))])) (let ([name parser-expr]) name)))]))
(define-syntax (rhs->parser+description stx) (define-syntax (rhs->parser+description stx)
(syntax-case stx () (syntax-case stx ()
[(rhs->parser+description name rhss (arg ...) ctx) [(rhs->parser+description name rhss (arg ...) ctx)
(parameterize ((current-syntax-context #'ctx)) (with-disappeared-uses
(let ([rhs (parse-rhs #'rhss #f #'ctx)] (parameterize ((current-syntax-context #'ctx))
[sc (syntax-local-value #'name)]) (let ([rhs (parse-rhs #'rhss #f #'ctx)]
#`(values #,(parse:rhs rhs [sc (syntax-local-value #'name)])
(sc-attrs sc) #`(values #,(parse:rhs rhs
(syntax->list #'(arg ...))) (sc-attrs sc)
(lambda (arg ...) (syntax->list #'(arg ...)))
#,(or (rhs-description rhs) (lambda (arg ...)
#'(symbol->string 'name))))))])) #,(or (rhs-description rhs)
#'(symbol->string 'name)))))))]))
(define-syntax (parse-sc stx) (define-syntax (parse-sc stx)
(syntax-case stx () (syntax-case stx ()
@ -176,15 +177,16 @@
(define-syntax (syntax-parse* stx) (define-syntax (syntax-parse* stx)
(syntax-case stx () (syntax-case stx ()
[(syntax-parse report-as expr . clauses) [(syntax-parse report-as expr . clauses)
(parameterize ((current-syntax-context (with-disappeared-uses
(syntax-property stx (parameterize ((current-syntax-context
'report-errors-as (syntax-property stx
(syntax-e #'report-as)))) 'report-errors-as
#`(let ([x expr]) (syntax-e #'report-as))))
(let ([fail (syntax-patterns-fail x)]) #`(let ([x expr])
(parameterize ((current-expression (or (current-expression) x))) (let ([fail (syntax-patterns-fail x)])
#,(parse:clauses #'clauses #'x #'fail)))))])) (parameterize ((current-expression (or (current-expression) x)))
#,(parse:clauses #'clauses #'x #'fail))))))]))
(define-syntax with-patterns (define-syntax with-patterns
(syntax-rules () (syntax-rules ()
[(with-patterns () . b) [(with-patterns () . b)

106
collects/stxclass/stxclass.scrbl
View File

@ -2,7 +2,8 @@
@(require scribble/manual @(require scribble/manual
scribble/struct scribble/struct
scribble/decode scribble/decode
(for-label scheme/base (for-label scheme/base
scheme/contract
stxclass stxclass
stxclass/util)) stxclass/util))
@ -60,11 +61,8 @@ The grammar of patterns accepted by @scheme[syntax-parse] and
literal-id literal-id
atomic-datum atomic-datum
(syntax-pattern . syntax-pattern) (syntax-pattern . syntax-pattern)
#| (syntax-splice-pattern . syntax-pattern) |#
(syntax-pattern #,ellipses . syntax-pattern) (syntax-pattern #,ellipses . syntax-pattern)
((head ...+) ...* . syntax-pattern)] ((head ...+) ...* . syntax-pattern)]
#| [syntax-splice-pattern
pvar-id:syntax-splice-class-id] |#
[pvar-id [pvar-id
_ _
id]] id]]
@ -268,8 +266,12 @@ depth is fixed for each syntax class.
(define-syntax-class (name-id arg-id ...) stxclass-option ... (define-syntax-class (name-id arg-id ...) stxclass-option ...
stxclass-variant ...+)] stxclass-variant ...+)]
([stxclass-options ([stxclass-options
(code:line #:attributes (attr-arity-decl ...))
(code:line #:description description) (code:line #:description description)
(code:line #:transparent)] (code:line #:transparent)]
[attr-arity-decl
attr-name-id
(attr-name-id depth)]
[stxclass-variant [stxclass-variant
(pattern syntax-pattern pattern-directive ...)])]{ (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 same ellipsis nesting depth and the same sub-attributes in each
component. component.
@TODO{Eliminate attribute inference, require explicit attribute @specsubform[(code:line #:attributes (attr-arity-decl ...))]{
declaration?}
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)]{ @specsubform[(code:line #:description description)]{
@ -314,12 +329,14 @@ structure of the syntax class.
Accepts syntax matching the given pattern with the accompanying Accepts syntax matching the given pattern with the accompanying
pattern directives as in @scheme[syntax-parse]. pattern directives as in @scheme[syntax-parse].
Provides an attribute for every pattern variable defined in the The attributes of the pattern are the pattern variables within the
pattern and the @scheme[#:with] clauses. The name of the attribute is @scheme[pattern] form together with all pattern variables bound by
the symbolic name of the pattern variable, except when the name is @scheme[#:with] clauses, including nested attributes produced by
explicitly given via a @scheme[#:rename] clause. Pattern variables syntax classes associated with the pattern variables.
declared with a syntax class yield derived pattern variables for that
syntax class's attributes. These are propagated as nested attributes. 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)]{ @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]{ @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?] @defproc[(chunk-kw-seq [stx syntax?]
[table [table
(listof (cons/c keyword? (listof (cons/c keyword?

2
collects/stxclass/util/error.ss
View File

@ -12,4 +12,4 @@
(raise-syntax-error (if (symbol? blame) blame #f) (raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args) (apply format format-string args)
ctx ctx
stx))) (or stx ctx))))

30
collects/stxclass/util/misc.ss
View File

@ -10,6 +10,11 @@
generate-temporary generate-temporary
generate-n-temporaries generate-n-temporaries
current-caught-disappeared-uses
with-catching-disappeared-uses
with-disappeared-uses
syntax-local-value/catch
format-symbol format-symbol
chunk-kw-seq/no-dups chunk-kw-seq/no-dups
@ -26,6 +31,31 @@
(begin (define var expr) (begin (define var expr)
(define-syntax name (make-syntax-mapping '0 (quote-syntax var))))) (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 ;; Generating temporaries
;; with-temporaries ;; with-temporaries