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

syntax/parse:

Browse Source 
added nested ~or ellipsis-head patterns
  added ~between, ...+
  cleaned up declenvs
  fixed kernel-literals (include template phase binding)
  pattern variables may not start with ~ (tilde)
  first cut of syntax-class-possible-errors

svn: r17937
This commit is contained in:
Ryan Culpepper 2010-02-02 02:28:32 +00:00
parent 87712b0dd2
commit cb7600607b
9 changed files with 358 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,11 +3,9 @@
(require "sc.ss"
"../util.ss"
syntax/stx
syntax/kerncase
scheme/struct-info
scheme/contract/private/helpers
(for-syntax scheme/base
syntax/kerncase
"rep.ss"
(only-in "rep-data.ss" make-literalset))
(for-template scheme/base
@ -115,9 +113,26 @@
(quote-syntax #,(syntax/loc #'x (<there>))))))
;; Literal sets
(define-syntax kernel-literals
(make-literalset
(list* (list '#%plain-module-begin (quote-syntax #%plain-module-begin))
(for/list ([id (kernel-form-identifier-list)])
(list (syntax-e id) id)))))
(define-literal-set kernel-literals
(begin
begin0
define-values
define-syntaxes
define-values-for-syntax
set!
let-values
letrec-values
#%plain-lambda
case-lambda
if
quote
letrec-syntaxes+values
with-continuation-mark
#%expression
#%plain-app
#%top
#%datum
#%variable-reference
module #%provide #%require
#%plain-module-begin))

1
collects/syntax/private/stxparse/minimatch.ss
View File

@ -77,6 +77,7 @@
(match-p xps (list p ...) success failure))
failure)))]))
#;
(define-syntax struct
(lambda (stx)
(raise-syntax-error #f "illegal use of keyword" stx)))

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

@ -52,15 +52,18 @@
(syntax-case stx ()
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...))
relsattrs (arg ...) get-description splicing?)
#`(lambda (x arg ...)
(define (fail-rhs failure)
(expectation-of-thing (get-description arg ...)
transparent?
(if transparent? failure #f)))
def ...
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
(with-enclosing-fail* fail-rhs
(parse:variants x relsattrs variants splicing?))))]))
#`(with-error-collector
(make-parser
(lambda (x arg ...)
(define (fail-rhs failure)
(expectation-of-thing (get-description arg ...)
transparent?
(if transparent? failure #f)))
def ...
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
(with-enclosing-fail* fail-rhs
(parse:variants x relsattrs variants splicing?))))
(collect-error)))]))
;; (parse:variants id (SAttr ...) (Variant ...) boolean)
;; : expr[SyntaxClassResult]
@ -566,17 +569,19 @@
;; (expectation Pattern)
(define-syntax (expectation stx)
(syntax-case stx ()
[(_ #s(pat:datum attrs datum))
#'(make-expect:atom 'datum)]
[(_ #s(pat:literal attrs literal))
#'(make-expect:literal (quote-syntax literal))]
[(_ #s(pat:datum attrs d))
#'(begin (collect-error '(datum d))
(make-expect:atom 'd))]
[(_ #s(pat:literal attrs lit))
#'(begin (collect-error '(literal lit))
(make-expect:literal (quote-syntax lit)))]
;; 2 pat:compound patterns
;;[(_ #s(pat:compound attrs #:pair (head-pattern tail-pattern)))
;; #'(make-expect:pair)]
[(_ #s(pat:compound attrs kind0 (part-pattern ...)))
#''ineffable]
#'(collect-error 'ineffable)]
[(_ #s(pat:not _ pattern))
#''ineffable]
#'(collect-error 'ineffable)]
[(_ #s(ghost:fail _ condition message))
#'(expectation-of-message message)]))
@ -586,8 +591,10 @@
(make-expect:thing description transparent? chained))
(define-syntax-rule (expectation-of-message message)
(let ([msg message])
(if msg (make-expect:message msg) 'ineffable)))
(let ([msg (collect-error message)])
(if msg
(make-expect:message msg)
'ineffable)))
(define-syntax expectation-of-reps/too-few
(syntax-rules ()
@ -607,18 +614,43 @@
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
(expectation-of-message/too-many too-many-msg name)]))
(define-syntax-rule (expectation-of-message/too-few msg name)
(expectation-of-message
(or msg
(let ([n name])
(if n
(format "missing required occurrence of ~a" n)
"repetition constraint violated")))))
(define-syntax expectation-of-message/too-few
(syntax-rules ()
[(emtf #f #f)
(collect-error "repetition constraint violated")]
[(emtf #f name)
(collect-error (format "missing required occurrence of ~a" name))]
[(emtf msg _)
(collect-error msg)]))
(define-syntax-rule (expectation-of-message/too-many msg name)
(expectation-of-message
(or msg
(let ([n name])
(if n
(format "too many occurrences of ~a" n)
"repetition constraint violated")))))
(define-syntax expectation-of-message/too-many
(syntax-rules ()
[(emtm #f #f)
(collect-error (format "repetition constraint violated"))]
[(emtm #f name)
(collect-error (format "too many occurrences of ~a" name))]
[(emtm msg _)
(collect-error msg)]))
;;
(define-syntax-parameter collect-error
(syntax-rules ()
[(ce thing) thing]
[(ce) '()]))
(define-syntax-rule (with-error-collector body)
(...
(let-syntax ([tmp (box null)])
(syntax-parameterize ((collect-error
(lambda (stx)
(let ([b (syntax-local-value #'tmp)])
(syntax-case stx ()
[(ce thing)
(begin (set-box! b (cons #''thing (unbox b)))
#'thing)]
[(ce)
(with-syntax ([(thing ...) (reverse (unbox b))])
#'(list thing ...))])))))
body))))

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

@ -4,6 +4,7 @@
syntax/stx
syntax/id-table
"../util.ss"
"minimatch.ss"
"rep-attrs.ss"
"rep-patterns.ss")
(provide (all-from-out "rep-attrs.ss")
@ -81,14 +82,18 @@ A LiteralSet is
DeclEnv =
(make-declenv immutable-bound-id-mapping[id => DeclEntry]
(listof ConventionRule))
DeclEntry =
(list 'literal id id)
(list 'stxclass id id (listof stx))
(list 'parser id id (listof IAttr))
#f
(make-den:lit id id)
(make-den:class id id (listof syntax) bool)
(make-den:parser id id (listof SAttr) bool)
|#
(define-struct declenv (table conventions))
(define-struct den:lit (internal external))
(define-struct den:class (name class args))
(define-struct den:parser (parser description attrs splicing?))
(define (new-declenv literals #:conventions [conventions null])
(for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)])
([literal literals])
@ -104,45 +109,63 @@ DeclEntry =
;; Order goes: literals, pattern, declares
;; So blame-declare? only applies to stxclass declares
(let ([val (declenv-lookup env id #:use-conventions? #f)])
(when val
(cond [(eq? 'literal (car val))
(wrong-syntax id "identifier previously declared as literal")]
[(and blame-declare? stxclass-name)
(wrong-syntax (cadr val)
"identifier previously declared with syntax class ~a"
stxclass-name)]
[else
(wrong-syntax (if blame-declare? (cadr val) id)
"identifier previously declared")]))))
(match val
[(struct den:lit (_i _e))
(wrong-syntax id "identifier previously declared as literal")]
[(struct den:class (name _c _a))
(if (and blame-declare? stxclass-name)
(wrong-syntax name
"identifier previously declared with syntax class ~a"
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(struct den:parser (_p _d _a _sp))
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
(define (declenv-put-literal env internal-id lit-id)
(declenv-check-unbound env internal-id)
(make-declenv
(bound-id-table-set (declenv-table env) internal-id
(list 'literal internal-id lit-id))
(make den:lit internal-id lit-id))
(declenv-conventions env)))
(define (declenv-put-stxclass env id stxclass-name args)
(declenv-check-unbound env id)
(make-declenv
(bound-id-table-set (declenv-table env) id
(list 'stxclass id stxclass-name args))
(make den:class id stxclass-name args))
(declenv-conventions env)))
(define (declenv-put-parser env id parser get-description attrs splicing?)
;; no unbound check, since replacing 'stxclass entry
(make-declenv
(bound-id-table-set (declenv-table env) id
(list (if splicing? 'splicing-parser 'parser)
parser get-description attrs))
(make den:parser parser get-description attrs splicing?))
(declenv-conventions env)))
;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
;; -> (values DeclEnv a)
(define (declenv-update/fold env0 f acc0)
(define-values (acc1 rules1)
(for/fold ([acc acc0] [newrules null])
([rule (declenv-conventions env0)])
(let-values ([(val acc) (f (car rule) (cadr rule) acc)])
(values acc (cons (list (car rule) val) newrules)))))
(define-values (acc2 table2)
(for/fold ([acc acc1] [table (make-immutable-bound-id-table)])
([(k v) (in-dict (declenv-table env0))])
(let-values ([(val acc) (f k v acc)])
(values acc (bound-id-table-set table k val)))))
(values (make-declenv table2 (reverse rules1))
acc2))
;; returns ids in domain of env but not in given list
(define (declenv-domain-difference env ids)
(define idbm (make-bound-id-table))
(for ([id ids]) (bound-id-table-set! idbm id #t))
(for/list ([(k v) (in-dict (declenv-table env))]
#:when (and (pair? v) (not (eq? (car v) 'literal)))
#:when (or (den:class? v) (den:parser? v))
#:when (not (bound-id-table-ref idbm k #f)))
k))
@ -158,11 +181,19 @@ DeclEntry =
(define DeclEnv/c
(flat-named-contract 'DeclEnv declenv?))
(define DeclEntry/c
(flat-named-contract 'DeclEntry (or/c den:lit? den:class? den:parser?)))
(define SideClause/c
(or/c clause:fail? clause:with? clause:attr?))
(provide (struct-out den:lit)
(struct-out den:class)
(struct-out den:parser))
(provide/contract
[DeclEnv/c contract?]
[DeclEntry/c contract?]
[SideClause/c contract?]
[make-dummy-stxclass (-> identifier? stxclass?)]
@ -177,14 +208,20 @@ DeclEntry =
[declenv-put-stxclass
(-> DeclEnv/c identifier? identifier? (listof syntax?)
DeclEnv/c)]
[declenv-put-literal
(-> DeclEnv/c identifier? identifier?
DeclEnv/c)]
[declenv-put-parser
(-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean?
DeclEnv/c)]
[declenv-domain-difference
(-> DeclEnv/c (listof identifier?)
(listof identifier?))]
[declenv-table
(-> DeclEnv/c any)]
[declenv-update/fold
(-> DeclEnv/c
(-> (or/c identifier? regexp?) DeclEntry/c any/c (values DeclEntry/c any/c))
any/c
(values DeclEnv/c any/c))]
[get-stxclass
(-> identifier? any)]

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

@ -18,7 +18,7 @@
(provide/contract
[parse-rhs
(-> syntax? boolean? boolean? #:context (or/c false/c syntax?)
(-> syntax? (or/c false/c (listof sattr?)) boolean? #:context (or/c false/c syntax?)
rhs?)]
[parse-whole-pattern
(-> syntax? DeclEnv/c #:context (or/c false/c syntax?)
@ -39,8 +39,8 @@
(values DeclEnv/c (listof syntax?)))]
|#
[create-aux-def
(-> list? ;; DeclEntry
(values identifier? identifier? (listof sattr?) (listof syntax?) boolean?))]
(-> DeclEntry/c
(values DeclEntry/c (listof syntax?)))]
[check-literals-list
(-> syntax? syntax?
(listof (list/c identifier? identifier?)))]
@ -67,9 +67,10 @@
(free-identifier=? stx kw)
(begin (disappeared! stx) #t))))
(define wildcard? (id-predicate (quote-syntax _)))
(define epsilon? (id-predicate (quote-syntax ||)))
(define dots? (id-predicate (quote-syntax ...)))
(define wildcard? (id-predicate (quote-syntax _)))
(define epsilon? (id-predicate (quote-syntax ||)))
(define dots? (id-predicate (quote-syntax ...)))
(define plus-dots? (id-predicate (quote-syntax ...+)))
(define keywords
(list (quote-syntax _)
@ -85,13 +86,14 @@
(quote-syntax ~rep)
(quote-syntax ~once)
(quote-syntax ~optional)
(quote-syntax ~bounds)
(quote-syntax ~between)
(quote-syntax ~rest)
(quote-syntax ~describe)
(quote-syntax ~!)
(quote-syntax ~bind)
(quote-syntax ~fail)
(quote-syntax ~parse)))
(quote-syntax ~parse)
(quote-syntax ...+)))
(define (reserved? stx)
(and (identifier? stx)
@ -116,20 +118,20 @@
;; ---
;; parse-rhs : stx boolean boolean stx -> RHS
;; If strict? is true, then referenced stxclasses must be defined and
;; parse-rhs : stx boolean (or #f (listof SAttr)) stx -> RHS
;; If expected-attrs is true, then referenced stxclasses must be defined and
;; literals must be bound. Set to #f for pass1 (attr collection);
;; parser requires stxclasses to be bound.
(define (parse-rhs stx strict? splicing? #:context ctx)
(define (parse-rhs stx expected-attrs splicing? #:context ctx)
(parameterize ((current-syntax-context ctx))
(define-values (rest description transp? attributes auto-nested? decls defs)
(parse-rhs/part1 stx strict?))
(parse-rhs/part1 stx (and expected-attrs #t)))
(define patterns
(parameterize ((stxclass-lookup-config
(cond [strict? 'yes]
(cond [expected-attrs 'yes]
[auto-nested? 'try]
[else 'no])))
(parse-variants rest decls splicing?)))
(parse-variants rest decls splicing? expected-attrs)))
(when (null? patterns)
(wrong-syntax #f "expected at least one variant"))
(let ([sattrs
@ -151,12 +153,12 @@
(define-values (decls defs) (get-decls+defs chunks strict?))
(values rest description transparent? attributes auto-nested? decls defs))
(define (parse-variants rest decls splicing?)
(define (parse-variants rest decls splicing? expected-attrs)
(define (gather-patterns stx)
(syntax-case stx (pattern)
[((pattern . _) . rest)
(begin (disappeared! (stx-car stx))
(cons (parse-variant (stx-car stx) splicing? decls)
(cons (parse-variant (stx-car stx) splicing? decls expected-attrs)
(gather-patterns #'rest)))]
[(bad-variant . rest)
(wrong-syntax #'bad-variant "expected syntax-class variant")]
@ -175,10 +177,11 @@
(define lits (options-select-value chunks '#:literals #:default null))
(define litsets (options-select-value chunks '#:literal-sets #:default null))
(define convs (options-select-value chunks '#:conventions #:default null))
(define localconvs (options-select-value chunks '#:local-conventions #:default null))
(define literals
(append-lits+litsets (check-literals-bound lits strict?)
litsets))
(define convention-rules (apply append convs))
(define convention-rules (apply append (cons localconvs convs)))
(new-declenv literals #:conventions convention-rules))
(define (check-literals-bound lits strict?)
@ -195,31 +198,34 @@
;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
(define (decls-create-defs decls0)
(for/fold ([decls decls0] [defs null])
([(k v) (in-dict (declenv-table decls0))]
#:when (memq (car v) '(stxclass splicing-stxclass)))
(let-values ([(parser description attrs new-defs splicing?) (create-aux-def v)])
(values (declenv-put-parser decls k parser description attrs splicing?)
(append new-defs defs)))))
(define (updater key value defs)
(let-values ([(value newdefs) (create-aux-def value)])
(values value (append newdefs defs))))
(declenv-update/fold decls0 updater null))
;; create-aux-def : DeclEntry -> (values id id (listof SAttr) (listof stx) boolean)
;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
(define (create-aux-def entry)
(let ([sc-name (caddr entry)]
[args (cadddr entry)])
(let ([sc (get-stxclass/check-arg-count sc-name (length args))])
(with-syntax ([sc-parser (stxclass-parser-name sc)]
[sc-description (stxclass-description sc)])
(if (pair? args)
(with-syntax ([x (generate-temporary 'x)]
[parser (generate-temporary sc-name)]
[description (generate-temporary sc-name)]
[(arg ...) args])
(values #'parser #'description (stxclass-attrs sc)
(list #'(define (parser x) (sc-parser x arg ...))
#'(define (description) (description arg ...)))
(stxclass/h? sc)))
(values #'sc-parser #'sc-description (stxclass-attrs sc)
null (stxclass/h? sc)))))))
(match entry
[(struct den:lit (_i _e))
(values entry null)]
[(struct den:class (name class args))
(let ([sc (get-stxclass/check-arg-count class (length args))])
(with-syntax ([sc-parser (stxclass-parser-name sc)]
[sc-description (stxclass-description sc)])
(if (pair? args)
(with-syntax ([x (generate-temporary 'x)]
[parser (generate-temporary class)]
[description (generate-temporary class)]
[(arg ...) args])
(values (make den:parser #'parser #'description
(stxclass-attrs sc) (stxclass/h? sc))
(list #'(define (parser x) (sc-parser x arg ...))
#'(define (description) (description arg ...)))))
(values (make den:parser #'sc-parser #'sc-description
(stxclass-attrs sc) (stxclass/h? sc))
null))))]
[(struct den:parser (_p _d _a _sp))
(values entry null)]))
(define (append-lits+litsets lits litsets)
(define seen (make-bound-id-table lits))
@ -230,8 +236,8 @@
(bound-id-table-set! seen (car lit) #t)))
(apply append lits litsets))
;; parse-variant : stx boolean DeclEnv -> RHS
(define (parse-variant stx splicing? decls0)
;; parse-variant : stx boolean DeclEnv #f/(listof Sattr) -> RHS
(define (parse-variant stx splicing? decls0 expected-attrs)
(syntax-case stx (pattern)
[(pattern p . rest)
(let-values ([(rest decls defs clauses)
@ -249,6 +255,10 @@
(cons (pattern-attrs pattern)
(side-clauses-attrss clauses)))]
[sattrs (iattrs->sattrs attrs)])
(when expected-attrs
(parameterize ((current-syntax-context stx))
;; Called just for error-reporting
(reorder-iattrs expected-attrs attrs)))
(make variant stx sattrs pattern clauses defs)))]))
(define (side-clauses-attrss clauses)
@ -367,6 +377,10 @@
(dots? #'dots)
(begin (disappeared! #'dots)
(parse-pat:dots stx #'head #'tail decls))]
[(head plus-dots . tail)
(plus-dots? #'plus-dots)
(begin (disappeared! #'plus-dots)
(parse-pat:plus-dots stx #'head #'tail decls))]
[(head . tail)
(let ([headp (parse-*-pattern #'head decls #t #t)]
[tailp (parse-single-pattern #'tail decls)])
@ -394,47 +408,50 @@
(let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
(create-pat:compound `(#:pstruct ,key) (list lp))))]))
;; parse-ellipsis-head-pattern : stx DeclEnv number -> EllipsisHeadPattern
;; parse-ellipsis-head-pattern : stx DeclEnv number -> (listof EllipsisHeadPattern)
(define (parse-ellipsis-head-pattern stx decls)
(syntax-case stx (~bounds ~optional ~once)
(syntax-case stx (~or ~between ~optional ~once)
[(~or . _)
(begin
(unless (stx-list? stx)
(wrong-syntax stx "expected sequence of patterns"))
(apply append
(for/list ([sub (cdr (stx->list stx))])
(parse-ellipsis-head-pattern sub decls))))]
[(~optional . _)
(disappeared! stx)
(parse-ehpat/optional stx decls)]
(list (parse-ehpat/optional stx decls))]
[(~once . _)
(disappeared! stx)
(parse-ehpat/once stx decls)]
[(~bounds . _)
(list (parse-ehpat/once stx decls))]
[(~between . _)
(disappeared! stx)
(parse-ehpat/bounds stx decls)]
(list (parse-ehpat/bounds stx decls))]
[_
(let ([head (parse-head-pattern stx decls)])
(make ehpat (map increase-depth (pattern-attrs head))
head
#f))]))
(list (make ehpat (map increase-depth (pattern-attrs head))
head
#f)))]))
;; ----
(define (parse-pat:id id decls allow-head?)
(define entry (declenv-lookup decls id))
(match entry
[(list 'literal internal-id literal-id)
(create-pat:literal literal-id)]
[(list 'stxclass _ _ _)
[(struct den:lit (internal literal))
(create-pat:literal literal)]
[(struct den:class (_n _c _a))
(error 'parse-pat:id
"(internal error) decls had leftover 'stxclass entry: ~s"
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(list 'splicing-stxclass _ _ _)
(error 'parse-pat:id
"(internal error) decls had leftover 'splicing-stxclass entry: ~s"
entry)]
[(list 'parser parser description attrs)
(parse-pat:id/s id parser null attrs)]
[(list 'splicing-parser parser description attrs)
(parse-pat:id/h id parser null attrs)]
[(struct den:parser (parser desc attrs splicing?))
(if splicing?
(parse-pat:id/h id parser null attrs)
(parse-pat:id/s id parser null attrs))]
['#f
(when #f ;; FIXME: enable?
(when #t ;; FIXME: right place???
(unless (safe-name? id)
(wrong-syntax id "expected identifier not starting with ~ character")))
(wrong-syntax id "expected identifier not starting with ~~ character")))
(let-values ([(name sc) (split-id/get-stxclass id decls)])
(if sc
(parse-pat:var* id allow-head? name sc null)
@ -631,21 +648,21 @@
result))
(define (parse-pat:dots stx head tail decls)
(define headps
(syntax-case head (~or)
[(~or . _)
(begin
(unless (stx-list? head)
(wrong-syntax head "expected sequence of patterns"))
(unless (stx-pair? (stx-cdr head))
(wrong-syntax head "expected at least one pattern"))
(for/list ([sub (cdr (stx->list head))])
(parse-ellipsis-head-pattern sub decls)))]
[_
(list (parse-ellipsis-head-pattern head decls))]))
(define headps (parse-ellipsis-head-pattern head decls))
(define tailp (parse-single-pattern tail decls))
(unless (pair? headps)
(wrong-syntax head "expected at least one pattern"))
(create-pat:dots headps tailp))
(define (parse-pat:plus-dots stx head tail decls)
(define headp (parse-head-pattern head decls))
(define tailp (parse-single-pattern tail decls))
(define head/rep
(make-ehpat (map increase-depth (pattern-attrs headp))
headp
(make-rep:bounds 1 +inf.0 #f #f #f)))
(create-pat:dots (list head/rep) tailp))
(define (parse-pat:bind stx decls)
(syntax-case stx ()
[(_ clause ...)
@ -758,8 +775,8 @@
(make rep:once name too-few-msg too-many-msg))))]))
(define (parse-ehpat/bounds stx decls)
(syntax-case stx (~bounds)
[(~bounds p min max . options)
(syntax-case stx (~between)
[(~between p min max . options)
(let ([head (parse-head-pattern #'p decls)])
(define minN (syntax-e #'min))
(define maxN (syntax-e #'max))
@ -959,26 +976,32 @@
[_
(raise-syntax-error "expected conventions entry" ctx stx)]))
;; returns (listof (list regexp DeclEntry))
(define (check-conventions-rules stx ctx)
(unless (stx-list? stx)
(raise-syntax-error #f "expected convention rule list" ctx stx))
(for/list ([x (stx->list stx)])
(check-conventions-rule x ctx)))
;; returns (list regexp DeclEntry)
(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 (raise-syntax-error #f "expected identifier convention pattern" ctx blame)]))
(define (check-sc-expr x)
(define (check-sc-expr x rx)
(syntax-case x ()
[sc (identifier? #'sc) (list #'sc null)]
[(sc arg ...) (identifier? #'sc) (list #'sc (syntax->list #'(arg ...)))]
[sc
(identifier? #'sc)
(make den:class rx #'sc null)]
[(sc arg ...)
(identifier? #'sc)
(make den:class rx #'sc (syntax->list #'(arg ...)))]
[_ (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))]))
(check-sc-expr #'sc #'rx))]))
;; bind clauses
(define (check-bind-clause-list stx ctx)
@ -993,11 +1016,15 @@
(make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)]
[_ (raise-syntax-error #f "expected bind clause" ctx clause)]))
;; Directive tables
;; 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)))
(list '#:conventions check-conventions-list)
(list '#:local-conventions check-conventions-rules)))
;; parse-directive-table
(define parse-directive-table

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

@ -19,7 +19,7 @@
~or
~not
~seq
~bounds
~between
~once
~optional
~rest
@ -28,6 +28,7 @@
~bind
~fail
~parse
...+
current-expression
current-macro-name
@ -84,7 +85,7 @@
(define-keyword ~or)
(define-keyword ~not)
(define-keyword ~seq)
(define-keyword ~bounds)
(define-keyword ~between)
(define-keyword ~once)
(define-keyword ~optional)
(define-keyword ~rest)
@ -93,6 +94,7 @@
(define-keyword ~bind)
(define-keyword ~fail)
(define-keyword ~parse)
(define-keyword ...+)
;; == Parameters & Syntax Parameters
@ -569,3 +571,11 @@ An Expectation is one of
[(make expect:thing thing '#t chained)
(make expect:thing thing #t (failure->sexpr chained))]
[_ expectation]))
;;
(provide (struct-out parser))
(define-struct parser (proc errors)
#:property prop:procedure (struct-field-index proc))

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

@ -17,6 +17,7 @@
define-conventions
syntax-class-parse
syntax-class-attributes
syntax-class-possible-errors
debug-rhs
debug-pattern
@ -33,7 +34,7 @@
~or
~not
~seq
~bounds
~between
~once
~optional
~rest
@ -42,6 +43,7 @@
~bind
~fail
~parse
...+
attribute
this-syntax)
@ -93,15 +95,14 @@
(with-syntax ([([entry (def ...)] ...)
(for/list ([line (check-conventions-rules #'(rule ...) stx)])
(let ([rx (car line)]
[sc (car (cadr line))]
[args (cadr (cadr line))])
(let-values ([(parser description attrs defs splicing?)
(create-aux-def (list 'stxclass rx sc args))])
[den (cadr line)])
(let-values ([(den defs) (create-aux-def den)])
(list #`(list (quote #,rx)
(list (quote #,(if splicing? 'splicing-parser 'parser))
(quote-syntax #,parser)
(quote-syntax #,description)
(quote #,attrs)))
(make-den:parser
(quote-syntax #,(den:parser-parser den))
(quote-syntax #,(den:parser-description den))
(quote #,(den:parser-attrs den))
(quote #,(den:parser-splicing? den))))
defs))))])
#'(begin
def ... ...
@ -129,7 +130,8 @@
(with-disappeared-uses
(let ([rhs
(parameterize ((current-syntax-context #'ctx))
(parse-rhs #'rhss #t (syntax-e #'splicing?) #:context #'ctx))])
(parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
#:context #'ctx))])
#`(let ([get-description
(lambda args
#,(or (rhs-description rhs)
@ -165,6 +167,13 @@
[(depth ...) (map attr-depth attrs)])
#'(quote ((a depth) ...)))))]))
(define-syntax (syntax-class-possible-errors stx)
(syntax-case stx ()
[(_ s)
(parameterize ((current-syntax-context stx))
(with-syntax ([p (stxclass-parser-name (get-stxclass #'s))])
#'(parser-errors p)))]))
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)

71
collects/syntax/scribblings/parse-patterns.scrbl
View File

@ -97,8 +97,8 @@ means specifically @tech{@Spattern}.
(~datum datum)
(H-pattern . S-pattern)
(A-pattern . S-pattern)
((@#,ref[~or eh] EH-pattern ...+) #,ellipses . S-pattern)
(EH-pattern #,ellipses . S-pattern)
(H-pattern @#,(scheme ...+) . S-pattern)
(@#,ref[~and s] proper-S/A-pattern ...+)
(@#,ref[~or s] S-pattern ...+)
(~not S-pattern)
@ -112,8 +112,8 @@ means specifically @tech{@Spattern}.
()
(A-pattern . L-pattern)
(H-pattern . L-pattern)
((@#,ref[~or eh] EH-pattern ...+) #,ellipses . L-pattern)
(EH-pattern #,ellipses . L-pattern)
(H-pattern @#,(scheme ...+) . L-pattern)
(~rest L-pattern)]
[H-pattern
pvar-id:splicing-syntax-class-id
@ -125,8 +125,10 @@ means specifically @tech{@Spattern}.
(@#,ref[~describe h] expr H-pattern)
proper-S-pattern]
[EH-pattern
(@#,ref[~or eh] EH-pattern ...)
(~once H-pattern once-option ...)
(@#,ref[~optional eh] H-pattern optional-option ...)
(~between H min-number max-number between-option)
H-pattern]
[A-pattern
~!
@ -160,10 +162,10 @@ One of @ref[~and s], @ref[~and h], or @ref[~and a]:
@defidform[~or]{
One of @ref[~or s], @ref[~or h]), or @ref[~or eh]:
One of @ref[~or s], @ref[~or h], or @ref[~or eh]:
@itemize[
@item{@ref[~or eh] if the pattern occurs directly before ellipses
(@ellipses)}
(@ellipses) or immediately within another @ref[~or eh] pattern}
@item{@ref[~or h] if any of the disjuncts is a @tech{proper @Hpattern}}
@item{@ref[~or s] otherwise}
]
@ -396,11 +398,11 @@ words, @Apatterns ``don't take up space.''
See @tech{@Apatterns} for more information.
}
@specsubform[((@#,def[~or eh] EH-pattern ...+) #,ellipses . S-pattern)]{
@specsubform[(EH-pattern #,ellipses . S-pattern)]{
Matches any term that can be decomposed into a list head matching some
number of repetitions of @scheme[EH-pattern] alternatives (subject to
its repetition constraints) followed by a list tail matching
number of repetitions of the @scheme[EH-pattern] alternatives (subject
to its repetition constraints) followed by a list tail matching
@scheme[S-pattern].
In other words, the whole pattern matches either the second pattern
@ -411,10 +413,25 @@ the whole sequence pattern.
See @tech{@EHpatterns} for more information.
}
@specsubform[(EH-pattern #,ellipses . S-pattern)]{
@specsubform[(H-pattern @#,defhere[...+] . S-pattern)]{
Like an ellipses (@ellipses) pattern, but requires at one occurrence
of the head pattern to be present.
That is, the following patterns are equivalent:
@itemize[
@item[@scheme[(H ...+ . S)]]
@item[@scheme[((~between H 1 +inf.0) ... . S)]]
]
@myexamples[
(syntax-parse #'(1 2 3)
[(n:nat ...+) 'ok])
(syntax-parse #'()
[(n:nat ...+) 'ok]
[_ 'none])
]
The @scheme[~or]-free variant of ellipses (@ellipses) pattern is
equivalent to the @scheme[~or] variant with just one alternative.
}
@specsubform[(@#,def[~and s] S/A-pattern ...)]{
@ -704,7 +721,8 @@ An @deftech{@EHpattern} (abbreviated @svar[EH-pattern]) is pattern
that describes some number of terms, like a @tech{@Hpattern}, but may
also place contraints on the number of times it occurs in a
repetition. They are useful for matching keyword arguments where the
keywords may come in any order.
keywords may come in any order. Multiple alternatives can be grouped
together via @ref[~or eh].
@myexamples[
(define parser1
@ -725,6 +743,12 @@ arguments. The ``pieces'' can occur in any order.
Here are the variants of @elem{@EHpattern}:
@specsubform[(@#,def[~or eh] EH-pattern ...)]{
Matches if any of the inner @scheme[EH-pattern] alternatives match.
}
@specsubform/subs[(@#,defhere[~once] H-pattern once-option ...)
([once-option (code:line #:name name-expr)
(code:line #:too-few too-few-message-expr)
@ -734,11 +758,11 @@ Matches if the inner @scheme[H-pattern] matches. This pattern must be
selected exactly once in the match of the entire repetition sequence.
If the pattern is not chosen in the repetition sequence, then an error
is raised with a message, either @scheme[too-few-message-expr] or
is raised with the message either @scheme[too-few-message-expr] or
@schemevalfont{"missing required occurrence of @scheme[name-expr]"}.
If the pattern is chosen more than once in the repetition sequence,
then an error is raised with a message, either
then an error is raised with the message either
@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences
of @scheme[name-expr]"}.
}
@ -752,7 +776,7 @@ Matches if the inner @scheme[H-pattern] matches. This pattern may be used at
most once in the match of the entire repetition.
If the pattern is chosen more than once in the repetition sequence,
then an error is raised with a message, either
then an error is raised with the message either
@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences
of @scheme[name-expr]"}.
@ -762,6 +786,25 @@ sequence. The default attributes must be a subset of the subpattern's
attributes.
}
@specsubform/subs[(@#,defhere[~between] H-pattern min-number max-number between-option ...)
([reps-option (code:line #:name name-expr)
(code:line #:too-few too-few-message-expr)
(code:line #:too-many too-many-message-expr)])]{
Matches if the inner @scheme[H-pattern] matches. This pattern must be
selected at least @scheme[min-number] and at most @scheme[max-number]
times in the entire repetition.
If the pattern is chosen too few times, then an error is raised with a
message, either @scheme[too-few-message-expr] or @schemevalfont{"too
few occurrences of @scheme[name-expr]"}.
If the pattern is chosen too many times, then an error is raised with
the message either @scheme[too-many-message-expr] or
@schemevalfont{"too few occurrences of @scheme[name-expr]"}.
}
@;{--------}

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

@ -283,7 +283,8 @@ Two parsing forms are provided: @scheme[syntax-parse] and
([parse-option (code:line #:context context-expr)
(code:line #:literals (literal ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))]
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[literal literal-id
(pattern-id literal-id)]
[literal-set literal-set-id
@ -352,6 +353,13 @@ Imports @tech{convention}s that give default syntax classes to pattern
variables that do not explicitly specify a syntax class.
}
@specsubform[(code:line #:local-conventions (convention-rule ...))]{
Uses the @tech{conventions} specified. The advantage of
@scheme[#:local-conventions] over @scheme[#:conventions] is that local
conventions can be in the scope of syntax-class parameter bindings.
}
Each clause consists of a @tech{syntax pattern}, an optional sequence
of @tech{pattern directives}, and a non-empty sequence of body
expressions.
@ -386,7 +394,8 @@ structures can share syntax class definitions.
(code:line #:opaque)
(code:line #:literals (literal-entry ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))]
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[attr-arity-decl
attr-name-id
(attr-name-id depth)]
@ -713,8 +722,9 @@ identifiers the literal matches.
]
}
@defform/subs[(define-conventions name-id (id-pattern syntax-class) ...)
([name-pattern exact-id
@defform/subs[(define-conventions name-id convention-rule ...)
([convention-rule (name-pattern syntax-class)]
[name-pattern exact-id
name-rx]
[syntax-class syntax-class-id
(syntax-class-id expr ...)])]{