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)
(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)

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

@ -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))

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

@ -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)

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

@ -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)))

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

@ -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)

106
collects/stxclass/stxclass.scrbl
View File

@ -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?

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

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

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

@ -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