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

added syntax/keyword library

Browse Source 
updated syntax/parse to add #:context argument

svn: r15828
This commit is contained in:
Ryan Culpepper 2009-08-29 22:58:08 +00:00
parent 2900922d1c
commit 43d10b5179
11 changed files with 651 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/syntax/keyword.ss Normal file
View File

@ -0,0 +1,58 @@
#lang scheme/base
(require scheme/contract
scheme/dict
"private/keyword.ss")
(define optstx (or/c syntax? false/c))
(define checker (-> syntax? optstx any/c))
(define stxish any/c)
(define keyword-table/c
(or/c (listof (cons/c keyword? (listof checker)))
(and/c (not/c list?)
dict?)))
(define options/c
(listof (cons/c keyword? (cons/c syntax? list?))))
(provide/contract
[parse-keyword-options
(->* (syntax? dict?)
(#:context optstx
#:no-duplicates? boolean?
#:incompatible (listof (listof keyword?))
#:on-incompatible (-> keyword? keyword? options/c stxish optstx
(values options/c stxish))
#:on-too-short (-> keyword? options/c stxish optstx
(values options/c stxish))
#:on-not-in-table (-> keyword? options/c stxish optstx
(values options/c stxish)))
(values options/c stxish))]
[parse-keyword-options/eol
(->* (syntax? dict?)
(#:context optstx
#:no-duplicates? boolean?
#:incompatible (listof (listof keyword?))
#:on-incompatible (-> keyword? keyword? options/c stxish optstx
(values options/c stxish))
#:on-too-short (-> keyword? options/c stxish optstx
(values options/c stxish))
#:on-not-in-table (-> keyword? options/c stxish optstx
(values options/c stxish))
#:on-not-eol (-> options/c stxish optstx
options/c))
options/c)]
[options-select
(-> options/c keyword?
(listof list?))]
[options-select-one
(-> options/c keyword? #:default any/c
any/c)]
[check-expression checker]
[check-identifier checker]
[check-stx-string checker]
[check-stx-listof (-> checker checker)])

195
collects/syntax/private/keyword.ss Normal file
View File

