diff --git a/collects/syntax/keyword.ss b/collects/syntax/keyword.ss index b12d0eb2c7..b112c32c03 100644 --- a/collects/syntax/keyword.ss +++ b/collects/syntax/keyword.ss @@ -48,7 +48,10 @@ [options-select (-> options/c keyword? (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 any/c)] diff --git a/collects/syntax/private/keyword.ss b/collects/syntax/private/keyword.ss index f1afb120b8..4626f1b9c0 100644 --- a/collects/syntax/private/keyword.ss +++ b/collects/syntax/private/keyword.ss @@ -7,7 +7,8 @@ (provide parse-keyword-options parse-keyword-options/eol options-select - options-select-one + options-select-row + options-select-value check-expression check-identifier @@ -141,16 +142,35 @@ #:when (eq? kw (car chunk))) (cddr chunk))) -;; options-select-one : Options keyword -> any -(define (options-select-one chunks kw - #:default default) +;; options-select-row : Options keyword -> any +(define (options-select-row chunks kw #:default default) (let ([results (options-select chunks kw)]) (cond [(null? results) default] [(null? (cdr results)) (car results)] [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 diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index e1d1fe45bd..26aef0380b 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -143,8 +143,7 @@ #:context stx #:no-duplicates? #t)) (define context - (let ([c (options-select-one chunks '#:context #:default #f)]) - (if c (car c) #'x))) + (options-select-value chunks '#:context #:default #'x)) (define-values (decls0 defs) (get-decls+defs chunks)) (define (for-clause clause) (syntax-case clause () diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index e808ed07c3..181cad4141 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -590,17 +590,17 @@ (parse-keyword-options/eol #'options optional-directive-table #:no-duplicates? #t #:context stx)) - #| - (define defaults - (car (options-select-one chunks '#:defaults #:default '(())))) - |# - (with-syntax ([(too-many-msg) - (options-select-one chunks '#:too-many #:default #'(#f))] - [(name) - (options-select-one chunks '#:name #:default #'(#f))]) + (let ([too-many-msg + (options-select-value chunks '#:too-many #:default #'#f)] + [name + (options-select-value chunks '#:name #:default #'#f)] + #| + [defaults + (options-select-value chunks '#:defaults #:default '())] + |#) (make ehpat (map attr-make-uncertain (pattern-attrs head)) head - (make rep:optional #'name #'too-many-msg #| defaults |#))))])) + (make rep:optional name too-many-msg #| defaults |#))))])) (define (parse-ehpat/once stx decls) (syntax-case stx (~once) @@ -612,15 +612,15 @@ (list '#:too-many check-expression) (list '#:name check-expression)) #:context stx)) - (with-syntax ([(too-few-msg) - (options-select-one chunks '#:too-few #:default #'(#f))] - [(too-many-msg) - (options-select-one chunks '#:too-many #:default #'(#f))] - [(name) - (options-select-one chunks '#:name #:default #'(#f))]) + (let ([too-few-msg + (options-select-value chunks '#:too-few #:default #'#f)] + [too-many-msg + (options-select-value chunks '#:too-many #:default #'#f)] + [name + (options-select-value chunks '#:name #:default #'#f)]) (make ehpat (pattern-attrs 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) (syntax-case stx (~bounds) @@ -641,16 +641,16 @@ (list '#:too-many check-expression) (list '#:name check-expression)) #:context stx)]) - (with-syntax ([(too-few-msg) - (options-select-one chunks '#:too-few #:default #'(#f))] - [(too-many-msg) - (options-select-one chunks '#:too-many #:default #'(#f))] - [(name) - (options-select-one chunks '#:name #:default #'(#f))]) + (let ([too-few-msg + (options-select-value chunks '#:too-few #:default #'#f)] + [too-many-msg + (options-select-value chunks '#:too-many #:default #'#f)] + [name + (options-select-value chunks '#:name #:default #'#f)]) (make ehpat (map increase-depth (pattern-attrs head)) head - (make rep:bounds #'min #'max #'name - #'too-few-msg #'too-many-msg)))))])) + (make rep:bounds #'min #'max + name too-few-msg too-many-msg)))))])) ;; ----- diff --git a/collects/syntax/scribblings/keyword.scrbl b/collects/syntax/scribblings/keyword.scrbl index 80dd1481b0..1c4a215b96 100644 --- a/collects/syntax/scribblings/keyword.scrbl +++ b/collects/syntax/scribblings/keyword.scrbl @@ -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?] [#:default default any/c]) 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?]{ A @techlink{check-procedure} that accepts only identifiers. diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index 1737eda1d7..c86777e379 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -40,7 +40,8 @@ This section describes the @scheme[syntax-parse] pattern matching form, syntax patterns, and attributes. @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 #:conventions (convention-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 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 as literals, rather than simply being pattern variables. A literal in