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

Please apply changes to release branch.

Browse Source 
syntax/parse:
  - removed scribble docs for old stxclass collection
  - fixed bug in syntax-parse and #:declare
  - added attribute calculation option
  - renamed 'static-of' to 'static', added 'atom-in-list'
  - fixed kernel-literals to include all expanded-code forms
  - added tests

svn: r15488
This commit is contained in:
Ryan Culpepper 2009-07-19 01:08:00 +00:00
parent 01fc52e130
commit a97a7f51b5
8 changed files with 193 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/stxclass/info.ss
View File

@ -1,4 +1,6 @@
#lang setup/infotab
#|
(define scribblings
'(("scribblings/stxclass.scrbl" (multi-page) (experimental))))
|#

42
collects/syntax/private/stxparse/lib.ss
View File

@ -12,7 +12,27 @@
(only-in "rep-data.ss" make-literalset))
(for-template scheme/base
scheme/contract))
(provide (all-defined-out))
(provide identifier
boolean
str
character
keyword
number
integer
exact-integer
exact-nonnegative-integer
exact-positive-integer
id
nat
char
expr
static
atom-in-list
kernel-literals)
(define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes ()
@ -38,18 +58,20 @@
(define notfound (box 'notfound))
(define-syntax-class (static-of pred name)
(define-syntax-class (static pred name)
#:attributes (value)
#:description name
(pattern x:id
#:fail-unless (syntax-transforming?)
"not within the extent of a macro transformer"
#:attr value (syntax-local-value #'x (lambda () notfound))
#:fail-when (eq? (attribute value) notfound) #f))
(define-syntax-class static #:attributes (value)
(define-syntax-class (atom-in-list atoms name)
#:attributes ()
#:description name
(pattern x
#:declare x (static-of (lambda _ #t) "static")
#:attr value (attribute x.value)))
#:fail-unless (memv (syntax-e #'x) atoms) #f))
(define-syntax-class struct-name
#:description "struct name"
@ -60,7 +82,7 @@
super
complete?)
(pattern s
#:declare s (static-of "struct name" struct-info?)
#:declare s (static struct-info? "struct name")
#:with info (extract-struct-info (attribute s.value))
#:with descriptor (list-ref (attribute info) 0)
#:with constructor (list-ref (attribute info) 1)
@ -83,5 +105,9 @@
(define-syntax kernel-literals
(make-literalset
(for/list ([id (kernel-form-identifier-list)])
(list (syntax-e id) id))))
(list* (quote-syntax module)
(quote-syntax #%plain-module-begin)
(quote-syntax #%require)
(quote-syntax #%provide)
(for/list ([id (kernel-form-identifier-list)])
(list (syntax-e id) id)))))

12
collects/syntax/private/stxparse/parse.ss
View File

@ -145,12 +145,16 @@
[[p . rest]
(let-values ([(rest decls sides)
(parse-pattern-directives #'rest #:decls decls0)])
(define-values (decls2 defs2) (decls-create-defs decls))
(with-syntax ([rest rest]
[fc (empty-frontier #'x)]
[pattern (parse-whole-pattern #'p decls)])
#`(parse:S x fc pattern
(convert-sides x #,sides
(clause-success () (let () . rest))))))]))
[pattern (parse-whole-pattern #'p decls2)]
[(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))
(wrong-syntax clauses-stx "expected non-empty sequence of clauses"))
(with-syntax ([(def ...) defs]

23
collects/syntax/private/stxparse/rep-data.ss
View File

@ -167,7 +167,7 @@ DeclEntry =
[SideClause/c contract?]
[make-dummy-stxclass (-> identifier? stxclass?)]
[use-dummy-stxclasses? (parameter/c boolean?)]
[stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]
[new-declenv
(->* [(listof (list/c identifier? identifier?))]
@ -194,23 +194,26 @@ DeclEntry =
[split-id/get-stxclass
(-> identifier? DeclEnv/c any)])
(define use-dummy-stxclasses? (make-parameter #f))
;; stxclass-lookup-config : (parameterof (U 'no 'try 'yes))
;; 'no means don't lookup, always use dummy (no nested attrs)
;; 'try means lookup, but on failure use dummy (-> nested attrs only from prev.)
;; 'yes means lookup, raise error on failure
(define stxclass-lookup-config (make-parameter 'yes))
(define (get-stxclass id)
(if (use-dummy-stxclasses?)
(define config (stxclass-lookup-config))
(if (eq? config 'no)
(make-dummy-stxclass id)
(let* ([no-good
(lambda () (wrong-syntax id "not defined as syntax class"))]
[sc (syntax-local-value/catch id stxclass?)])
(unless (stxclass? sc)
(no-good))
sc)))
(cond [(syntax-local-value/catch id stxclass?) => values]
[(eq? config 'try)
(make-dummy-stxclass id)]
[else (wrong-syntax id "not defined as syntax class")])))
(define (get-stxclass/check-arg-count id arg-count)
(let* ([sc (get-stxclass id)]
[expected-arg-count (length (stxclass-params sc))])
(unless (or (= expected-arg-count arg-count)
(use-dummy-stxclasses?))
(memq (stxclass-lookup-config) '(try no)))
;; (above: don't check error if stxclass may not be defined yet)
(wrong-syntax id
"too few arguments for syntax-class ~a (expected ~s)"

95
collects/syntax/private/stxparse/rep.ss
View File

@ -23,7 +23,10 @@
(values stx-list? DeclEnv/c (listof SideClause/c)))]
[parse-directive-table any/c]
[get-decls+defs
(-> list?
(->* [list?] [boolean?]
(values DeclEnv/c (listof syntax?)))]
[decls-create-defs
(-> DeclEnv/c
(values DeclEnv/c (listof syntax?)))]
[check-literals-list
(-> syntax?
@ -81,12 +84,17 @@
;; ---
;; parse-rhs : stx boolean boolean stx -> RHS
;; If allow-unbound? is true, then all stxclasses act as if they have no attrs.
;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
(define (parse-rhs stx allow-unbound? splicing? ctx)
(define-values (rest description transparent? attributes decls defs)
(parse-rhs/part1 stx ctx))
(define patterns (parse-variants rest decls allow-unbound? splicing? ctx))
;; If strict? is true, then referenced stxclasses must be defined, literals must be bound.
;; Set to #f for pass1 (attr collection); parser requires stxclasses to be bound.
(define (parse-rhs stx strict? splicing? ctx)
(define-values (rest description transparent? attributes auto-nested? decls defs)
(parse-rhs/part1 stx strict? ctx))
(define patterns
(parameterize ((stxclass-lookup-config
(cond [strict? 'yes]
[auto-nested? 'try]
[else 'no])))
(parse-variants rest decls splicing? ctx)))
(when (null? patterns)
(wrong-syntax ctx "expected at least one variant"))
(let ([sattrs
@ -94,23 +102,29 @@
(intersect-sattrss (map variant-attrs patterns)))])
(make rhs stx sattrs transparent? description patterns defs)))
(define (parse-rhs/part1 stx ctx)
(define (parse-rhs/part1 stx strict? ctx)
(define-values (chunks rest)
(chunk-kw-seq/no-dups stx rhs-directive-table #:context ctx))
(define desc0 (assq '#:description chunks))
(define trans0 (assq '#:transparent chunks))
(define attrs0 (assq '#:attributes chunks))
(define auto-nested0 (assq '#:auto-nested-attributes chunks))
(define description (and desc0 (caddr desc0)))
(define transparent? (and trans0 #t))
(define attributes (and attrs0 (caddr attrs0)))
(define-values (decls defs) (get-decls+defs chunks))
(values rest description transparent? attributes decls defs))
(define attributes
(cond [(and attrs0 auto-nested0)
(raise-syntax-error #f "cannot use both #:attributes and #:auto-nested-attributes"
ctx (cadr auto-nested0))]
[attrs0 (caddr attrs0)]
[else #f]))
(define-values (decls defs) (get-decls+defs chunks strict?))
(values rest description transparent? attributes (and auto-nested0 #t) decls defs))
(define (parse-variants rest decls allow-unbound? splicing? ctx)
(define (parse-variants rest decls splicing? ctx)
(define (gather-patterns stx)
(syntax-case stx (pattern)
[((pattern . _) . rest)
(cons (parse-variant (stx-car stx) allow-unbound? splicing? decls)
(cons (parse-variant (stx-car stx) splicing? decls)
(gather-patterns #'rest))]
[(bad-variant . rest)
(raise-syntax-error #f "expected syntax-class variant" ctx #'bad-variant)]
@ -118,23 +132,30 @@
null]))
(gather-patterns rest))
;; get-decls+defs : chunks -> (values DeclEnv (listof syntax))
(define (get-decls+defs chunks)
(decls-create-defs (get-decls chunks)))
;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax))
(define (get-decls+defs chunks [strict? #t])
(decls-create-defs (get-decls chunks strict?)))
;; get-decls : chunks -> DeclEnv
(define (get-decls chunks #:context [ctx #f])
(define (get-decls chunks strict? #:context [ctx #f])
(define lits0 (assq '#:literals chunks))
(define litsets0 (assq '#:literal-sets chunks))
(define convs0 (assq '#:conventions chunks))
(define literals
(append-lits+litsets
(if lits0 (caddr lits0) null)
(check-literals-bound (if lits0 (caddr lits0) null) strict?)
(if litsets0 (caddr litsets0) null)
ctx))
(define convention-rules (if convs0 (apply append (caddr convs0)) null))
(new-declenv literals #:conventions convention-rules))
(define (check-literals-bound lits strict?)
(when strict?
(for ([p lits])
(unless (identifier-binding (cadr p))
(wrong-syntax (cadr p) "unbound literal not allowed"))))
lits)
;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
(define (decls-create-defs decls0)
(for/fold ([decls decls0] [defs null])
@ -172,25 +193,24 @@
(bound-id-table-set! seen (car lit) #t)))
(apply append lits litsets))
;; parse-variant : stx boolean boolean boolean DeclEnv -> RHS
(define (parse-variant stx allow-unbound? splicing? decls0)
;; parse-variant : stx boolean DeclEnv -> RHS
(define (parse-variant stx splicing? decls0)
(syntax-case stx (pattern)
[(pattern p . rest)
(parameterize ((use-dummy-stxclasses? allow-unbound?))
(let-values ([(rest decls1 clauses)
(parse-pattern-directives #'rest
#:decls decls0)])
(define-values (decls defs) (decls-create-defs decls1))
(unless (stx-null? rest)
(wrong-syntax (if (pair? rest) (car rest) rest)
"unexpected terms after pattern directives"))
(let* ([pattern (parse-whole-pattern #'p decls splicing?)]
[attrs
(append-iattrs
(cons (pattern-attrs pattern)
(side-clauses-attrss clauses)))]
[sattrs (iattrs->sattrs attrs)])
(make variant stx sattrs pattern clauses defs))))]))
(let-values ([(rest decls1 clauses)
(parse-pattern-directives #'rest
#:decls decls0)])
(define-values (decls defs) (decls-create-defs decls1))
(unless (stx-null? rest)
(wrong-syntax (if (pair? rest) (car rest) rest)
"unexpected terms after pattern directives"))
(let* ([pattern (parse-whole-pattern #'p decls splicing?)]
[attrs
(append-iattrs
(cons (pattern-attrs pattern)
(side-clauses-attrss clauses)))]
[sattrs (iattrs->sattrs attrs)])
(make variant stx sattrs pattern clauses defs)))]))
(define (side-clauses-attrss clauses)
(for/list ([c clauses]
@ -673,6 +693,7 @@
[else (values decls chunks)]))
(loop chunks decls))
;; Keyword Options & Checkers
;; check-lit-string : stx -> string
(define (check-lit-string stx)
@ -703,7 +724,7 @@
[_
(wrong-syntax stx "expected attribute name with optional depth declaration")]))
;; check-literals-list : syntax -> (listof id)
;; check-literals-list : syntax -> (listof (list id id))
(define (check-literals-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected literals list"))
@ -712,6 +733,7 @@
(when dup (wrong-syntax dup "duplicate literal identifier")))
lits))
;; check-literal-entry : syntax -> (list id id)
(define (check-literal-entry stx)
(syntax-case stx ()
[(internal external)
@ -799,6 +821,7 @@
(list* (list '#:description values)
(list '#:transparent)
(list '#:attributes check-attr-arity-list)
(list '#:auto-nested-attributes)
parse-directive-table))
;; pattern-directive-table

6
collects/syntax/private/stxparse/sc.ss
View File

@ -49,7 +49,7 @@
[rhss rhss])
(let ([the-rhs
(parameterize ((current-syntax-context stx))
(parse-rhs #'rhss #t splicing? stx))])
(parse-rhs #'rhss #f splicing? stx))])
(with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))]
[attrs (rhs-attrs the-rhs)])
@ -125,7 +125,7 @@
(with-disappeared-uses
(let ([rhs
(parameterize ((current-syntax-context #'ctx))
(parse-rhs #'rhss #f (syntax-e #'splicing?) #'ctx))])
(parse-rhs #'rhss #t (syntax-e #'splicing?) #'ctx))])
#`(let ([get-description
(lambda args
#,(or (rhs-description rhs)
@ -164,7 +164,7 @@
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f stx)])
(let ([rhs (parse-rhs #'rhs #t stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)

30
collects/syntax/scribblings/parse.scrbl
View File

@ -66,6 +66,11 @@ and the identifier expected to occur in those positions
(@scheme[literal-id]). If the single-identifier form is used, the same
identifier is used for both purposes.
@bold{Note:} Unlike @scheme[syntax-case], @scheme[syntax-parse]
requires all literals to have a binding. To match identifiers by their
symbolic names, consider using the @scheme[atom-in-list] syntax class
instead.
Many literals can be declared at once via one or more @tech{literal sets},
imported with the @scheme[#:literal-sets] option. The literal-set
definition determines the literal identifiers to recognize and the
@ -894,7 +899,7 @@ Match syntax satisfying the corresponding predicates.
@defstxclass[id]{ Alias for @scheme[identifier]. }
@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. }
@defform[(static-of predicate description)]{
@defform[(static predicate description)]{
Matches an identifier that is bound in the syntactic environment to
static information (see @scheme[syntax-local-value]) satisfying the
@ -907,20 +912,29 @@ When used outside of the dynamic extend of a macro transformer (see
The attribute @var[value] contains the value the name is bound to.
}
@defstxclass[static]{
@defform[(atom-in-list atoms description)]{
Like @scheme[static-of], but matches any identifier bound to static
information (see @scheme[syntax-local-value]).
Matches a syntax object whose inner datum is @scheme[eqv?] to some
atom in the given list.
Use @scheme[atom-in-list] instead of a literals list when recognizing
identifier based on their symbolic names rather than their bindings.
The attribute @var[value] contains the value the name is bound to.
}
@subsection{Literal sets}
@defidform[kernel-literals]{
Literal set containing the identifiers for fully-expanded expression
and definition forms (the same as provided by
@scheme[kernel-form-identifier-list]).
Literal set containing the identifiers for fully-expanded code. The
set contains all of the forms listed by
@scheme[kernel-form-identifier-list], plus @scheme[module],
@scheme[#%plain-module-begin], @scheme[#%require], and
@scheme[#%provide].
@;{See @secref[#:doc '(lib "scribblings/reference/reference.scrbl") 'fully-expanded].}
Note that the literal-set uses the names @scheme[#%plain-lambda] and
@scheme[#%plain-app], not @scheme[lambda] and @scheme[#%app].
}

52
collects/tests/stxclass/more-tests.ss Normal file
View File

@ -0,0 +1,52 @@
#lang scheme
(require syntax/parse
schemeunit)
(require (for-syntax syntax/parse))
(define-syntax (convert-syntax-error stx)
(syntax-case stx ()
[(_ expr)
(with-handlers ([exn:fail:syntax?
(lambda (e)
#`(error '#,(exn-message e)))])
(local-expand #'expr 'expression null))]))
;; Test #:auto-nested-attributes
(define-syntax-class two
(pattern (x y)))
(define-syntax-class square0
(pattern (x:two y:two)))
(define-syntax-class square
#:auto-nested-attributes
(pattern (x:two y:two)))
(test-case "nested attributes omitted by default"
(check-equal? (syntax-class-attributes square0)
'((x 0) (y 0))))
(test-case "nested attributes work okay"
(check-equal? (syntax-class-attributes square)
'((x 0) (x.x 0) (x.y 0) (y 0) (y.x 0) (y.y 0))))
;; Test static-of
(define-syntax zero 0)
(define-syntax (m stx)
(syntax-parse stx
[(_ x)
#:declare x (static-of number? "identifier bound to number")
#`(quote #,(attribute x.value))]))
(test-case "static-of: right error"
(check-exn (lambda (exn)
(regexp-match? #rx"identifier bound to number"
(exn-message exn)))
(lambda () (convert-syntax-error (m twelve)))))
(test-case "static-of: works"
(check-equal? (convert-syntax-error (m zero))
0))