@ -0,0 +1,195 @@
#lang scheme/base
;; No-contract version...
(require syntax/stx
scheme/dict)
(provide parse-keyword-options
parse-keyword-options/eol
options-select
options-select-one
check-expression
check-identifier
check-stx-string
check-stx-listof)
;; Parsing keyword arguments
;; KeywordTable = (listof (cons keyword (listof CheckProc)))
;; Options = (listof (list* keyword syntax-keyword (listof any)))
;; CheckProc = syntax syntax -> any
;; The first arg is syntax to check, second arg is context.
;; incompatible-handler : keyword keyword Options syntax syntax -> (values Options syntax)
(define (default-incompatible kw1 kw2 chunks stx ctx)
(if (eq? kw1 kw2)
(raise-syntax-error #f "duplicate keyword option" ctx (stx-car stx))
(raise-syntax-error #f
(format "~s option not allowed after ~s option" kw2 kw1)
ctx (stx-car stx))))
;; too-short-handler : keyword Options syntax syntax -> (values Options syntax)
(define (default-too-short kw chunks stx ctx)
(raise-syntax-error #f "too few arguments for keyword" ctx (stx-car stx)))
;; not-in-table-handler : keyword syntax syntax -> (values Options syntax)
(define ((default-not-in-table kws) kw stx ctx)
(raise-syntax-error #f
(format "unexpected keyword, expected one of ~s" kws)
ctx (stx-car stx)))
;; not-eol-handler : Options syntax syntax -> (values Options syntax)
(define (default-not-eol chunks stx ctx)
(raise-syntax-error #f
"terms left over after keyword options"
ctx
stx))
(define (parse-keyword-options/eol stx table
#:context [ctx #f]
#:no-duplicates? [no-duplicates? #f]
#:incompatible [incompatible null]
#:on-incompatible [incompatible-handler default-incompatible]
#:on-too-short [too-short-handler default-too-short]
#:on-not-in-table [not-in-table-handler
(default-not-in-table (map car table))]
#:on-not-eol [not-eol-handler default-not-eol])
(define-values (chunks rest)
(parse-keyword-options stx table
#:context ctx
#:no-duplicates? no-duplicates?
#:incompatible incompatible
#:on-incompatible incompatible-handler
#:on-too-short too-short-handler
#:on-not-in-table not-in-table-handler))
(if (stx-null? rest)
chunks
(not-eol-handler chunks stx ctx)))
(define (list-ne-tails lst)
(if (pair? lst)
(cons lst (list-ne-tails (cdr lst)))
null))
;; parse-keyword-options : syntax KeywordTable ... -> (values Options syntax)
;; incompatible-handler is also used for duplicates (same kw arg)
;; incompatible is (listof (list keyword keyword)); reflexive closure taken
(define (parse-keyword-options stx table
#:context [ctx #f]
#:no-duplicates? [no-duplicates? #f]
#:incompatible [incompatible null]
#:on-incompatible [incompatible-handler default-incompatible]
#:on-too-short [too-short-handler default-too-short]
#:on-not-in-table [not-in-table-handler
(default-not-in-table (map car table))])
(define interfere-table
(let ([table (make-hash)])
(for ([entry incompatible])
(for ([tail (list-ne-tails entry)])
(for ([next (cdr tail)])
(hash-set! table (list (car tail) next) #t)
(hash-set! table (list next (car tail)) #t))))
table))
(define (interferes kw seen)
(for/or ([seen-kw (in-dict-keys seen)])
(and (hash-ref interfere-table (list seen-kw kw) #f)
seen-kw)))
(define (loop stx rchunks seen)
(syntax-case stx ()
[(kw . more)
(keyword? (syntax-e #'kw))
(let* ([kw-value (syntax-e #'kw)]
[entry (assq kw-value table)])
(cond [(and no-duplicates?
(hash-ref seen kw-value #f))
(incompatible-handler kw-value kw-value (reverse rchunks) stx ctx)]
[(interferes kw-value seen) =>
(lambda (seen-kw)
(incompatible-handler seen-kw kw-value (reverse rchunks) stx ctx))]
[entry
(let* ([arity (cdr entry)]
[args+rest (stx-split #'more arity)])
(if args+rest
(let ([args (for/list ([arg (car args+rest)] [proc arity])
(proc arg ctx))]
[rest (cdr args+rest)])
(loop rest
(cons (list* kw-value #'kw args) rchunks)
(hash-set seen kw-value #t)))
(too-short-handler kw-value (reverse rchunks) stx ctx)))]
[else
(not-in-table-handler kw-value stx ctx)]))]
[_
(values (reverse rchunks) stx)]))
(loop stx null (make-immutable-hasheq '())))
;; stx-split : stx (listof any) -> (cons (listof stx) stx)
(define (stx-split stx arity)
(define (loop stx arity acc)
(cond [(null? arity)
(cons (reverse acc) stx)]
[(stx-pair? stx)
(loop (stx-cdr stx) (cdr arity) (cons (stx-car stx) acc))]
[else #f]))
(loop stx arity null))
;; options-select : Options keyword -> (listof (listof any))
(define (options-select chunks kw)
(for/list ([chunk chunks]
#:when (eq? kw (car chunk)))
(cddr chunk)))
;; options-select-one : Options keyword -> any
(define (options-select-one 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)])))
;; Check Procedures
;; check-identifier : stx stx -> identifier
(define (check-identifier stx ctx)
(unless (identifier? stx)
(raise-syntax-error #f "expected identifier" ctx stx))
stx)
;; check-expression : stx stx -> stx
(define (check-expression stx ctx)
(when (keyword? (syntax-e stx))
(raise-syntax-error #f "expected expression" ctx stx))
stx)
;; check-stx-string : stx stx -> stx
(define (check-stx-string stx ctx)
(unless (string? (syntax-e stx))
(raise-syntax-error #f "expected string" ctx stx))
stx)
;; check-stx-boolean : stx stx -> stx
(define (check-stx-boolean stx ctx)
(unless (boolean? (syntax-e stx))
(raise-syntax-error #f "expected boolean" ctx stx))
stx)
#|
;; check-nat/f : stx stx -> stx
(define (check-nat/f stx ctx)
(let ([d (syntax-e stx)])
(unless (or (eq? d #f) (exact-nonnegative-integer? d))
(raise-syntax-error #f "expected exact nonnegative integer or #f" ctx stx))
stx))
|#
;; check-stx-listof : (stx stx -> A) -> stx stx -> (listof A)
(define ((check-stx-listof check) stx ctx)
(unless (stx-list? stx)
(raise-syntax-error #f "expected list" ctx stx))
(for/list ([x (stx->list stx)])
(check x ctx)))

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

@ -4,6 +4,7 @@
scheme/private/sc
syntax/stx
syntax/id-table
syntax/keyword
"rep-data.ss"
"rep.ss"
"codegen-data.ss"
@ -138,7 +139,12 @@
[(parse:clauses x clauses)
(let ()
(define-values (chunks clauses-stx)
(chunk-kw-seq/no-dups #'clauses parse-directive-table))
(parse-keyword-options #'clauses parse-directive-table
#:context stx
#:no-duplicates? #t))
(define context
(let ([c (options-select-one chunks '#:context #:default #f)])
(if c (car c) #'#f)))
(define-values (decls0 defs) (get-decls+defs chunks))
(define (for-clause clause)
(syntax-case clause ()
@ -160,9 +166,10 @@
(with-syntax ([(def ...) defs]
[(alternative ...)
(map for-clause (stx->list clauses-stx))])
#`(let ()
#`(let ([fail (syntax-patterns-fail #,context)])
def ...
(try alternative ...))))]))
(with-enclosing-fail* fail
(try alternative ...)))))]))
(define-for-syntax (wash-literal stx)
(syntax-case stx ()

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

@ -6,6 +6,7 @@
scheme/dict
syntax/id-table
syntax/stx
syntax/keyword
"../util.ss"
"rep-data.ss"
"codegen-data.ss")
@ -29,10 +30,10 @@
(-> DeclEnv/c
(values DeclEnv/c (listof syntax?)))]
[check-literals-list
(-> syntax?
(-> syntax? syntax?
(listof (list/c identifier? identifier?)))]
[check-literal-sets-list
(-> syntax?
(-> syntax? syntax?
(listof (listof (list/c identifier? identifier?))))]
[append-lits+litsets
(-> (listof (list/c identifier? identifier?))
@ -104,7 +105,9 @@
(define (parse-rhs/part1 stx strict? ctx)
(define-values (chunks rest)
(chunk-kw-seq/no-dups stx rhs-directive-table #:context ctx))
(parse-keyword-options stx rhs-directive-table
#:context ctx
#:no-duplicates? #t))
(define desc0 (assq '#:description chunks))
(define trans0 (assq '#:transparent chunks))
(define attrs0 (assq '#:attributes chunks))
@ -506,16 +509,16 @@
(define (parse-bind-clause clause)
(syntax-case clause ()
[(attr-decl expr)
(make clause:attr (check-attr-arity #'attr-decl) #'expr)]
(make clause:attr (check-attr-arity #'attr-decl #f) #'expr)]
[_ (wrong-syntax clause "expected bind clause")]))
(define (parse-pat:fail stx decls)
(syntax-case stx ()
[(_ . rest)
(let-values ([(chunks rest)
(chunk-kw-seq/no-dups #'rest
fail-directive-table
#:context stx)])
(parse-keyword-options #'rest fail-directive-table
#:context stx
#:no-duplicates? #t)])
;; chunks has 0 or 1 of each of #:when, #:unless
;; if has both, second one is bad; report it
(when (> (length chunks) 1)
@ -572,13 +575,15 @@
(syntax-case stx (~optional)
[(~optional p . options)
(let ([head (parse-head-pattern #'p decls)])
(with-syntax ([((too-many-msg) (name))
(parse-kw-options #'options
(list (list '#:too-many values)
(list '#:name values))
(list (list '#:too-many #'#f)
(list '#:name #'#f))
#:context stx)])
(define chunks
(parse-keyword-options/eol #'options
(list (list '#:too-many check-expression)
(list '#:name check-expression))
#:context stx))
(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))
head
(make rep:optional #'name #'too-many-msg))))]))
@ -587,15 +592,18 @@
(syntax-case stx (~once)
[(~once p . options)
(let ([head (parse-head-pattern #'p decls)])
(with-syntax ([((too-few-msg) (too-many-msg) (name))
(parse-kw-options #'options
(list (list '#:too-few values)
(list '#:too-many values)
(list '#:name values))
(list (list '#:too-few #'#f)
(list '#:too-many #'#f)
(list '#:name #'#f))
#:context stx)])
(define chunks
(parse-keyword-options/eol #'options
(list (list '#:too-few check-expression)
(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))])
(make ehpat (pattern-attrs head)
head
(make rep:once #'name #'too-few-msg #'too-many-msg))))]))
@ -614,18 +622,21 @@
"expected exact nonnegative integer or +inf.0"))
(when (> minN maxN)
(wrong-syntax stx "minumum larger than maximum repetition constraint"))
(with-syntax ([((too-few-msg) (too-many-msg) (name))
(parse-kw-options #'options
(list (list '#:too-few values)
(list '#:too-many values)
(list '#:name values))
(list (list '#:too-few #'#f)
(list '#:too-many #'#f)
(list '#:name #'#f)))])
(make ehpat (map increase-depth (pattern-attrs head))
head
(make rep:bounds #'min #'max #'name
#'too-few-msg #'too-many-msg))))]))
(let ([chunks (parse-keyword-options #'options
(list (list '#:too-few check-expression)
(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))])
(make ehpat (map increase-depth (pattern-attrs head))
head
(make rep:bounds #'min #'max #'name
#'too-few-msg #'too-many-msg)))))]))
;; -----
@ -635,7 +646,7 @@
#:decls [decls #f]
#:allow-declare? [allow-declare? #t])
(define-values (chunks rest)
(chunk-kw-seq stx pattern-directive-table))
(parse-keyword-options stx pattern-directive-table))
(define-values (decls2 chunks2)
(if allow-declare?
(grab-decls chunks decls)
@ -696,46 +707,39 @@
;; Keyword Options & Checkers
;; check-lit-string : stx -> string
(define (check-lit-string stx)
(let ([x (syntax-e stx)])
(unless (string? x)
(wrong-syntax stx "expected string literal"))
x))
;; check-attr-arity-list : stx -> (listof SAttr)
(define (check-attr-arity-list stx)
;; check-attr-arity-list : stx stx -> (listof SAttr)
(define (check-attr-arity-list stx ctx)
(unless (stx-list? stx)
(wrong-syntax stx "expected list of attribute declarations"))
(let ([iattrs (map check-attr-arity (stx->list stx))])
(raise-syntax-error #f "expected list of attribute declarations" ctx stx))
(let ([iattrs (for/list ([x (stx->list stx)]) (check-attr-arity x ctx))])
(iattrs->sattrs (append-iattrs (map list iattrs)))))
;; check-attr-arity : stx -> IAttr
(define (check-attr-arity stx)
;; check-attr-arity : stx stx -> IAttr
(define (check-attr-arity stx ctx)
(syntax-case stx ()
[attr
(identifier? #'attr)
(make-attr #'attr 0 #f)]
[(attr depth)
(begin (unless (identifier? #'attr)
(wrong-syntax #'attr "expected attribute name"))
(raise-syntax-error #f "expected attribute name" ctx #'attr))
(unless (exact-nonnegative-integer? (syntax-e #'depth))
(wrong-syntax #'depth "expected depth (nonnegative integer)"))
(raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth))
(make-attr #'attr (syntax-e #'depth) #f))]
[_
(wrong-syntax stx "expected attribute name with optional depth declaration")]))
(raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
;; check-literals-list : syntax -> (listof (list id id))
(define (check-literals-list stx)
;; check-literals-list : stx stx -> (listof (list id id))
(define (check-literals-list stx ctx)
(unless (stx-list? stx)
(wrong-syntax stx "expected literals list"))
(let ([lits (map check-literal-entry (stx->list stx))])
(raise-syntax-error #f "expected literals list" ctx stx))
(let ([lits (for/list ([x (stx->list stx)]) (check-literal-entry x ctx))])
(let ([dup (check-duplicate-identifier (map car lits))])
(when dup (wrong-syntax dup "duplicate literal identifier")))
(when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
lits))
;; check-literal-entry : syntax -> (list id id)
(define (check-literal-entry stx)
;; check-literal-entry : stx stx -> (list id id)
(define (check-literal-entry stx ctx)
(syntax-case stx ()
[(internal external)
(and (identifier? #'internal) (identifier? #'external))
@ -744,96 +748,103 @@
(identifier? #'id)
(list #'id #'id)]
[_
(wrong-syntax stx
"expected literal (identifier or pair of identifiers)")]))
(raise-syntax-error #f "expected literal (identifier or pair of identifiers)" ctx stx)]))
(define (check-literal-sets-list stx)
(define (check-literal-sets-list stx ctx)
(unless (stx-list? stx)
(wrong-syntax stx "expected literal-set list"))
(map check-literal-set-entry (stx->list stx)))
(raise-syntax-error #f "expected literal-set list" ctx stx))
(for/list ([x (stx->list stx)])
(check-literal-set-entry x ctx)))
(define (check-literal-set-entry stx)
(define (elaborate litset-id context)
(define (check-literal-set-entry stx ctx)
(define (elaborate litset-id lctx)
(let ([litset (syntax-local-value litset-id (lambda () #f))])
(unless (literalset? litset)
(wrong-syntax litset-id "expected identifier defined as a literal-set"))
(elaborate-litset litset context stx)))
(raise-syntax-error #f "expected identifier defined as a literal-set" ctx litset-id))
(elaborate-litset litset lctx stx)))
(syntax-case stx ()
[(litset #:at context)
(and (identifier? #'litset) (identifier? #'context))
(elaborate #'litset #'context)]
[(litset #:at lctx)
(and (identifier? #'litset) (identifier? #'lctx))
(elaborate #'litset #'lctx)]
[litset
(identifier? #'litset)
(elaborate #'litset #'litset)]
[_
(wrong-syntax stx "expected literal-set entry")]))
(raise-syntax-error #f "expected literal-set entry" ctx stx)]))
(define (elaborate-litset litset context ctx)
(define (elaborate-litset litset lctx srcctx)
(for/list ([entry (literalset-literals litset)])
(list (datum->syntax context (car entry) ctx)
(list (datum->syntax lctx (car entry) srcctx)
(cadr entry))))
(define (check-conventions-list stx)
(define (check-conventions-list stx ctx)
(unless (stx-list? stx)
(wrong-syntax stx "expected conventions list"))
(map check-conventions (stx->list stx)))
(raise-syntax-error #f "expected conventions list" ctx stx))
(for/list ([x (stx->list stx)])
(check-conventions x ctx)))
(define (check-conventions stx)
(define (check-conventions stx ctx)
(define (elaborate conventions-id)
(let ([cs (syntax-local-value conventions-id (lambda () #f))])
(unless (conventions? cs)
(wrong-syntax conventions-id "expected identifier defined as a conventions"))
(raise-syntax-error #f "expected identifier defined as a conventions" ctx conventions-id))
(conventions-rules cs)))
(syntax-case stx ()
[conventions
(identifier? #'conventions)
(elaborate #'conventions)]
[_
(wrong-syntax stx "expected conventions entry")]))
(raise-syntax-error "expected conventions entry" ctx stx)]))
(define (check-conventions-rules stx)
(define (check-conventions-rules stx ctx)
(unless (stx-list? stx)
(wrong-syntax stx "expected convention rule list"))
(map check-conventions-rule (stx->list stx)))
(raise-syntax-error #f "expected convention rule list" ctx stx))
(for/list ([x (stx->list stx)])
(check-conventions-rule x ctx)))
(define (check-conventions-rule stx)
(define (check-conventions-rule stx ctx)
(define (check-conventions-pattern x blame)
(cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))]
[(regexp? x) x]
[else (wrong-syntax blame "expected identifier convention pattern")]))
[else (raise-syntax-error #f "expected identifier convention pattern" ctx blame)]))
(define (check-sc-expr x)
(syntax-case x ()
[sc (identifier? #'sc) (list #'sc null)]
[(sc arg ...) (identifier? #'sc) (list #'sc #'(arg ...))]
[_ (wrong-syntax x "expected syntax class use")]))
[_ (raise-syntax-error #f "expected syntax class use" ctx x)]))
(syntax-case stx ()
[(rx sc)
(list (check-conventions-pattern (syntax-e #'rx) #'rx)
(check-sc-expr #'sc))]))
;; parse-directive-table
(define parse-directive-table
;; common-parse-directive-table
(define common-parse-directive-table
(list (list '#:literals check-literals-list)
(list '#:literal-sets check-literal-sets-list)
(list '#:conventions check-conventions-list)))
;; parse-directive-table
(define parse-directive-table
(list* (list '#:context check-expression)
common-parse-directive-table))
;; rhs-directive-table
(define rhs-directive-table
(list* (list '#:description values)
(list* (list '#:description check-expression)
(list '#:transparent)
(list '#:attributes check-attr-arity-list)
(list '#:auto-nested-attributes)
parse-directive-table))
common-parse-directive-table))
;; pattern-directive-table
(define pattern-directive-table
(list (list '#:declare check-id values)
(list '#:fail-when values values)
(list '#:fail-unless values values)
(list '#:with values values)
(list '#:attr check-attr-arity values)))
(list (list '#:declare check-identifier check-expression)
(list '#:fail-when check-expression check-expression)
(list '#:fail-unless check-expression check-expression)
(list '#:with check-expression check-expression)
(list '#:attr check-attr-arity check-expression)))
;; fail-directive-table
(define fail-directive-table
(list (list '#:when values)
(list '#:unless values)))
(list (list '#:when check-expression)
(list '#:unless check-expression)))

14
collects/syntax/private/stxparse/runtime-prose.ss
View File

@ -10,13 +10,25 @@
(for-syntax "rep-data.ss")
(for-syntax "../util/error.ss")
"runtime.ss")
(provide default-failure-handler)
(provide syntax-patterns-fail
current-failure-handler)
;; Failure reporting parameter & default
(define (default-failure-handler stx0 f)
(match (simplify-failure f)
[(struct failure (x frontier frontier-stx expected))
(report-failure stx0 x (last frontier) frontier-stx expected)]))
(define current-failure-handler
(make-parameter default-failure-handler))
(define ((syntax-patterns-fail stx0) f)
(let ([value ((current-failure-handler) stx0 f)])
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e" value)))
;; report-failure : stx stx number stx Expectation -> (escapes)
(define (report-failure stx0 x index frontier-stx expected)
(define (err msg stx0 stx)

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

@ -87,7 +87,7 @@
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(with-syntax ([([entry (def ...)] ...)
(for/list ([line (check-conventions-rules #'(rule ...))])
(for/list ([line (check-conventions-rules #'(rule ...) stx)])
(let ([rx (car line)]
[sc (car (cadr line))]
[args (cadr (cadr line))])
@ -111,7 +111,7 @@
(begin
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(let ([lits (check-literals-list #'(lit ...))])
(let ([lits (check-literals-list #'(lit ...) stx)])
(with-syntax ([((internal external) ...) lits])
#'(define-syntax name
(make-literalset
@ -189,10 +189,7 @@
'report-errors-as
(syntax-e #'report-as))))
#`(let ([x expr])
(let ([fail (syntax-patterns-fail x)])
(with-enclosing-fail* fail
(parameterize ((current-expression (or (current-expression) x)))
(parse:clauses x clauses)))))))]))
(parse:clauses x clauses))))]))
(define-syntax with-patterns
(syntax-rules ()
@ -200,14 +197,3 @@
(let () . b)]
[(with-patterns ([p x] . more) . b)
(syntax-parse x [p (with-patterns more . b)])]))
;; Failure reporting parameter & default
(define current-failure-handler
(make-parameter default-failure-handler))
(define ((syntax-patterns-fail stx0) f)
(let ([value ((current-failure-handler) stx0 f)])
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e" value)))

4
collects/syntax/private/util/misc.ss
View File

@ -23,6 +23,7 @@
in-stx-list
in-stx-list/unwrap
#|
parse-kw-options
extract-kw-option
chunk-kw-seq/no-dups
@ -32,7 +33,8 @@
check-id
check-nat/f
check-string
check-idlist)
check-idlist
|#)
;; Unwrapping syntax

255
collects/syntax/scribblings/keyword.scrbl Normal file
View File

@ -0,0 +1,255 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
scheme/sandbox
(for-label scheme/base
scheme/contract
scheme/dict
syntax/keyword))
@(begin
(define the-eval
(parameterize ((sandbox-output 'string)
(sandbox-error-output 'string))
(make-evaluator 'scheme/base #:requires '(syntax/keyword))))
;;(void (the-eval '(error-print-source-location #f)))
(define-syntax-rule (myexamples e ...)
(parameterize (#|(error-print-source-location #f)|#)
(examples #:eval the-eval e ...))))
@title[#:tag "stxkeyword"]{Helpers for Processing Keyword Syntax}
The @schememodname[syntax/keyword] module contains procedures for
parsing keyword options in macros.
@defmodule[syntax/keyword]
@schemegrammar[#, @deftech{keyword-table}
(dict-of keyword (listof check-procedure))]
A keyword-table is a dictionary (@scheme[dict?]) mapping keywords to
lists of @techlink{check-procedures}. (Note that an association list is a
suitable dictionary.) The keyword's arity is the length of the list of
procedures.
@myexamples[
(define my-keyword-table
(list (list '#:a check-identifier)
(list '#:b check-expression check-expression)))
]
@schemegrammar[#, @deftech{check-procedure}
(syntax syntax -> any)]
A check procedure consumes the syntax to check and a context syntax
object for error reporting and either raises an error to reject the
syntax or returns a value as its parsed representation.
@myexamples[
(define (check-stx-string stx context-stx)
(unless (string? (syntax-e stx))
(raise-syntax-error #f "expected string" context-stx stx))
stx)
]
@schemegrammar[#, @deftech{options}
(listof (list keyword syntax-keyword any ...))]
Parsed options are represented as an list of option entries. Each
entry contains the keyword, the syntax of the keyword (for error
reporting), and the list of parsed values returned by the keyword's
list of check procedures. The list contains the parsed options in the
order they appeared in the input, and a keyword that occurs multiple
times in the input occurs multiple times in the options list.
@defproc[(parse-keyword-options [stx syntax?]
[table #, @techlink{keyword-table}]
[#:context ctx (or/c false/c syntax?) #f]
[#:no-duplicates? no-duplicates? boolean? #f]
[#:incompatible incompatible (listof (listof keyword?)) '()]
[#:on-incompatible incompatible-handler
(-> keyword? keyword?
#, @techlink{options} syntax? syntax?
(values #, @techlink{options} syntax?))
(lambda (....) (error ....))]
[#:on-too-short too-short-handler
(-> keyword? #, @techlink{options} syntax? syntax?
(values #, @techlink{options} syntax?))
(lambda (....) (error ....))]
[#:on-not-in-table not-in-table-handler
(-> keyword? #, @techlink{options} syntax? syntax?
(values #, @techlink{options} syntax?))
(lambda (....) (error ....))])
(values #, @techlink{options} any/c)]{
Parses the keyword options in the syntax @scheme[stx] (@scheme[stx]
may be an improper syntax list). The keyword options are described in
the @scheme[table] association list. Each entry in @scheme[table]
should be a list whose first element is a keyword and whose subsequent
elements are procedures for checking the arguments following the
keyword. The keyword's arity (number of arguments) is determined by
the number of procedures in the entry. Only fixed-arity keywords are
supported.
Parsing stops normally when the syntax list does not have a keyword at
its head (it may be empty, start with a non-keyword term, or it may be
a non-list syntax object). Two values are returned: the parsed
@techlink{options} and the rest of the syntax (generally either a
syntax object or a list of syntax objects).
A variety of errors and exceptional conditions can occur during the
parsing process. The following keyword arguments determine the
behavior in those situations.
The @scheme[#:context ctx] argument is used to report all errors in
parsing syntax. In addition, @scheme[ctx] is passed as the final
argument to all provided handler procedures. Macros using
@scheme[parse-keyword-options] should generally pass the syntax object
for the whole macro use as @scheme[ctx].
If @scheme[no-duplicates?] is a non-false value, then duplicate
keyword options are not allowed. If a duplicate is seen, the keyword's
associated check procedures are not called and an @tech{incompatibility} is
reported.
The @scheme[incompatible] argument is a list of incompatibility
entries, where each entry is a list of @emph{at least two}
keywords. If any keyword in the entry occurs after any other keyword
in the entry, an @tech{incompatibility} is reported.
Note that including a keyword in an incompatibility entry does not
prevent it from occurring multiple times. To disallow duplicates of
some keywords (as opposed to all keywords), include those keywords in
the @scheme[incompatible] list as being incompatible with
themselves. That is, include them twice:
@schemeblock[
(code:comment "Disallow duplicates of only the #:foo keyword")
(parse-keyword-options .... #:incompatible '((#:foo #:foo)))
]
When an @deftech{incompatibility} occurs, the
@scheme[incompatible-handler] is tail-called with the two keywords
causing the incompatibility (in the order that they occurred in the
syntax list, so the keyword triggering the incompatibility occurs
second), the syntax list starting with the occurrence of the second
keyword, and the context (@scheme[ctx]). If the incompatibility is due
to a duplicate, the two keywords are the same.
When a keyword is not followed by enough arguments according to its
arity in @scheme[table], the @scheme[too-short-handler] is tail-called
with the keyword, the @techlink{options} parsed thus far, the syntax list
starting with the occurrence of the keyword, and @scheme[ctx].
When a keyword occurs in the syntax list that is not in
@scheme[table], the @scheme[not-in-table-handler] is tail-called with
the keyword, the @techlink{options} parsed thus far, the syntax list
starting with the occurrence of the keyword, and @scheme[ctx].
Handlers typically escape---all of the default handlers raise
errors---but if they return, they should return two values: the parsed
@techlink{options} and a syntax object; these are returned as the results
of @scheme[parse-keyword-options].
@(myexamples
(parse-keyword-options
#'(#:transparent #:property p (lambda (x) (f x)))
(list (list '#:transparent)
(list '#:inspector check-expression)
(list '#:property check-expression check-expression)))
(parse-keyword-options
#'(#:transparent #:inspector (make-inspector))
(list (list '#:transparent)
(list '#:inspector check-expression)
(list '#:property check-expression check-expression))
#:context #'define-struct
#:incompatible '((#:transparent #:inspector)
(#:inspector #:inspector)
(#:inspector #:inspector))))
}
@defproc[(parse-keyword-options/eol [stx syntax?]
[table #, @techlink{keyword-table}]
[#:context ctx (or/c false/c syntax?) #f]
[#:no-duplicates? no-duplicates? boolean? #f]
[#:incompatible incompatible (listof (list keyword? keyword?)) '()]
[#:on-incompatible incompatible-handler
(-> keyword? keyword?
#, @techlink{options} syntax? syntax?
(values #, @techlink{options} syntax?))
(lambda (....) (error ....))]
[#:on-too-short too-short-handler
(-> keyword? #, @techlink{options} syntax? syntax?
(values #, @techlink{options} syntax?))
(lambda (....) (error ....))]
[#:on-not-in-table not-in-table-handler
(-> keyword? #, @techlink{options} syntax? syntax?
(values #, @techlink{options} syntax?))
(lambda (....) (error ....))]
[#:on-not-eol not-eol-handler
(-> #, @techlink{options} syntax? syntax?
#, @techlink{options})
(lambda (....) (error ....))])
#, @techlink{options}]{
Like @scheme[parse-keyword-options], but checks that there are no
terms left over after parsing all of the keyword options. If there
are, @scheme[not-eol-handler] is tail-called with the @techlink{options}
parsed thus far, the leftover syntax, and @scheme[ctx].
}
@defproc[(options-select [options #, @techlink{options}]
[keyword keyword?])
(listof list?)]{
Selects the values associated with one keyword from the parsed
@techlink{options}. The resulting list has as many items as there were
occurrences of the keyword, and each element is a list whose length is
the arity of the keyword.
}
@defproc[(options-select-one [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 is returned. Otherwise,
the @scheme[default] list is returned.
}
@defproc[(check-identifier [stx syntax?] [ctx (or/c false/c syntax?)]) identifier?]{
A @techlink{check-procedure} that accepts only identifiers.
}
@defproc[(check-expression [stx syntax?] [ctx (or/c false/c syntax?)]) syntax?]{
A @techlink{check-procedure} that accepts any non-keyword term. It does
not actually check that the term is a valid expression.
}
@defproc[((check-stx-listof [check #, @techlink{check-procedure}])
[stx syntax?] [ctx (or/c false/c syntax?)])
(listof any/c)]{
Lifts a @techlink{check-procedure} to accept syntax lists of whatever the
original procedure accepted.
}
@defproc[(check-stx-string [stx syntax?] [ctx (or/c false/c syntax?)]) syntax?]{
A @techlink{check-procedure} that accepts syntax strings.
}

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

@ -273,7 +273,8 @@ examining its structure. Syntax classes are useful for the same
purpose, but @scheme[~and] can be lighter weight.
@(interaction-eval #:eval the-eval
(begin (define (check-imports . _) #f)))
(begin (define import #f)
(define (check-imports . _) #f)))
@myexamples[
(syntax-parse #'(m (import one two))

1
collects/syntax/scribblings/syntax-object-helpers.scrbl
View File

@ -10,5 +10,6 @@
@include-section["to-string.scrbl"]
@include-section["free-vars.scrbl"]
@include-section["strip-context.scrbl"]
@include-section["keyword.scrbl"]
@include-section["zodiac.scrbl"]

6
collects/tests/stxclass/more-tests.ss
View File

@ -37,16 +37,16 @@
(define-syntax (m stx)
(syntax-parse stx
[(_ x)
#:declare x (static-of number? "identifier bound to number")
#:declare x (static number? "identifier bound to number")
#`(quote #,(attribute x.value))]))
(test-case "static-of: right error"
(test-case "static: 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"
(test-case "static: works"
(check-equal? (convert-syntax-error (m zero))
0))