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

syntax/keyword: renamed and added selection procedures

Browse Source 
syntax/parse: documented #:context option

svn: r15839
This commit is contained in:
Ryan Culpepper 2009-08-30 18:22:09 +00:00
parent 188dba05f4
commit 1a2ce72089
6 changed files with 74 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/syntax/keyword.ss
View File

@ -48,7 +48,10 @@
[options-select [options-select
(-> options/c keyword? (-> options/c keyword?
(listof list?))] (listof list?))]
[options-select-one [options-select-row
(-> options/c keyword? #:default any/c
any/c)]
[options-select-value
(-> options/c keyword? #:default any/c (-> options/c keyword? #:default any/c
any/c)] any/c)]

30
collects/syntax/private/keyword.ss
View File

@ -7,7 +7,8 @@
(provide parse-keyword-options (provide parse-keyword-options
parse-keyword-options/eol parse-keyword-options/eol
options-select options-select
options-select-one options-select-row
options-select-value
check-expression check-expression
check-identifier check-identifier
@ -141,16 +142,35 @@
#:when (eq? kw (car chunk))) #:when (eq? kw (car chunk)))
(cddr chunk))) (cddr chunk)))
;; options-select-one : Options keyword -> any ;; options-select-row : Options keyword -> any
(define (options-select-one chunks kw (define (options-select-row chunks kw #:default default)
#:default default)
(let ([results (options-select chunks kw)]) (let ([results (options-select chunks kw)])
(cond [(null? results) (cond [(null? results)
default] default]
[(null? (cdr results)) [(null? (cdr results))
(car results)] (car results)]
[else [else
(error 'options-select-one "multiple occurrences of ~s keyword option" kw)]))) (error 'options-select-row
"multiple occurrences of ~s keyword" kw)])))
;; options-select-value : Options keyword -> any
(define (options-select-value chunks kw #:default default)
(let ([results (options-select chunks kw)])
(cond [(null? results)
default]
[(null? (cdr results))
(let ([row (car results)])
(cond [(null? row)
(error 'options-select-value
"keyword ~s has no arguments" kw)]
[(null? (cdr row))
(car row)]
[else
(error 'options-select-value
"keyword ~s has more than one argument" kw)]))]
[else
(error 'options-select-value
"multiple occurrences of ~s keyword" kw)])))
;; Check Procedures ;; Check Procedures

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

@ -143,8 +143,7 @@
#:context stx #:context stx
#:no-duplicates? #t)) #:no-duplicates? #t))
(define context (define context
(let ([c (options-select-one chunks '#:context #:default #f)]) (options-select-value chunks '#:context #:default #'x))
(if c (car c) #'x)))
(define-values (decls0 defs) (get-decls+defs chunks)) (define-values (decls0 defs) (get-decls+defs chunks))
(define (for-clause clause) (define (for-clause clause)
(syntax-case clause () (syntax-case clause ()

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

@ -590,17 +590,17 @@
(parse-keyword-options/eol #'options optional-directive-table (parse-keyword-options/eol #'options optional-directive-table
#:no-duplicates? #t #:no-duplicates? #t
#:context stx)) #:context stx))
(let ([too-many-msg
(options-select-value chunks '#:too-many #:default #'#f)]
[name
(options-select-value chunks '#:name #:default #'#f)]
#| #|
(define defaults [defaults
(car (options-select-one chunks '#:defaults #:default '(())))) (options-select-value chunks '#:defaults #:default '())]
|# |#)
(with-syntax ([(too-many-msg)
(options-select-one chunks '#:too-many #:default #'(#f))]
[(name)
(options-select-one chunks '#:name #:default #'(#f))])
(make ehpat (map attr-make-uncertain (pattern-attrs head)) (make ehpat (map attr-make-uncertain (pattern-attrs head))
head head
(make rep:optional #'name #'too-many-msg #| defaults |#))))])) (make rep:optional name too-many-msg #| defaults |#))))]))
(define (parse-ehpat/once stx decls) (define (parse-ehpat/once stx decls)
(syntax-case stx (~once) (syntax-case stx (~once)
@ -612,15 +612,15 @@
(list '#:too-many check-expression) (list '#:too-many check-expression)
(list '#:name check-expression)) (list '#:name check-expression))
#:context stx)) #:context stx))
(with-syntax ([(too-few-msg) (let ([too-few-msg
(options-select-one chunks '#:too-few #:default #'(#f))] (options-select-value chunks '#:too-few #:default #'#f)]
[(too-many-msg) [too-many-msg
(options-select-one chunks '#:too-many #:default #'(#f))] (options-select-value chunks '#:too-many #:default #'#f)]
[(name) [name
(options-select-one chunks '#:name #:default #'(#f))]) (options-select-value chunks '#:name #:default #'#f)])
(make ehpat (pattern-attrs head) (make ehpat (pattern-attrs head)
head head
(make rep:once #'name #'too-few-msg #'too-many-msg))))])) (make rep:once name too-few-msg too-many-msg))))]))
(define (parse-ehpat/bounds stx decls) (define (parse-ehpat/bounds stx decls)
(syntax-case stx (~bounds) (syntax-case stx (~bounds)
@ -641,16 +641,16 @@
(list '#:too-many check-expression) (list '#:too-many check-expression)
(list '#:name check-expression)) (list '#:name check-expression))
#:context stx)]) #:context stx)])
(with-syntax ([(too-few-msg) (let ([too-few-msg
(options-select-one chunks '#:too-few #:default #'(#f))] (options-select-value chunks '#:too-few #:default #'#f)]
[(too-many-msg) [too-many-msg
(options-select-one chunks '#:too-many #:default #'(#f))] (options-select-value chunks '#:too-many #:default #'#f)]
[(name) [name
(options-select-one chunks '#:name #:default #'(#f))]) (options-select-value chunks '#:name #:default #'#f)])
(make ehpat (map increase-depth (pattern-attrs head)) (make ehpat (map increase-depth (pattern-attrs head))
head head
(make rep:bounds #'min #'max #'name (make rep:bounds #'min #'max
#'too-few-msg #'too-many-msg)))))])) name too-few-msg too-many-msg)))))]))
;; ----- ;; -----

17
collects/syntax/scribblings/keyword.scrbl
View File

@ -214,7 +214,7 @@ the arity of the keyword.
} }
@defproc[(options-select-one [options #, @techlink{options}] @defproc[(options-select-row [options #, @techlink{options}]
[keyword keyword?] [keyword keyword?]
[#:default default any/c]) [#:default default any/c])
any]{ any]{
@ -226,6 +226,21 @@ the @scheme[default] list is returned.
} }
@defproc[(options-select-value [options #, @techlink{options}]
[keyword keyword?]
[#:default default any/c])
any]{
Like @scheme[options-select], except that the given keyword must occur
either zero or one times in @scheme[options]. If the keyword occurs,
the associated list of parsed argument values must have exactly one
element, and that element is returned. If the keyword does not occur
in @scheme[options], the @scheme[default] value is returned.
}
@defproc[(check-identifier [stx syntax?] [ctx (or/c false/c syntax?)]) identifier?]{ @defproc[(check-identifier [stx syntax?] [ctx (or/c false/c syntax?)]) identifier?]{
A @techlink{check-procedure} that accepts only identifiers. A @techlink{check-procedure} that accepts only identifiers.

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

@ -40,7 +40,8 @@ This section describes the @scheme[syntax-parse] pattern matching
form, syntax patterns, and attributes. form, syntax patterns, and attributes.
@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+) @defform/subs[(syntax-parse stx-expr parse-option ... clause ...+)
([parse-option (code:line #:literals (literal ...)) ([parse-option (code:line #:context context-expr)
(code:line #:literals (literal ...))
(code:line #:literal-sets (literal-set ...)) (code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))] (code:line #:conventions (convention-id ...))]
[literal literal-id [literal literal-id
@ -57,7 +58,8 @@ subterms of the syntax object and that clause's side conditions and
If the syntax object fails to match any of the patterns (or all If the syntax object fails to match any of the patterns (or all
matches fail the corresponding clauses' side conditions), a syntax matches fail the corresponding clauses' side conditions), a syntax
error is raised. error is raised. If the @scheme[#:context] argument is given,
@scheme[context-expr] is used in reporting the error.
The @scheme[#:literals] option specifies identifiers that should match The @scheme[#:literals] option specifies identifiers that should match
as literals, rather than simply being pattern variables. A literal in as literals, rather than simply being pattern variables. A literal in