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 #lang setup/infotab
#|
(define scribblings (define scribblings
'(("scribblings/stxclass.scrbl" (multi-page) (experimental)))) '(("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)) (only-in "rep-data.ss" make-literalset))
(for-template scheme/base (for-template scheme/base
scheme/contract)) 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-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes () (define-syntax-class name #:attributes ()
@ -38,18 +58,20 @@
(define notfound (box 'notfound)) (define notfound (box 'notfound))
(define-syntax-class (static-of pred name) (define-syntax-class (static pred name)
#:attributes (value) #:attributes (value)
#:description name
(pattern x:id (pattern x:id
#:fail-unless (syntax-transforming?) #:fail-unless (syntax-transforming?)
"not within the extent of a macro transformer" "not within the extent of a macro transformer"
#:attr value (syntax-local-value #'x (lambda () notfound)) #:attr value (syntax-local-value #'x (lambda () notfound))
#:fail-when (eq? (attribute value) notfound) #f)) #: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 (pattern x
#:declare x (static-of (lambda _ #t) "static") #:fail-unless (memv (syntax-e #'x) atoms) #f))
#:attr value (attribute x.value)))
(define-syntax-class struct-name (define-syntax-class struct-name
#:description "struct name" #:description "struct name"
@ -60,7 +82,7 @@
super super
complete?) complete?)
(pattern s (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 info (extract-struct-info (attribute s.value))
#:with descriptor (list-ref (attribute info) 0) #:with descriptor (list-ref (attribute info) 0)
#:with constructor (list-ref (attribute info) 1) #:with constructor (list-ref (attribute info) 1)
@ -83,5 +105,9 @@
(define-syntax kernel-literals (define-syntax kernel-literals
(make-literalset (make-literalset
(for/list ([id (kernel-form-identifier-list)]) (list* (quote-syntax module)
(list (syntax-e id) id)))) (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] [[p . rest]
(let-values ([(rest decls sides) (let-values ([(rest decls sides)
(parse-pattern-directives #'rest #:decls decls0)]) (parse-pattern-directives #'rest #:decls decls0)])
(define-values (decls2 defs2) (decls-create-defs decls))
(with-syntax ([rest rest] (with-syntax ([rest rest]
[fc (empty-frontier #'x)] [fc (empty-frontier #'x)]
[pattern (parse-whole-pattern #'p decls)]) [pattern (parse-whole-pattern #'p decls2)]
#`(parse:S x fc pattern [(local-def ...) defs2])
(convert-sides x #,sides #`(let ()
(clause-success () (let () . rest))))))])) 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)) (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx))
(wrong-syntax clauses-stx "expected non-empty sequence of clauses")) (wrong-syntax clauses-stx "expected non-empty sequence of clauses"))
(with-syntax ([(def ...) defs] (with-syntax ([(def ...) defs]

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

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

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

@ -49,7 +49,7 @@
[rhss rhss]) [rhss rhss])
(let ([the-rhs (let ([the-rhs
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(parse-rhs #'rhss #t splicing? stx))]) (parse-rhs #'rhss #f splicing? stx))])
(with-syntax ([parser (generate-temporary (with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))] (format-symbol "parse-~a" (syntax-e #'name)))]
[attrs (rhs-attrs the-rhs)]) [attrs (rhs-attrs the-rhs)])
@ -125,7 +125,7 @@
(with-disappeared-uses (with-disappeared-uses
(let ([rhs (let ([rhs
(parameterize ((current-syntax-context #'ctx)) (parameterize ((current-syntax-context #'ctx))
(parse-rhs #'rhss #f (syntax-e #'splicing?) #'ctx))]) (parse-rhs #'rhss #t (syntax-e #'splicing?) #'ctx))])
#`(let ([get-description #`(let ([get-description
(lambda args (lambda args
#,(or (rhs-description rhs) #,(or (rhs-description rhs)
@ -164,7 +164,7 @@
(define-syntax (debug-rhs stx) (define-syntax (debug-rhs stx)
(syntax-case stx () (syntax-case stx ()
[(debug-rhs rhs) [(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f stx)]) (let ([rhs (parse-rhs #'rhs #t stx)])
#`(quote #,rhs))])) #`(quote #,rhs))]))
(define-syntax (debug-pattern stx) (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 (@scheme[literal-id]). If the single-identifier form is used, the same
identifier is used for both purposes. 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}, Many literals can be declared at once via one or more @tech{literal sets},
imported with the @scheme[#:literal-sets] option. The literal-set imported with the @scheme[#:literal-sets] option. The literal-set
definition determines the literal identifiers to recognize and the 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[id]{ Alias for @scheme[identifier]. }
@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. } @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 Matches an identifier that is bound in the syntactic environment to
static information (see @scheme[syntax-local-value]) satisfying the 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. 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 Matches a syntax object whose inner datum is @scheme[eqv?] to some
information (see @scheme[syntax-local-value]). 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} @subsection{Literal sets}
@defidform[kernel-literals]{ @defidform[kernel-literals]{
Literal set containing the identifiers for fully-expanded expression Literal set containing the identifiers for fully-expanded code. The
and definition forms (the same as provided by set contains all of the forms listed by
@scheme[kernel-form-identifier-list]). @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))