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

Merged changes to syntax/parse

Browse Source 
Changed backtracking algorithm, runtime representations
    - syntax classes, ~describe no longer implicitly commit
    - ~describe no longer delimits effect of cut
  Added keyword & optional args for stxclasses
  Added ~do and #:do, ~post, ~commit and #:commit,
    ~delimit-cut and #:no-delimit-cut
  Added syntax/parse/debug, syntax/parse/experimental/*
    - expr/c for contracting macro sub-expressions
      moved from syntax/parse to syntax/parse/experimental/contract
    - syntax class reflection (~reflect, ~splicing-reflect)
    - eh-alternative-sets (~eh-var)
    - provide-syntax-class/contract
      (only for params, not attrs so far)
  Changed ~fail to not include POST progress (#:fail still does)
    old (~fail _) is now (~post (~fail _))
  Made msg argument of ~fail optional
  Removed generic "repetition constraint violated" msg
  Removed atom-in-list stxclass
  Removed unnecessary datum->syntax on cdr of pair pattern
    massive improvements to long-list microbenchmarks
  Optimization: integrable syntax classes (id, expr, keyword)
    need better measurements
  Optimization: ad hoc elimination of head/tail choice point
    for (EH ... . ()) patterns
  Added unstable/wrapc (proc version of expr/c)
This commit is contained in:
Ryan Culpepper 2010-08-30 22:47:23 -06:00
parent 6e31d8f2d7
commit d7a87c79e0
64 changed files with 7407 additions and 4057 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/macro-debugger/model/reductions-engine.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require (for-syntax racket/base
syntax/parse)
syntax/parse
syntax/parse/experimental/contract)
racket/list
racket/contract
"deriv.rkt"

4
collects/meta/props
View File

@ -1318,6 +1318,10 @@ path/s is either such a string or a list of them.
"collects/swindle" responsible (eli)
"collects/swindle/tool.rkt" drdr:command-line (gracket-text "-t" *)
"collects/syntax" responsible (mflatt)
"collects/syntax/parse" responsible (ryanc)
"collects/syntax/parse.rkt" responsible (ryanc)
"collects/syntax/scribblings/parse" responsible (ryanc)
"collects/syntax/scribblings/parse.scrbl" responsible (ryanc)
"collects/syntax-color" responsible (mflatt)
"collects/teachpack" responsible (matthias)
"collects/teachpack/2htdp/scribblings/image-gen.rkt" responsible (robby) drdr:command-line (gracket-text *)

19
collects/syntax/parse.rkt
View File

@ -1,6 +1,13 @@
#lang scheme/base
(require "private/stxparse/sc.ss"
"private/stxparse/lib.ss")
(provide (all-from-out "private/stxparse/sc.ss")
(all-from-out "private/stxparse/lib.ss"))
#lang racket/base
(require racket/contract/base
"parse/private/sc.rkt"
"parse/private/litconv.rkt"
"parse/private/lib.rkt"
"parse/experimental/provide.rkt")
(provide (except-out (all-from-out "parse/private/sc.rkt")
parser/rhs)
(all-from-out "parse/private/litconv.rkt")
(except-out (all-from-out "parse/private/lib.rkt")
static))
(provide-syntax-class/contract
[static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])])

106
collects/syntax/parse/debug.rkt Normal file
View File

@ -0,0 +1,106 @@
#lang racket/base
(require (for-syntax racket/base
racket/private/sc
syntax/stx
unstable/syntax
unstable/struct
"private/rep-data.rkt"
"private/rep.rkt"
"private/kws.rkt")
racket/list
syntax/stx
unstable/markparam
"../parse.rkt"
"private/parse.rkt"
"private/keywords.rkt"
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"
"private/kws.rkt")
(provide syntax-class-parse
syntax-class-attributes
syntax-class-arity
syntax-class-keywords
debug-rhs
debug-pattern
debug-parse)
(define-syntax (syntax-class-parse stx)
(syntax-case stx ()
[(_ s x arg ...)
(parameterize ((current-syntax-context stx))
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
[stxclass
(get-stxclass/check-arity #'s stx
(length (arguments-pargs argu))
(arguments-kws argu))]
[attrs (stxclass-attrs stxclass)])
(with-syntax ([parser (stxclass-parser stxclass)]
[argu argu]
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (fs) fs)])
(app-argu parser x x (ps-empty x x) null fh fh
(lambda (fh cp . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu)))))]))
(define-syntaxes (syntax-class-attributes
syntax-class-arity
syntax-class-keywords)
(let ()
(define ((mk handler) stx)
(syntax-case stx ()
[(_ s)
(parameterize ((current-syntax-context stx))
(handler (get-stxclass #'s)))]))
(values (mk (lambda (s)
(let ([attrs (stxclass-attrs s)])
(with-syntax ([(a ...) (map attr-name attrs)]
[(d ...) (map attr-depth attrs)])
#'(quote ((a d) ...))))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a)))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(values '#,(arity-minkws a) '#,(arity-maxkws a))))))))
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f #f #:context stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p . rest)
(let-values ([(rest pattern defs)
(parse-pattern+sides #'p #'rest
#:splicing? #f
#:decls (new-declenv null)
#:context stx)])
(unless (stx-null? rest)
(raise-syntax-error #f "unexpected terms" stx rest))
#`(quote ((definitions . #,defs)
(pattern #,pattern))))]))
(define-syntax-rule (debug-parse x p ...)
(let/ec escape
(parameterize ((current-failure-handler
(lambda (_ fs)
(escape
`(parse-failure
#:raw-failures
,(failureset->sexpr fs)
#:maximal-failures
,(let ([selected (map (lambda (fs)
(cons 'equivalence-class
(map failure->sexpr fs)))
(maximal-failures fs))])
(if (= (length selected) 1)
(car selected)
(cons 'union selected))))))))
(syntax-parse x [p 'success] ...))))

98
collects/syntax/parse/experimental.rkt
View File

@ -1,95 +1,3 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/parse
syntax/private/stxparse/rep-data))
(provide define-primitive-splicing-syntax-class)
(define-syntax (define-primitive-splicing-syntax-class stx)
(define-syntax-class attr
(pattern name:id
#:with depth #'0)
(pattern [name:id depth:nat]))
(syntax-parse stx
[(dssp (name:id param:id ...)
(~or (~once (~seq #:attrs (a:attr ...))
#:name "attributes declaration")
(~once (~seq #:description description)
#:name "description declaration")) ...
proc:expr)
#'(begin
(define (get-description param ...)
description)
(define parser
(lambda (stx param ...)
(let/ec escape
((mk-check-result 'name '(a.name ...) stx)
(proc stx
(lambda ([msg #f])
(escape
(if msg
`#s(expect:message ,msg)
`#s(expect:thing
,(get-description param ...) #f #f)))))))))
(define-syntax name
(make-stxclass 'name '(param ...)
'(#s(attr a.name a.depth #f) ...)
(quote-syntax parser)
(quote-syntax get-description)
#t
#t)))]))
(define (mk-check-result name attr-names stx)
(lambda (result)
(unless (list? result)
(error name "parser returned non-list"))
(let ([rlength (length result)])
(unless (= rlength (+ 2 (length attr-names)))
(error name "parser returned list of wrong length; expected length ~s, got ~e"
(+ 2 (length attr-names))
result))
(unless (exact-nonnegative-integer? (cadr result))
(error name "expected exact nonnegative integer for second element of result list, got ~e"
(cadr result)))
(list* (car result)
(nat->dfc (cadr result) stx)
(cddr result)))))
(define (nat->dfc nat stx)
(if (zero? nat)
`#s(dfc:empty ,stx)
`#s(dfc:cdr #s(dfc:empty ,stx) ,nat)))
#|
(define-primitive-splicing-syntax-class (name param ...)
#:attrs (attr-decl ...)
#:description description-expr
proc)
'proc' must take two arguments, 'stx' and 'fail', where 'fail' is an
escaping procedure that indicates failure. 'fail' takes an optional
argument, an error message to attach to the failure. If no message is
given, the syntax class description is used.
'proc' must return a list of 2+|attrs| elements. The first element is
the rest of the input syntax. The second element is the number of
elements consumed from the input. The rest are the attribute values,
in the same order as given in the #:attrs directive.
Example:
(define-primitive-splicing-syntax-class (a-expr)
#:attrs (x)
#:description "a-expr"
(lambda (stx fail)
(syntax-case stx ()
[(a b c . rest)
(list #'rest 3 #'(printf "got an A\n"))]
[_
(fail)])))
|#
#lang racket/base
(require "experimental/splicing.rkt")
(provide (all-from-out "experimental/splicing.rkt"))

35
collects/syntax/parse/experimental/contract.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang racket/base
(require "../private/sc.rkt"
"../private/lib.rkt"
"provide.rkt"
unstable/wrapc
(only-in "../private/runtime.rkt"
this-context-syntax)
racket/contract/base)
(define-syntax-class (expr/c ctc-stx
#:positive [pos-blame 'use-site]
#:negative [neg-blame 'from-macro]
#:macro [macro-name #f]
#:name [expr-name #f]
#:context [ctx #f])
#:attributes (c)
(pattern y:expr
#:with
c (wrap-expr/c ctc-stx
#'y
#:positive pos-blame
#:negative neg-blame
#:name expr-name
#:macro macro-name
#:context (or ctx (this-context-syntax)))))
(provide-syntax-class/contract
[expr/c (syntax-class/c (syntax?)
(#:positive (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
#:negative (or/c syntax? string? module-path-index?
'from-macro 'same-as-use-site 'unknown)
#:name (or/c identifier? string? symbol? #f)
#:macro (or/c identifier? string? symbol? #f)
#:context (or/c syntax? #f)))])

78
collects/syntax/parse/experimental/eh.rkt Normal file
View File

@ -0,0 +1,78 @@
#lang racket/base
(require (for-syntax racket/base
syntax/parse
unstable/syntax
"../private/minimatch.rkt"
"../private/rep.rkt"
"../private/rep-data.rkt"
"../private/rep-patterns.rkt"
"../private/kws.rkt")
"../private/keywords.rkt"
"../private/sc.rkt")
(provide ~eh-var
define-eh-alternative-set)
(define-syntax (define-eh-alternative-set stx)
(define-syntax-class alt
#:description "eh-alternate-set alternative"
#:literals (pattern)
(pattern (pattern alt)))
(syntax-parse stx
#:literals (pattern)
[(_ name:id a:alt ...)
(parameterize ((current-syntax-context stx))
(let* ([decls (new-declenv null #:conventions null)]
[ehpat+hstx-list
(apply append
(for/list ([alt (in-list (syntax->list #'(a.alt ...)))])
(parse*-ellipsis-head-pattern alt decls #t #:context stx)))]
[eh-alt+defs-list
(for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
(let ([ehpat (car ehpat+hstx)]
[hstx (cadr ehpat+hstx)])
(cond [(syntax? hstx)
(with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))])
(let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))])
(list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
(list #`(define parser
(parser/rhs parser () #,attrs
[#:description #f (pattern #,hstx)]
#t
#,stx))))))]
[(eh-alternative? hstx)
(list hstx null)]
[else
(error 'define-eh-alternative-set "internal error: unexpected ~e"
hstx)])))]
[eh-alts (map car eh-alt+defs-list)]
[defs (apply append (map cadr eh-alt+defs-list))])
(with-syntax ([(def ...) defs]
[(alt-expr ...)
(for/list ([alt (in-list eh-alts)])
(with-syntax ([repc-expr
(match (eh-alternative-repc alt)
['#f
#'(quote #f)]
[(rep:once n u o)
#`(rep:once (quote-syntax #,n)
(quote-syntax #,u)
(quote-syntax #,o))]
[(rep:optional n o d)
#`(rep:optional (quote-syntax #,n)
(quote-syntax #,o)
(quote-syntax #,d))]
[(rep:bounds min max n u o)
#`(rep:bounds (quote #,min)
(quote #,max)
(quote-syntax #,n)
(quote-syntax #,u)
(quote-syntax #,o))])]
[attrs-expr
#`(quote #,(eh-alternative-attrs alt))]
[parser-expr
#`(quote-syntax #,(eh-alternative-parser alt))])
#'(eh-alternative repc-expr attrs-expr parser-expr)))])
#'(begin def ...
(define-syntax name
(eh-alternative-set (list alt-expr ...)))))))]))

160
collects/syntax/parse/experimental/provide.rkt Normal file
View File

@ -0,0 +1,160 @@
#lang racket/base
(require racket/contract/base
unstable/location
(for-syntax racket/base
unstable/syntax
"../private/minimatch.rkt"
"../private/sc.rkt"
"../private/lib.rkt"
"../private/rep-data.ss"
"../private/kws.rkt"
(only-in "../private/runtime.rkt"
this-context-syntax)
unstable/wrapc))
(provide provide-syntax-class/contract
syntax-class/c
splicing-syntax-class/c)
;; FIXME:
;; - seems to get first-requiring-module wrong, not surprising
;; - extend to contracts on attributes?
;; - syntax-class/c etc just a made-up name, for now
;; (connect to dynamic syntax-classes, eventually)
(define-syntaxes (syntax-class/c splicing-syntax-class/c)
(let ([nope
(lambda (stx)
(raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))])
(values nope nope)))
(begin-for-syntax
(define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab
#:omit-define-syntaxes))
(begin-for-syntax
;; do-one-contract : stx id stxclass ctcrec id -> stx
(define (do-one-contract stx scname stxclass rec pos-module-source)
;; First, is the contract feasible?
(match (stxclass-arity stxclass)
[(arity minpos maxpos minkws maxkws)
(let* ([minpos* (length (ctcrec-mpcs rec))]
[maxpos* (+ minpos* (length (ctcrec-opcs rec)))]
[minkws* (sort (map syntax-e (ctcrec-mkws rec)) keyword<?)]
[maxkws* (sort (append minkws* (map syntax-e (ctcrec-okws rec))) keyword<?)])
(define (err msg . args)
(apply wrong-syntax scname msg args))
(unless (<= minpos minpos*)
(err (string-append "expected a syntax class with at most ~a "
"required positional arguments, got one with ~a")
minpos* minpos))
(unless (<= maxpos* maxpos)
(err (string-append "expected a syntax class with at least ~a "
"total positional arguments (required and optional), "
"got one with ~a")
maxpos* maxpos))
(unless (null? (diff/sorted/eq minkws minkws*))
(err (string-append "expected a syntax class with at most the "
"required keyword arguments ~a, got one with ~a")
(join-sep (map kw->string minkws*) "," "and")
(join-sep (map kw->string minkws) "," "and")))
(unless (null? (diff/sorted/eq maxkws* maxkws))
(err (string-append "expected a syntax class with at least the optional "
"keyword arguments ~a, got one with ~a")
(join-sep (map kw->string maxkws*) "," "and")
(join-sep (map kw->string maxkws) "," "and")))
(with-syntax ([scname scname]
[#s(stxclass name arity attrs parser splicing? options integrate)
stxclass]
[#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
(opc ...) (okw ...) (okwc ...))
rec]
[arity* (arity minpos* maxpos* minkws* maxkws*)]
[(parser-contract contracted-parser contracted-scname)
(generate-temporaries #`(contract parser #,scname))])
(with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))]
[(mkwc-id ...) (generate-temporaries #'(mkwc ...))]
[(opc-id ...) (generate-temporaries #'(opc ...))]
[(okwc-id ...) (generate-temporaries #'(okwc ...))])
(with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)]
[((okw-c-part ...) ...) #'((okw okwc-id) ...)]
[((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)]
[((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)])
#`(begin
(define parser-contract
(let ([mpc-id mpc] ...
[mkwc-id mkwc] ...
[opc-id opc] ...
[okwc-id okwc] ...)
(rename-contract
(->* (any/c any/c any/c any/c any/c any/c any/c
mpc-id ... mkw-c-part ... ...)
(okw-c-part ... ...)
any)
`(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c)
[,(contract-name mpc-id) ... mkw-name-part ... ...]
[okw-name-part ... ...]))))
(define-syntax contracted-parser
(make-provide/contract-transformer
(quote-syntax parser-contract)
(quote-syntax parser)
(quote-syntax scname)
(quote-syntax #,pos-module-source)))
(define-syntax contracted-scname
(make-stxclass
(quote-syntax name)
'arity*
'attrs
(quote-syntax contracted-parser)
'splicing?
'options
#f)) ;; must disable integration
(provide (rename-out [contracted-scname scname])))))))])))
(define-syntax (provide-syntax-class/contract stx)
(define-syntax-class stxclass-ctc
#:description "syntax-class/c or splicing-syntax-class/c form"
#:literals (syntax-class/c)
#:attributes (rec)
(pattern ((~or syntax-class/c splicing-syntax-class/c)
mand:ctclist
(~optional opt:ctclist))
#:attr rec (make-ctcrec (attribute mand.pc.c)
(attribute mand.kw)
(attribute mand.kwc.c)
(or (attribute opt.pc.c) '())
(or (attribute opt.kw) '())
(or (attribute opt.kwc.c) '()))))
(define-syntax-class ctclist
#:attributes ([pc.c 1] [kw 1] [kwc.c 1])
(pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...)
#:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))])
(wrap-expr/c #'contract? pc-expr))
#:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))])
(wrap-expr/c #'contract? kwc-expr))))
(syntax-parse stx
[(_ [scname c:stxclass-ctc] ...)
#:declare scname (static stxclass? "syntax class")
(parameterize ((current-syntax-context stx))
#`(begin (define pos-module-source (quote-module-path))
#,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
[stxclass (in-list (attribute scname.value))]
[rec (in-list (attribute c.rec))])
(do-one-contract stx scname stxclass rec #'pos-module-source))))]))
;; Copied from unstable/contract,
;; which requires racket/contract, not racket/contract/base
;; rename-contract : contract any/c -> contract
;; If the argument is a flat contract, so is the result.
(define (rename-contract ctc name)
(let ([ctc (coerce-contract 'rename-contract ctc)])
(if (flat-contract? ctc)
(flat-named-contract name (flat-contract-predicate ctc))
(let* ([ctc-fo (contract-first-order ctc)]
[proj (contract-projection ctc)])
(make-contract #:name name
#:projection proj
#:first-order ctc-fo)))))

118
collects/syntax/parse/experimental/reflect.rkt Normal file
View File

@ -0,0 +1,118 @@
#lang racket/base
(require racket/contract/base
(for-syntax racket/base
"../../parse.rkt"
"../private/rep-data.rkt")
"../private/minimatch.rkt"
"../private/keywords.rkt"
"../private/runtime-reflect.rkt"
"../private/kws.rkt")
(define (reified-syntax-class-arity r)
(match (reified-arity r)
[(arity minpos maxpos _ _)
(to-procedure-arity minpos maxpos)]))
(define (reified-syntax-class-keywords r)
(match (reified-arity r)
[(arity _ _ minkws maxkws)
(values minkws maxkws)]))
(define (reified-syntax-class-attributes r)
(reified-signature r))
(define reified-syntax-class-curry
(make-keyword-procedure
(lambda (kws1 kwargs1 r . rest1)
(match r
[(reified name parser arity1 sig)
(let ()
(check-curry arity1 (length rest1) kws1
(lambda (msg)
(raise-mismatch-error 'reified-syntax-class-curry
(string-append msg ": ") r)))
(let* ([curried-arity
(match arity1
[(arity minpos maxpos minkws maxkws)
(let* ([rest1-length (length rest1)]
[minpos* (- minpos rest1-length)]
[maxpos* (- maxpos rest1-length)]
[minkws* (sort (remq* kws1 minkws) keyword<?)]
[maxkws* (sort (remq* kws1 maxkws) keyword<?)])
(arity minpos* maxpos* minkws* maxkws*))])]
[curried-parser
(make-keyword-procedure
(lambda (kws2 kwargs2 x cx pr es fh cp success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
(keyword-apply kws kwargs x cx pr es fh cp success
(append rest1 rest2)))))]
[ctor
(cond [(reified-syntax-class? r)
reified-syntax-class]
[(reified-splicing-syntax-class? r)
reified-splicing-syntax-class]
[else
(error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])])
(ctor name curried-parser curried-arity sig)))]))))
(define (merge2 kws1 kws2 kwargs1 kwargs2)
(cond [(null? kws1)
(values kws2 kwargs2)]
[(null? kws2)
(values kws1 kwargs1)]
[(keyword<? (car kws1) (car kws2))
(let-values ([(m-kws m-kwargs)
(merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)])
(values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))]
[else
(let-values ([(m-kws m-kwargs)
(merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))])
(values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))]))
;; ----
(provide reify-syntax-class
~reflect
~splicing-reflect)
(provide/contract
[reified-syntax-class?
(-> any/c boolean?)]
[reified-splicing-syntax-class?
(-> any/c boolean?)]
[reified-syntax-class-attributes
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
(listof (list/c symbol? exact-nonnegative-integer?)))]
[reified-syntax-class-arity
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
procedure-arity?)]
[reified-syntax-class-keywords
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
(values (listof keyword?)
(listof keyword?)))]
[reified-syntax-class-curry
(make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c))
(#:<kw> any/c ...)
#:rest list?
(or/c reified-syntax-class? reified-splicing-syntax-class/c))
#:projection
(lambda (blame)
(let ([check-reified
((contract-projection
(or/c reified-syntax-class? reified-splicing-syntax-class?))
(blame-swap blame))])
(lambda (f)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(make-keyword-procedure
(lambda (kws kwargs r . args)
(keyword-apply f kws kwargs (check-reified r) args)))
(raise-blame-error
blame
f
"expected a procedure of at least one argument, given ~e"
f)))))
#:first-order
(lambda (f)
(and (procedure? f) (procedure-arity-includes? f))))])

71
collects/syntax/parse/experimental/splicing.rkt Normal file
View File

@ -0,0 +1,71 @@
#lang racket/base
(require (for-syntax racket/base
"../../parse.ss"
"../private/rep-data.rkt"
"../private/kws.rkt")
"../private/runtime-progress.rkt"
"../private/runtime.rkt")
(provide define-primitive-splicing-syntax-class)
(define-syntax (define-primitive-splicing-syntax-class stx)
(define-syntax-class attr
(pattern name:id
#:with depth #'0)
(pattern [name:id depth:nat]))
(syntax-parse stx
[(dssp (name:id param:id ...)
(~or (~once (~seq #:attrs (a:attr ...))
#:name "attributes declaration")
(~once (~seq #:description description)
#:name "description declaration")) ...
proc:expr)
#'(begin
(define (get-description param ...)
description)
(define parser
(lambda (x cx pr es fh cp success param ...)
(let ([stx (datum->syntax cx x cx)])
(let ([result
(let/ec escape
(cons 'ok
(proc stx
(lambda ([msg #f] [stx #f])
(escape (list 'error msg stx))))))])
(case (car result)
((ok)
(apply success
((mk-check-result pr 'name '(a.name ...) x cx fh cp) (cdr result))))
((error)
(let ([es
(list* (cons (expect:thing (get-description param ...) #f) stx)
(cons (expect:message (cadr result)) (caddr result))
es)])
(fh (failure pr es)))))))))
(define-syntax name
(make-stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
'(#s(attr a.name a.depth #f) ...)
(quote-syntax parser)
#t
#s(options #t #t)
#f)))]))
(define (mk-check-result pr name attr-names x cx fh cp)
(lambda (result)
(unless (list? result)
(error name "parser returned non-list"))
(let ([rlength (length result)])
(unless (= rlength (+ 2 (length attr-names)))
(error name "parser returned list of wrong length; expected length ~s, got ~e"
(+ 2 (length attr-names))
result))
;; Ignore (car result), supposed to be rest-x
;; Easier to recompute it and get rest-cx right, too.
(let ([skip (cadr result)])
(unless (exact-nonnegative-integer? skip)
(error name "expected exact nonnegative integer for second element of result list, got ~e"
skip))
(let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
(list* fh cp rest-x rest-cx (ps-add-cdr pr skip)
(cddr result)))))))

37
collects/syntax/parse/private/keywords.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/base
(require (for-syntax racket/base))
;; == Keywords
(define-syntax-rule (define-keyword name)
(begin
(provide name)
(define-syntax name
(lambda (stx)
(raise-syntax-error #f "keyword used out of context" stx)))))
(define-keyword pattern)
(define-keyword ~var)
(define-keyword ~datum)
(define-keyword ~literal)
(define-keyword ~and)
(define-keyword ~or)
(define-keyword ~not)
(define-keyword ~seq)
(define-keyword ~between)
(define-keyword ~once)
(define-keyword ~optional)
(define-keyword ~rest)
(define-keyword ~describe)
(define-keyword ~!)
(define-keyword ~bind)
(define-keyword ~fail)
(define-keyword ~parse)
(define-keyword ~do)
(define-keyword ...+)
(define-keyword ~delimit-cut)
(define-keyword ~commit)
(define-keyword ~reflect)
(define-keyword ~splicing-reflect)
(define-keyword ~post)
(define-keyword ~eh-var)

176
collects/syntax/parse/private/kws.rkt Normal file
View File

@ -0,0 +1,176 @@
#lang racket/base
(require racket/list)
(provide (struct-out arguments)
(struct-out arity)
no-arguments
no-arity
to-procedure-arity
arguments->arity
check-arity
check-arity/neg
check-curry
join-sep
kw->string
diff/sorted/eq)
#|
An Arguments is
#s(arguments (listof stx) (listof keyword) (listof stx))
|#
(define-struct arguments (pargs kws kwargs) #:prefab)
(define no-arguments (arguments null null null))
#|
An Arity is
#s(arity nat nat/+inf.0 (listof keyword) (listof keyword))
|#
(define-struct arity (minpos maxpos minkws maxkws)
#:prefab)
(define no-arity (arity 0 0 null null))
;; ----
(define (to-procedure-arity minpos maxpos)
(cond [(= minpos maxpos) minpos]
[(= maxpos +inf.0) (arity-at-least minpos)]
[else (for/list ([i (in-range minpos (add1 maxpos))]) i)]))
(define (arguments->arity argu)
(let ([pos (length (arguments-pargs argu))]
[kws (arguments-kws argu)])
(arity pos pos kws kws)))
(define (check-arity arity pos-count keywords proc)
(let ([msg (gen-arity-msg (arity-minpos arity)
(arity-maxpos arity)
(arity-minkws arity)
(arity-maxkws arity)
pos-count keywords)])
(when msg
(proc msg))))
(define (check-arity/neg arity pos-count keywords proc)
(let ([msg (gen-arity-msg/neg (arity-minpos arity)
(arity-maxpos arity)
(arity-minkws arity)
(arity-maxkws arity)
pos-count keywords)])
(when msg
(proc msg))))
(define (arity-sat? minpos maxpos minkws maxkws pos-count keywords)
(and (<= minpos pos-count maxpos)
(null? (diff/sorted/eq minkws keywords))
(null? (diff/sorted/eq keywords maxkws))))
(define (gen-arity-msg minpos maxpos minkws maxkws pos-count keywords)
(if (arity-sat? minpos maxpos minkws maxkws pos-count keywords)
#f
(let ([pos-exp (gen-pos-exp-msg minpos maxpos)]
[minkws-exp (gen-minkws-exp-msg minkws)]
[optkws-exp (gen-optkws-exp-msg minkws maxkws)]
[pos-got (gen-pos-got-msg pos-count)]
[kws-got (gen-kws-got-msg keywords maxkws)])
(string-append
"expected "
(join-sep (filter string? (list pos-exp minkws-exp optkws-exp))
"," "and")
"; got "
(join-sep (filter string? (list pos-got kws-got))
"," "and")))))
(define (gen-arity-msg/neg minpos maxpos minkws maxkws pos-count keywords)
(if (arity-sat? minpos maxpos minkws maxkws pos-count keywords)
#f
(let ([pos-exp (gen-pos-exp-msg minpos maxpos)]
[minkws-exp (gen-minkws-exp-msg minkws)]
[optkws-exp (gen-optkws-exp-msg minkws maxkws)]
[pos-got (gen-pos-got-msg pos-count)]
[kws-got (gen-kws-got-msg keywords maxkws)])
(string-append
"expected a syntax class that accepts "
(join-sep (filter string? (list pos-got kws-got))
"," "and")
"; got one that accepts "
(join-sep (filter string? (list pos-exp minkws-exp optkws-exp))
"," "and")))))
(define (check-curry arity pos-count keywords proc)
(let ([maxpos (arity-maxpos arity)]
[maxkws (arity-maxkws arity)])
(when (> pos-count maxpos)
(proc (format "too many arguments: expected at most ~s, got ~s"
maxpos pos-count)))
(let ([extrakws (diff/sorted/eq keywords maxkws)])
(when (pair? extrakws)
(proc (format "syntax class does not accept keyword arguments for ~a"
(join-sep (map kw->string extrakws) "," "and")))))))
;; ----
(define (gen-pos-exp-msg minpos maxpos)
(format "~a positional argument~a"
(cond [(= maxpos minpos) minpos]
[(= maxpos +inf.0) (format "at least ~a" minpos)]
[else
(format "between ~a and ~a" minpos maxpos)])
(if (= minpos maxpos 1) "" "s")))
(define (gen-minkws-exp-msg minkws)
(and (pair? minkws)
(format "~amandatory keyword argument~a for ~a"
(if (= (length minkws) 1) "a " "")
(if (= (length minkws) 1) "" "s")
(join-sep (map kw->string minkws) "," "and"))))
(define (gen-optkws-exp-msg minkws maxkws)
(let ([optkws (diff/sorted/eq maxkws minkws)])
(and (pair? optkws)
(format "~aoptional keyword argument~a for ~a"
(if (= (length optkws) 1) "an " "")
(if (= (length optkws) 1) "" "s")
(join-sep (map kw->string optkws) "," "and")))))
(define (gen-pos-got-msg pos-count)
(format "~a positional argument~a"
pos-count (if (= pos-count 1) "" "s")))
(define (gen-kws-got-msg keywords maxkws)
(cond [(pair? keywords)
(format "~akeyword argument~a for ~a"
(if (= (length keywords) 1) "a " "")
(if (= (length keywords) 1) "" "s")
(join-sep (map kw->string keywords) "," "and"))]
[(pair? maxkws) "no keyword arguments"]
[else #f]))
;; ----
(define (kw->string kw) (format "~a" kw))
(define (diff/sorted/eq xs ys)
(if (pair? xs)
(let ([ys* (memq (car xs) ys)])
(if ys*
(diff/sorted/eq (cdr xs) (cdr ys*))
(cons (car xs) (diff/sorted/eq (cdr xs) ys))))
null))
(define (join-sep items sep0 ult0 [prefix ""])
(define sep (string-append sep0 " "))
(define ult (string-append ult0 " "))
(define (loop items)
(cond [(null? items)
null]
[(null? (cdr items))
(list sep ult (car items))]
[else
(list* sep (car items) (loop (cdr items)))]))
(case (length items)
[(0) #f]
[(1) (string-append prefix (car items))]
[(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
[else (let ([strings (list* (car items) (loop (cdr items)))])
(apply string-append prefix strings))]))

86
collects/syntax/parse/private/lib.rkt Normal file
View File

@ -0,0 +1,86 @@
#lang racket/base
(require "sc.rkt"
"keywords.rkt"
syntax/stx
unstable/syntax
(for-syntax racket/base
"rep.rkt"))
(provide identifier
boolean
str
character
keyword
number
integer
exact-integer
exact-nonnegative-integer
exact-positive-integer
id
nat
char
expr
static)
;; == Integrable syntax classes ==
(define-syntax-class identifier
#:description (quote "identifier")
(pattern (~fail #:unless (identifier? this-syntax))))
(define-syntax-class keyword
#:description (quote "keyword")
(pattern (~fail #:unless (and (syntax? this-syntax) (keyword? (syntax-e this-syntax))))))
(define-syntax-class expr
#:description (quote "expression")
(pattern (~fail #:when (and (syntax? this-syntax) (keyword? (syntax-e this-syntax))))))
;; == Normal syntax classes ==
(define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes () #:opaque #:commit
(pattern (~and x (~fail #:unless (pred (syntax-e #'x)))))))
;;(define-pred-stxclass identifier symbol?)
;;(define-pred-stxclass keyword keyword?)
(define-pred-stxclass boolean boolean?)
(define-pred-stxclass character char?)
(define-syntax-class str #:attributes () #:opaque #:commit
#:description "string"
(pattern (~and x (~fail #:unless (string? (syntax-e #'x))))))
(define-pred-stxclass number number?)
(define-pred-stxclass integer integer?)
(define-pred-stxclass exact-integer exact-integer?)
(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?)
(define-pred-stxclass exact-positive-integer exact-positive-integer?)
;; Aliases
(define-syntax id (make-rename-transformer #'identifier))
(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
(define-syntax char (make-rename-transformer #'character))
(define notfound (box 'notfound))
(define-syntax-class (static pred name)
#:attributes (value)
#:description name
#:commit
(pattern (~and x:id
(~fail #:unless (syntax-transforming?)
"not within the extent of a macro transformer")
(~bind [value (syntax-local-value #'x (lambda () notfound))])
(~fail #:when (eq? (attribute value) notfound))
(~fail #:unless (pred (attribute value))))))
#|
(define-syntax-class expr
#:attributes ()
#:description "expression"
#:commit
(pattern (~and x (~fail #:when (keyword? (syntax-e #'x))))))
|#

137
collects/syntax/parse/private/litconv.rkt Normal file
View File

@ -0,0 +1,137 @@
#lang racket/base
(require (for-syntax racket/base
"sc.rkt"
"lib.rkt"
unstable/syntax
"rep-data.rkt"
"rep.rkt"
"kws.rkt")
"runtime.rkt")
(provide define-conventions
define-literal-set
kernel-literals)
(define-syntax (define-conventions stx)
(define-syntax-class header
#:description "name or name with formal parameters"
(pattern name:id
#:with formals #'()
#:attr arity (arity 0 0 null null))
(pattern (name:id . formals)
#:attr arity (parse-kw-formals #'formals #:context stx)))
(syntax-parse stx
[(define-conventions h:header rule ...)
(let ()
(define rules (check-conventions-rules #'(rule ...) stx))
(define rxs (map car rules))
(define dens0 (map cadr rules))
(define den+defs-list
(for/list ([den0 (in-list dens0)])
(let-values ([(den defs) (create-aux-def den0)])
(cons den defs))))
(define dens (map car den+defs-list))
(define defs (apply append (map cdr den+defs-list)))
(define/with-syntax (rx ...) rxs)
(define/with-syntax (def ...) defs)
(define/with-syntax (parser ...)
(map den:delayed-parser dens))
(define/with-syntax (class-name ...)
(map den:delayed-class dens))
#'(begin
(define-syntax h.name
(make-conventions
(quote-syntax get-parsers)
(lambda ()
(let ([class-names (list (quote-syntax class-name) ...)])
(map list
(list 'rx ...)
(map make-den:delayed
(generate-temporaries class-names)
class-names))))))
(define get-parsers
(lambda formals
def ...
(list parser ...)))))]))
(define-syntax (define-literal-set stx)
(syntax-case stx ()
[(define-literal-set name (lit ...))
(let ([phase-of-definition (syntax-local-phase-level)])
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(let ([lits (check-literals-list/litset #'(lit ...) stx)])
(with-syntax ([((internal external) ...) lits])
#`(begin
(define phase-of-literals
(phase-of-enclosing-module))
(define-syntax name
(make-literalset
(list (list 'internal (quote-syntax external)) ...)
(quote-syntax phase-of-literals)))
(begin-for-syntax/once
(for ([x (in-list (syntax->list #'(external ...)))])
(unless (identifier-binding x 0)
(raise-syntax-error #f "literal is unbound in phase 0"
(quote-syntax #,stx) x))))))))]))
(define-syntax (phase-of-enclosing-module stx)
(syntax-case stx ()
[(poem)
(let ([phase-within-module (syntax-local-phase-level)])
#`(let ([phase-of-this-expression
(variable-reference->phase (#%variable-reference))])
(- phase-of-this-expression
#,(if (zero? phase-within-module) 0 1))))]))
#|
Literal sets: The goal is for literals to refer to their bindings at
phase 0 relative to the enclosing module
Use cases, explained:
1) module X with def-lit-set is required-for-syntax
phase-of-mod-inst = 1
phase-of-def = 0
literals looked up at abs phase 1
which is phase 0 rel to module X
2) module X with local def-lit-set within define-syntax
phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax)
phase-of-def = 1
literals looked up at abs phase 0
which is phase 0 rel to module X
3) module X with def-lit-set in phase-2 position (really uncommon case!)
phase-of-mod-inst = 1 (not 2, apparently)
phase-of-def = 2
literals looked up at abs phase 0
(that's why the weird (if (z?) 0 1) term)
|#
;; Literal sets
(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))

27
collects/syntax/private/stxparse/minimatch.rkt → collects/syntax/parse/private/minimatch.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require unstable/struct
(for-syntax racket/base racket/struct-info unstable/struct))
(provide match make)
(provide match make ?)
(define-syntax (match stx)
(syntax-case stx ()
@ -25,7 +25,7 @@
;; (match-p id Pattern SuccessExpr FailureExpr)
(define-syntax (match-p stx)
(syntax-case stx (quote cons list make struct)
(syntax-case stx (quote cons list make struct ?)
[(match-p x wildcard success failure)
(and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
#'success]
@ -67,6 +67,15 @@
(let ([y (list (accessor x) ...)])
(match-p y (list p ...) success failure))
failure))))]
[(match-p x (? predicate pat ...) success failure)
#'(if (predicate x)
(match-p* ((x pat) ...) success failure)
failure)]
[(match-p x (S p ...) success failure)
(identifier? #'S)
(if (struct-info? (syntax-local-value #'S (lambda () #f)))
#'(match-p x (struct S (p ...)) success failure)
(raise-syntax-error #f "bad minimatch form" stx #'S))]
[(match-p x s success failure)
(prefab-struct-key (syntax-e #'s))
(with-syntax ([key (prefab-struct-key (syntax-e #'s))]
@ -75,9 +84,21 @@
(if (equal? xkey 'key)
(let ([xps (struct->list x)])
(match-p xps (list p ...) success failure))
failure)))]))
failure)))]
))
(define-syntax match-p*
(syntax-rules ()
[(match-p* () success failure)
success]
[(match-p* ((x1 p1) . rest) success failure)
(match-p x1 p1 (match-p* rest success failure) failure)]))
#;
(define-syntax struct
(lambda (stx)
(raise-syntax-error #f "illegal use of keyword" stx)))
(define-syntax ?
(lambda (stx)
(raise-syntax-error #f "illegal use of minimatch form '?'" stx)))

781
collects/syntax/parse/private/parse.rkt Normal file
View File

@ -0,0 +1,781 @@
#lang racket/base
(require (for-syntax racket/base
racket/private/sc
syntax/stx
syntax/id-table
syntax/keyword
unstable/syntax
"rep-data.rkt"
"rep.rkt"
"kws.rkt"
"txlift.rkt")
racket/stxparam
racket/list
syntax/stx
unstable/struct
"runtime.rkt"
"runtime-report.rkt"
"runtime-reflect.rkt")
(provide (all-defined-out))
#|
Parsing protocol:
(parse:* <*> * progress-var expectstack-var success-expr) : Ans
*-stxclass-parser
: stxish stx progress expectstack fail-handler cut-prompt success-proc arg ... -> Ans
<S> : x cx
<H> : x cx rest-x rest-cx rest-pr
<EH> : x cx ???
<A> : x cx
x is term to parse, usually syntax but can be pair, empty in cdr patterns
cx is most recent syntax object:
if x must be coerced to syntax, use cx as lexctx and src
Usually sub-patterns processed in tail position,
but *can* do non-tail calls for:
- ~commit
- var of stxclass with ~commit
(Also safe to keep normal tail-call protocol.)
There is no real benefit to specializing ~commit, since it does not involve
creating a success closure.
|#
#|
Optimizations
- commit protocol for stxclasses (but not ~commit, no point)
- avoid choice point in (EH ... . ()) by eager pair check
- integrable stxclasses (identifier, keyword, expr)
|#
;; ----
(begin-for-syntax
(define (wash stx)
(syntax-e stx))
(define (wash-list washer stx)
(let ([l (stx->list stx)])
(unless l (raise-type-error 'wash-list "stx-list" stx))
(map washer l)))
(define (wash-iattr stx)
(with-syntax ([#s(attr name depth syntax?) stx])
(attr #'name (wash #'depth) (wash #'syntax?))))
(define (wash-sattr stx)
(with-syntax ([#s(attr name depth syntax?) stx])
(attr (wash #'name) (wash #'depth) (wash #'syntax?))))
(define (wash-iattrs stx)
(wash-list wash-iattr stx))
(define (wash-sattrs stx)
(wash-list wash-sattr stx)))
;; ----
#|
Conventions:
- rhs : RHS
- iattr : IAttr
- relsattr : SAttr
- splicing? : bool
- x : id (var)
- cx : id (var, may be shadowed)
- pr : id (var, may be shadowed)
- es : id (var, may be shadowed)
- success : var (bound to success procedure)
- k : expr
- rest-x, rest-cx, rest-pr : id (to be bound)
- fh, cp : id (var)
|#
;; (parse:rhs rhs relsattrs (arg:id ...) get-description:id splicing?)
;; : expr[stxclass-parser]
;; Takes a list of the relevant attrs; order is significant!
(define-syntax (parse:rhs stx)
(syntax-case stx ()
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...)
#s(options commit? delimit-cut?) _integrate)
relsattrs formals splicing? description)
#'(lambda (x cx pr es fh0 cp0 success . formals)
def ...
(#%expression
(with ([this-syntax x])
(syntax-parameterize ((this-context-syntax
(syntax-rules ()
[(tbs) (ps-context-syntax pr)])))
(let ([es (cons (cons (expect:thing description 'transparent?) x) es)]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(with ([fail-handler fh0]
[cut-prompt cp0])
;; Update the prompt, if required
;; FIXME: can be optimized away if no cut immediately within variants...
(with-maybe-delimit-cut delimit-cut?
(parse:variants x cx relsattrs variants splicing?
pr es success cp0 commit?))))))))]))
;; (with-maybe-delimit-cut bool expr)
(define-syntax with-maybe-delimit-cut
(syntax-rules ()
[(wmdc #t k)
(with ([cut-prompt fail-handler]) k)]
[(wmdc #f k)
k]))
;; (parse:variants x cx relsattrs variants splicing? pr es success cp0) : expr[Ans]
(define-syntax (parse:variants stx)
(syntax-case stx ()
[(parse:variants x cx relsattrs (variant ...) splicing? pr es success cp0 commit?)
#'(try (parse:variant x cx relsattrs variant splicing? pr es success cp0 commit?) ...)]))
;; (parse:variant x cx relsattrs variant splicing? pr es success cp0) : expr[Ans]
(define-syntax (parse:variant stx)
(syntax-case stx ()
[(parse:variant x cx relsattrs variant #f pr es success cp0 commit?)
(with-syntax ([#s(variant _ _ pattern (def ...)) #'variant])
#`(let ()
def ...
(parse:S x cx pattern pr es
(variant-success relsattrs variant () success cp0 commit?))))]
[(parse:variant x cx relsattrs variant #t pr es success cp0 commit?)
(with-syntax ([#s(variant _ _ pattern (def ...)) #'variant])
#`(let ()
def ...
(parse:H x cx rest-x rest-cx rest-pr pattern pr es
(variant-success relsattrs variant (rest-x rest-cx rest-pr)
success cp0 commit?))))]))
;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans]
(define-syntax (variant-success stx)
(syntax-case stx ()
[(variant-success relsattrs #s(variant _ _ pattern _) (also ...) success cp0 commit?)
#`(with-maybe-reset-fail commit? cp0
(base-success-expr #,(pattern-attrs (wash #'pattern))
relsattrs
(also ...)
success))]))
;; (with-maybe-reset-fail bool id expr)
(define-syntax with-maybe-reset-fail
(syntax-rules ()
[(wmrs #t cp0 k)
(with ([fail-handler cp0]) k)]
[(wmrs #f cp0 k)
k]))
;; (base-success-expr iattrs relsattrs (also:id ...) success) : expr[Ans]
(define-syntax (base-success-expr stx)
(syntax-case stx ()
[(base-success-expr iattrs relsattrs (also ...) success)
(let ([reliattrs
(reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
#'(success fail-handler cut-prompt also ... (attribute name) ...)))]))
;; ----
;; (parse:clauses x clauses ctx)
(define-syntax (parse:clauses stx)
(syntax-case stx ()
[(parse:clauses x clauses ctx)
(with-disappeared-uses
(with-txlifts
(lambda ()
(define-values (chunks clauses-stx)
(parse-keyword-options #'clauses parse-directive-table
#:context #'ctx
#:no-duplicates? #t))
(define context
(options-select-value chunks '#:context #:default #'x))
(define-values (decls0 defs)
(get-decls+defs chunks #t #:context #'ctx))
(define (for-clause clause)
(syntax-case clause ()
[[p . rest]
(let-values ([(rest pattern defs2)
(parse-pattern+sides #'p #'rest
#:splicing? #f
#:decls decls0
#:context #'ctx)])
(unless (and (stx-list? rest) (stx-pair? rest))
(raise-syntax-error #f
"expected non-empty clause body"
#'ctx
clause))
(with-syntax ([rest rest]
[pattern pattern]
[(local-def ...) (append defs defs2)])
#`(let ()
local-def ...
(parse:S x cx pattern pr es (let () . rest)))))]))
(unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx))
(raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx))
(with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)]
[(alternative ...)
(map for-clause (stx->list clauses-stx))])
#`(let* ([ctx0 #,context]
[pr (ps-empty x ctx0)]
[es null]
[cx x]
[fh0 (syntax-patterns-fail ctx0)])
(with ([fail-handler fh0]
[cut-prompt fh0])
(try alternative ...)))))))]))
;; ----
;; (parse:S x cx S-pattern pr es k) : expr[Ans]
;; In k: attrs(S-pattern) are bound.
(define-syntax (parse:S stx)
(syntax-case stx ()
[(parse:S x cx pattern0 pr es k)
(syntax-case #'pattern0 ()
[#s(internal-rest-pattern rest-x rest-cx rest-pr)
#`(let ([rest-x x]
[rest-cx cx]
[rest-pr pr])
k)]
[#s(pat:any _attrs)
#'k]
[#s(pat:var _attrs name #f _ () _)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)]
[#s(pat:var _attrs name parser argu (nested-a ...) commit?)
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) (datum->syntax cx x cx)])
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
#'(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(with ([fail-handler fh]
[cut-prompt cp])
k))))
argu)
;; The commit protocol
;; (Avoids putting k in procedure)
#'(let ([result
(with ([fail-handler (lambda (fs) (cons 'fail fs))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result) (cons 'ok result))
argu)))])
(case (car result)
((fail) (fail (cdr result)))
((ok)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) (cdr result))
k)))))))]
[#s(pat:reflect _attrs obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) (datum->syntax cx x cx)])
#'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(with ([fail-handler fh]
[cut-prompt cp])
k))))
argu))))]
[#s(pat:datum attrs datum)
#`(let ([d (if (syntax? x) (syntax-e x) x)])
(if (equal? d (quote datum))
k
(fail (failure pr (cons (cons (expect:atom 'datum) x) es)))))]
[#s(pat:literal attrs literal input-phase lit-phase)
#`(if (and (identifier? x)
(free-identifier=?/phases
x input-phase
(quote-syntax literal) lit-phase))
k
(fail (failure pr (cons (cons (expect:literal (quote-syntax literal)) x) es))))]
[#s(pat:action attrs action subpattern)
#'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))]
[#s(pat:head attrs head tail)
#`(parse:H x cx rest-x rest-cx rest-pr head pr es
(parse:S rest-x rest-cx tail rest-pr es k))]
[#s(pat:dots attrs head tail)
#`(parse:dots x cx head tail pr es k)]
[#s(pat:and attrs subpatterns)
(for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))])
#`(parse:S x cx #,subpattern pr es #,k))]
[#s(pat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh cp id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh]
[cut-prompt cp])
k)))])
(try (parse:S x cx subpattern pr es
(disjunct subpattern success () (id ...)))
...)))]
[#s(pat:not () subpattern)
#`(let* ([fh0 fail-handler]
[pr0 pr]
[es0 es]
[fail-to-succeed
(lambda (fs) k)])
;; ~not implicitly prompts to be safe,
;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
;; (statically checked!)
(with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe
(parse:S x cx subpattern pr es
(fh0 (failure pr0 es0)))))]
[#s(pat:pair _attrs head tail)
#`(let-values ([(datum cx)
(if (syntax? x)
(values (syntax-e x) x)
(values x cx))])
(if (pair? datum)
(let ([hx (car datum)]
[hcx (car datum)]
[hpr (ps-add-car pr)]
[tx (cdr datum)]
[tpr (ps-add-cdr pr)])
(parse:S hx hcx head hpr es
(parse:S tx cx tail tpr es k)))
(fail (failure pr es))))]
[#s(pat:vector _attrs subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (vector? datum)
(let ([datum (vector->list datum)]
[vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ???
[pr (ps-add-unvector pr)])
(parse:S datum vcx subpattern pr es k))
(fail (failure pr es))))]
[#s(pat:box _attrs subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (box? datum)
(let ([datum (unbox datum)]
[bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ???
[pr (ps-add-unbox pr)])
(parse:S datum bcx subpattern pr es k))
(fail (failure pr es))))]
[#s(pat:pstruct _attrs key subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (let ([xkey (prefab-struct-key datum)])
(and xkey (equal? xkey 'key)))
(let ([datum (struct->list datum)]
[scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ???
[pr (ps-add-unpstruct pr)])
(parse:S datum scx subpattern pr es k))
(fail (failure pr es))))]
[#s(pat:describe attrs description transparent? pattern)
#`(let ([es (cons (cons (expect:thing description transparent?) x) es)]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(parse:S x cx pattern pr es k))]
[#s(pat:delimit attrs pattern)
#`(let ([cp0 cut-prompt])
(with ([cut-prompt fail-handler])
(parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))]
[#s(pat:commit attrs pattern)
#`(let ([fh0 fail-handler]
[cp0 cut-prompt])
(with ([cut-prompt fh0])
(parse:S x cx pattern pr es
(with ([cut-prompt cp0]
[fail-handler fh0])
k))))]
[#s(pat:post attrs pattern)
#`(let ([pr (ps-add-post pr)])
(parse:S x cx pattern pr es k))]
[#s(pat:integrated _attrs name argu predicate description)
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) x])
#'())])
;; NOTE: predicate must not assume x (ie, this-syntax) is stx
#'(if (app-argu predicate x argu)
(let-attributes (name-attr ...) k)
(let ([es (cons (cons (expect:thing 'description #t) x) es)])
(fail (failure pr es)))))])]))
;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans]
(define-syntax (disjunct stx)
(syntax-case stx ()
[(disjunct pattern success (pre ...) (id ...))
(with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))])
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success fail-handler cut-prompt pre ... id ...))))))]))
;; (disjunct/sides clauses success (pre:expr ...) (id:id ...)) : expr[Ans]
(define-syntax (disjunct/sides stx)
(syntax-case stx ()
[(disjunct/sides clauses success (pre ...) (id ...))
(with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses])
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success fail-handler cut-prompt pre ... id ...))))))]))
;; (parse:A x cx A-pattern pr es k) : expr[Ans]
;; In k: attrs(A-pattern) are bound.
(define-syntax (parse:A stx)
(syntax-case stx ()
[(parse:A x cx pattern0 pr es k)
(syntax-case #'pattern0 ()
[#s(action:cut _)
#'(with ([fail-handler cut-prompt]) k)]
[#s(action:bind _ (side ...))
#'(bind/sides (side ...) k)]
[#s(action:fail _ condition message)
#`(let ([c (wrap-user-code condition)])
(if c
(let ([pr* (if (syntax? c)
(ps-add-stx pr c)
pr)]
[es* (cons (cons (expect:message message)
(if (syntax? c) c x))
es)])
(fail (failure pr* es*)))
k))]
[#s(action:parse _ pattern expr)
#`(let* ([y (datum->syntax #f (wrap-user-code expr) #f)]
[cy y]
[pr* (ps-add-stx pr y)])
(parse:S y cy pattern pr* es k))]
[#s(action:do _ (stmt ...))
#'(let () (no-shadow stmt) ... (#%expression k))]
[#s(action:post _ pattern)
#'(let ([pr (ps-add-post pr)])
(parse:A x cx pattern pr es k))])]))
;; (bind/sides clauses k) : expr[Ans]
;; In k: attrs(clauses) are bound.
(define-syntax (bind/sides stx)
(syntax-case stx ()
[(_ (side ...) k)
(for/fold ([k #'k]) ([side (in-list (reverse (syntax->list #'(side ...))))])
(syntax-case side ()
[#s(clause:attr a expr)
#`(let-attributes ([a (wrap-user-code (check-list^depth a expr))])
#,k)]))]))
(begin-for-syntax
;; convert-list-pattern : ListPattern id -> SinglePattern
;; Converts '() datum pattern at end of list to bind (cons stx index)
;; to rest-var.
(define (convert-list-pattern pattern end-pattern)
(syntax-case pattern ()
[#s(pat:datum () ())
end-pattern]
[#s(pat:action attrs action tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:action attrs action tail))]
[#s(pat:head attrs head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:head attrs head tail))]
[#s(pat:dots attrs head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:dots attrs head tail))]
[#s(pat:pair attrs head-part tail-part)
(with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)])
#'#s(pat:pair attrs head-part tail-part))])))
;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k)
;; In k: rest, rest-pr, attrs(H-pattern) are bound.
(define-syntax (parse:H stx)
(syntax-case stx ()
[(parse:H x cx rest-x rest-cx rest-pr head pr es k)
(syntax-case #'head ()
[#s(hpat:describe _ description transparent? pattern)
#`(let ([es (cons (cons (expect:thing description transparent?) x) es)])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
[#s(hpat:var _attrs name parser argu (nested-a ...) commit?)
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x (ps-difference pr rest-pr))])
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
#`(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(with ([fail-handler fh]
[cut-prompt cp])
k))))
argu)
;; The commit protocol
;; (Avoids putting k in procedure)
#'(let ([result
(with ([fail-handler (lambda (fs) (cons 'fail fs))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda result (cons 'ok result))
argu)))])
(case (car result)
((fail) (fail (cdr result)))
((ok)
(let ([_fh (car result)]
[_cp (cadr result)]
[result (cddr result)])
(let ([rest-x (cadr result)]
[rest-cx (caddr result)]
[rest-pr (cadddr result)]
[result (cddddr result)])
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
k)))))))))]
[#s(hpat:reflect _attrs obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x (ps-difference pr rest-pr))])
#'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(with ([fail-handler fh]
[cut-prompt cp])
k))))
argu))))]
[#s(hpat:and (a ...) head single)
#`(let ([cx0 cx])
(parse:H x cx rest-x rest-cx rest-pr head pr es
(let ([lst (stx-list-take x (ps-difference pr rest-pr))])
(parse:S lst cx0 single pr es k))))]
[#s(hpat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh cp rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh]
[cut-prompt cp])
k)))])
(try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(disjunct subpattern success
(rest-x rest-cx rest-pr) (id ...)))
...)))]
[#s(hpat:seq attrs pattern)
(with-syntax ([pattern
(convert-list-pattern
#'pattern
#'#s(internal-rest-pattern rest-x rest-cx rest-pr))])
#'(parse:S x cx pattern pr es k))]
[#s(hpat:optional (a ...) pattern defaults)
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh cp rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh]
[cut-prompt cp])
k)))])
(try (parse:H x cx rest-x rest-cx rest-pr pattern pr es
(success fail-handler cut-prompt
rest-x rest-cx rest-pr (attribute id) ...))
(let ([rest-x x]
[rest-cx cx]
[rest-pr pr])
(bind/sides defaults
(disjunct/sides defaults success
(rest-x rest-cx rest-pr)
(id ...)))))))]
[#s(hpat:delimit _attrs pattern)
#'(let ([cp0 cut-prompt])
(with ([cut-prompt fail-handler])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es
(with ([cut-prompt cp0]) k))))]
[#s(hpat:commit attrs pattern)
#`(let ([fh0 fail-handler]
[cp0 cut-prompt])
(with ([cut-prompt fh0])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es
(with ([cut-prompt cp0]
[fail-handler fh0])
k))))]
[#s(hpat:post _ pattern)
#'(let ([pr (ps-add-post pr)])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
[_
(with-syntax ([attrs (pattern-attrs (wash #'head))])
#'(parse:S x cx
#s(pat:pair attrs head #s(internal-rest-pattern rest-x rest-cx rest-pr))
pr es k))])]))
;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans]
;; In k: attrs(EH-pattern, S-pattern) are bound.
(define-syntax (parse:dots stx)
(syntax-case stx ()
[(parse:dots x cx (#s(ehpat head-attrs head head-repc) ...) tail pr es k)
(let ()
(define repcs (wash-list wash #'(head-repc ...)))
(define rep-ids (for/list ([repc (in-list repcs)])
(and repc (generate-temporary 'rep))))
(define rel-repcs (filter values repcs))
(define rel-rep-ids (filter values rep-ids))
(define aattrs
(for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))]
[repc (in-list repcs)]
#:when #t
[a (in-list (wash-iattrs head-attrs))])
(cons a repc)))
(define attrs (map car aattrs))
(define attr-repcs (map cdr aattrs))
(define ids (map attr-name attrs))
(with-syntax ([(id ...) ids]
[(alt-id ...) (generate-temporaries ids)]
[reps rel-rep-ids]
[(head-rep ...) rep-ids]
[(rel-rep ...) rel-rep-ids]
[(rel-repc ...) rel-repcs]
[(a ...) attrs]
[(attr-repc ...) attr-repcs]
[tail-pattern-is-null?
(equal? (syntax->datum #'tail) '#s(pat:datum () ()))])
(define-pattern-variable alt-map #'((id . alt-id) ...))
(define-pattern-variable loop-k
#'(dots-loop dx* dcx* loop-pr* fail-handler cut-prompt rel-rep ... alt-id ...))
#`(let ()
;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
(define (dots-loop dx dcx loop-pr fh cp rel-rep ... alt-id ...)
(with ([fail-handler fh]
[cut-prompt cp])
(try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es
(try (parse:EH dx dcx loop-pr head-repc dx* dcx* loop-pr* alt-map head-rep
head es loop-k)
...)
(cond [(< rel-rep (rep:min-number rel-repc))
(let ([es (cons (cons (expectation-of-reps/too-few rel-rep rel-repc) dx) es)])
(fail (failure loop-pr es)))]
...
[else
(let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
(parse:S dx dcx tail loop-pr es k))]))))
(let ([rel-rep 0] ...
[alt-id (rep:initial-value attr-repc)] ...)
(dots-loop x cx pr fail-handler cut-prompt rel-rep ... alt-id ...)))))]))
;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt)
(define-syntax try-or-pair/null-check
(syntax-rules ()
[(topc #t x cx pr es pair-alt null-alt)
(cond [(stx-pair? x) pair-alt]
[(stx-null? x) null-alt]
[else (fail (failure pr es))])]
[(topc _ x cx pr es alt1 alt2)
(try alt1 alt2)]))
;; (parse:EH x cx pr repc x* cx* pr* alts rep H-pattern es k) : expr[Ans]
;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed.
(define-syntax (parse:EH stx)
(syntax-case stx ()
[(parse:EH x cx pr repc x* cx* pr* alts rep head es k)
(let ()
(define-pattern-variable k*
(let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))]
[ids (map attr-name main-attrs)]
[alt-ids
(let ([table (make-bound-id-table)])
(for ([entry (in-list (syntax->list #'alts))])
(let ([entry (syntax-e entry)])
(bound-id-table-set! table (car entry) (cdr entry))))
(for/list ([id (in-list ids)]) (bound-id-table-ref table id)))])
(with-syntax ([(id ...) ids]
[(alt-id ...) alt-ids]
[(alt-a ...) (map rename-attr main-attrs alt-ids)])
#`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
k))))
(syntax-case #'repc ()
[#f #`(parse:H x cx x* cx* pr* head pr es k*)]
[_ #`(parse:H x cx x* cx* pr* head pr es
(if (< rep (rep:max-number repc))
(let ([rep (add1 rep)]) k*)
(let ([es (cons (cons (expectation-of-reps/too-many rep repc) x*) es)])
(fail (failure pr* es)))))]))]))
;; (rep:initial-value RepConstraint) : expr
(define-syntax (rep:initial-value stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'#f]
[(_ #s(rep:optional _ _ _)) #'#f]
[(_ _) #'null]))
;; (rep:finalize RepConstraint expr) : expr
(define-syntax (rep:finalize stx)
(syntax-case stx ()
[(_ a #s(rep:optional _ _ defaults) v)
(with-syntax ([#s(attr name _ _) #'a]
[(#s(clause:attr da de) ...) #'defaults])
(let ([default
(for/or ([da (in-list (syntax->list #'(da ...)))]
[de (in-list (syntax->list #'(de ...)))])
(with-syntax ([#s(attr dname _ _) da])
(and (bound-identifier=? #'name #'dname) de)))])
(if default
#`(or v #,default)
#'v)))]
[(_ a #s(rep:once _ _ _) v) #'v]
[(_ a _ v) #'(reverse v)]))
;; (rep:min-number RepConstraint) : expr
(define-syntax (rep:min-number stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'1]
[(_ #s(rep:optional _ _ _)) #'0]
[(_ #s(rep:bounds min max _ _ _)) #'min]))
;; (rep:max-number RepConstraint) : expr
(define-syntax (rep:max-number stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'1]
[(_ #s(rep:optional _ _ _)) #'1]
[(_ #s(rep:bounds min max _ _ _)) #'max]))
;; (rep:combine RepConstraint expr expr) : expr
(define-syntax (rep:combine stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _) a b) #'a]
[(_ #s(rep:optional _ _ _) a b) #'a]
[(_ _ a b) #'(cons a b)]))
;; ----
(define-syntax-rule (expectation-of-message message)
(expect:message message))
(define-syntax expectation-of-reps/too-few
(syntax-rules ()
[(_ rep #s(rep:once name too-few-msg too-many-msg))
(expect:message (or too-few-msg (name->too-few/once name)))]
[(_ rep #s(rep:optional name too-many-msg _))
(error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")]
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
(expect:message (or too-few-msg (name->too-few name)))]))
(define-syntax expectation-of-reps/too-many
(syntax-rules ()
[(_ rep #s(rep:once name too-few-msg too-many-msg))
(expect:message (or too-many-msg (name->too-many name)))]
[(_ rep #s(rep:optional name too-many-msg _))
(expect:message (or too-many-msg (name->too-many name)))]
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
(expect:message (or too-many-msg (name->too-many name)))]))
(define (name->too-few/once name)
(and name (format "missing required occurrence of ~a" name)))
(define (name->too-few name)
(and name (format "too few occurrences of ~a" name)))
(define (name->too-many name)
(and name (format "too many occurrences of ~a" name)))

39
collects/syntax/private/stxparse/rep-attrs.rkt → collects/syntax/parse/private/rep-attrs.rkt
View File

@ -2,7 +2,8 @@
(require racket/contract/base
syntax/stx
syntax/id-table
"../util.ss")
unstable/syntax
unstable/struct)
(provide (struct-out attr))
#|
@ -14,6 +15,11 @@ attr is guaranteed to be bound to a value which is a syntax object (or
a list^depth of syntax objects).
|#
#|
SAttr lists are always stored in sorted order, to make comparison
of signatures easier for reified syntax-classes.
|#
(define-struct attr (name depth syntax?) #:prefab)
(define (iattr? a)
@ -56,6 +62,9 @@ a list^depth of syntax objects).
[iattrs->sattrs
(-> (listof iattr?)
(listof sattr?))]
[sort-sattrs
(-> (listof sattr?)
(listof sattr?))]
[intersect-sattrss
(-> (listof (listof sattr?))
@ -83,13 +92,13 @@ a list^depth of syntax objects).
(define count-t (make-bound-id-table))
(define attr-t (make-bound-id-table))
(define list-count (length attrss))
(for* ([attrs attrss] [attr attrs])
(for* ([attrs (in-list attrss)] [attr (in-list attrs)])
(define name (attr-name attr))
(define prev (bound-id-table-ref attr-t name #f))
(bound-id-table-set! attr-t name (join-attrs attr prev))
(let ([pc (bound-id-table-ref count-t name 0)])
(bound-id-table-set! count-t name (add1 pc))))
(for/list ([a (bound-id-table-map attr-t (lambda (_ v) v))])
(for/list ([a (in-list (bound-id-table-map attr-t (lambda (_ v) v)))])
(if (= (bound-id-table-ref count-t (attr-name a)) list-count)
a
(attr-make-uncertain a))))
@ -120,12 +129,18 @@ a list^depth of syntax objects).
(make attr (syntax-e name) depth syntax?)))
(define (iattrs->sattrs as)
(map iattr->sattr as))
(sort-sattrs (map iattr->sattr as)))
(define (sort-sattrs as)
(sort as string<?
#:key (lambda (a) (symbol->string (attr-name a)))
#:cache-keys? #t))
(define (rename-attr a name)
(make attr name (attr-depth a) (attr-syntax? a)))
;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr)
;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort?
(define (intersect-sattrss attrss)
(cond [(null? attrss) null]
[else
@ -137,21 +152,18 @@ a list^depth of syntax objects).
[ht (make-hasheq)]
[put (lambda (attr) (hash-set! ht (attr-name attr) attr))]
[fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))])
(for* ([attrs attrss]
[attr attrs]
(for* ([attrs (in-list attrss)]
[attr (in-list attrs)]
#:when (memq (attr-name attr) names))
(put (join-attrs attr (fetch-like attr))))
(sort (hash-map ht (lambda (k v) v))
(lambda (a b)
(string<? (symbol->string (attr-name a))
(symbol->string (attr-name b))))))]))
(sort-sattrs (hash-map ht (lambda (k v) v))))]))
;; reorder-iattrs : (listof SAttr) (listof IAttr) -> (listof IAttr)
;; Reorders iattrs (and restricts) based on relsattrs
;; If a relsattr is not found, or if depth or contents mismatches, raises error.
(define (reorder-iattrs relsattrs iattrs)
(let ([ht (make-hasheq)])
(for ([iattr iattrs])
(for ([iattr (in-list iattrs)])
(let ([remap-name (syntax-e (attr-name iattr))])
(hash-set! ht remap-name iattr)))
(let loop ([relsattrs relsattrs])
@ -178,8 +190,9 @@ a list^depth of syntax objects).
;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void
(define (check-iattrs-subset little big ctx)
(define big-t (make-bound-id-table))
(for ([a big]) (bound-id-table-set! big-t (attr-name a) #t))
(for ([a little])
(for ([a (in-list big)])
(bound-id-table-set! big-t (attr-name a) #t))
(for ([a (in-list little)])
(unless (bound-id-table-ref big-t (attr-name a) #f)
(raise-syntax-error #f
"attribute bound in defaults but not in pattern"

163
collects/syntax/private/stxparse/rep-data.rkt → collects/syntax/parse/private/rep-data.rkt
View File

@ -4,55 +4,45 @@
racket/list
syntax/stx
syntax/id-table
"../util.ss"
"minimatch.ss"
"rep-attrs.ss"
"rep-patterns.ss")
(provide (all-from-out "rep-attrs.ss")
(all-from-out "rep-patterns.ss")
unstable/syntax
"minimatch.rkt"
"kws.rkt"
"rep-attrs.rkt"
"rep-patterns.rkt")
(provide (all-from-out "rep-attrs.rkt")
(all-from-out "rep-patterns.rkt")
(struct-out stxclass)
(struct-out options)
(struct-out integrate)
stxclass/s?
stxclass/h?
stxclass-commit?
stxclass-delimit-cut?
(struct-out attr)
(struct-out rhs)
(struct-out variant)
(struct-out clause:fail)
(struct-out clause:with)
(struct-out clause:attr)
(struct-out clause:do)
(struct-out conventions)
(struct-out literalset))
#|
NOTES
syntax-class protocol
---------------------
Two kinds of syntax class: commit? = #t, commit? = #f
let syntax-class SC have params (P ...)
if commit? = #t
parser : Stx P ... -> (U list expectation)
if commit? = #f
parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer
conventions
-----------
let conventions C have params (P ...)
get-procedures :
(P ... -> (values (listof ParserFun) (listof DescriptionFun)))
|#
(struct-out literalset)
(struct-out eh-alternative-set)
(struct-out eh-alternative))
#|
A stxclass is
(make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean)
#s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
where Options = #s(options boolean boolean)
Integrate = #s(integrate id string)
Arity is defined in kws.rkt
|#
(define-struct stxclass (name params attrs parser-name description
splicing? commit?)
(define-struct stxclass (name arity attrs parser splicing? options integrate)
#:prefab)
(define-struct options (commit? delimit-cut?)
#:prefab)
(define-struct integrate (predicate description)
#:prefab)
(define (stxclass/s? x)
@ -60,29 +50,28 @@ A stxclass is
(define (stxclass/h? x)
(and (stxclass? x) (stxclass-splicing? x)))
(define (stxclass-commit? x)
(options-commit? (stxclass-options x)))
(define (stxclass-delimit-cut? x)
(options-delimit-cut? (stxclass-options x)))
#|
An RHS is
(make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx))
#s(rhs stx (listof SAttr) bool stx/#f (listof Variant) (listof stx) Options Integrate/#f)
definitions: auxiliary definitions from #:declare
|#
(define-struct rhs (ostx attrs transparent? description variants definitions commit?)
(define-struct rhs (ostx attrs transparent? description variants definitions options integrate)
#:prefab)
#|
A Variant is
(make-variant stx (listof SAttr) Pattern (listof SideClause))
(make-variant stx (listof SAttr) Pattern (listof stx))
|#
(define-struct variant (ostx attrs pattern sides definitions) #:prefab)
(define-struct variant (ostx attrs pattern definitions) #:prefab)
#|
A SideClause is one of
(make-clause:fail stx stx)
(make-clause:with pattern stx (listof stx))
(make-clause:attr IAttr stx)
SideClause is defined in rep-patterns
|#
(define-struct clause:fail (condition message) #:prefab)
(define-struct clause:with (pattern expr definitions) #:prefab)
(define-struct clause:attr (attr expr) #:prefab)
#|
A Conventions is
@ -100,8 +89,16 @@ A LiteralSet is
;; make-dummy-stxclass : identifier -> SC
;; Dummy stxclass for calculating attributes of recursive stxclasses.
(define (make-dummy-stxclass name)
(make stxclass (syntax-e name) null null #f #f #f #t))
(make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f))
#|
An EH-alternative-set is
(eh-alternative-set (listof EH-alternative)
An EH-alternative is
(eh-alternative RepetitionConstraint (listof SAttr) id)
|#
(define-struct eh-alternative-set (alts))
(define-struct eh-alternative (repc attrs parser))
;; Environments
@ -111,22 +108,24 @@ DeclEnv =
(listof ConventionRule))
DeclEntry =
(make-den:lit id id ct-phase ct-phase)
(make-den:class id id (listof syntax) bool)
(make-den:parser id id (listof SAttr) bool bool)
(make-den:delayed id id id)
(den:lit id id ct-phase ct-phase)
(den:class id id Arguments)
(den:parser id (listof SAttr) bool bool bool)
(den:delayed id id)
Arguments is defined in rep-patterns.rkt
|#
(define-struct declenv (table conventions))
(define-struct den:lit (internal external input-phase lit-phase))
(define-struct den:class (name class args))
(define-struct den:parser (parser description attrs splicing? commit?))
(define-struct den:delayed (parser description class))
(define-struct den:class (name class argu))
(define-struct den:parser (parser attrs splicing? commit? delimit-cut?))
(define-struct den:delayed (parser class))
(define (new-declenv literals #:conventions [conventions null])
(make-declenv
(for/fold ([table (make-immutable-bound-id-table)])
([literal literals])
([literal (in-list literals)])
(bound-id-table-set table (car literal)
(make den:lit (first literal) (second literal)
(third literal) (fourth literal))))
@ -152,15 +151,15 @@ DeclEntry =
stxclass-name)
(wrong-syntax (if blame-declare? name id)
"identifier previously declared"))]
[(struct den:parser (_p _d _a _sp _c))
[(struct den:parser (_p _a _sp _c _dc?))
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
(define (declenv-put-stxclass env id stxclass-name args)
(define (declenv-put-stxclass env id stxclass-name argu)
(declenv-check-unbound env id)
(make-declenv
(bound-id-table-set (declenv-table env) id
(make den:class id stxclass-name args))
(make den:class id stxclass-name argu))
(declenv-conventions env)))
;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
@ -168,7 +167,7 @@ DeclEntry =
(define (declenv-update/fold env0 f acc0)
(define-values (acc1 rules1)
(for/fold ([acc acc0] [newrules null])
([rule (declenv-conventions env0)])
([rule (in-list (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)
@ -182,7 +181,7 @@ DeclEntry =
;; 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 ([id (in-list ids)]) (bound-id-table-set! idbm id #t))
(for/list ([(k v) (in-dict (declenv-table env))]
#:when (or (den:class? v) (den:parser? v))
#:when (not (bound-id-table-ref idbm k #f)))
@ -192,7 +191,7 @@ DeclEntry =
(define (conventions-lookup conventions id)
(let ([sym (symbol->string (syntax-e id))])
(for/or ([c conventions])
(for/or ([c (in-list conventions)])
(and (regexp-match? (car c) sym) (cadr c)))))
;; Contracts
@ -205,7 +204,7 @@ DeclEntry =
(or/c den:lit? den:class? den:parser? den:delayed?)))
(define SideClause/c
(or/c clause:fail? clause:with? clause:attr?))
(or/c clause:fail? clause:with? clause:attr? clause:do?))
;; ct-phase = syntax, expr that computes absolute phase
;; usually = #'(syntax-local-phase-level)
@ -232,7 +231,7 @@ DeclEntry =
[declenv-lookup
(-> DeclEnv/c identifier? any)]
[declenv-put-stxclass
(-> DeclEnv/c identifier? identifier? (listof syntax?)
(-> DeclEnv/c identifier? identifier? arguments?
DeclEnv/c)]
[declenv-domain-difference
(-> DeclEnv/c (listof identifier?)
@ -244,11 +243,13 @@ DeclEntry =
(values DeclEnv/c any/c))]
[get-stxclass
(-> identifier? any)]
[get-stxclass/check-arg-count
(-> identifier? exact-nonnegative-integer? any)]
(-> identifier? stxclass?)]
[get-stxclass/check-arity
(-> identifier? syntax? exact-nonnegative-integer? (listof keyword?)
stxclass?)]
[split-id/get-stxclass
(-> identifier? DeclEnv/c any)])
(-> identifier? DeclEnv/c
(values identifier? (or/c stxclass? #f)))])
;; stxclass-lookup-config : (parameterof (U 'no 'try 'yes))
;; 'no means don't lookup, always use dummy (no nested attrs)
@ -265,16 +266,12 @@ DeclEntry =
(make-dummy-stxclass id)]
[else (wrong-syntax id "not defined as syntax class")])))
(define (get-stxclass/check-arg-count id arg-count)
(let* ([sc (get-stxclass id)]
[expected-arg-count (length (stxclass-params sc))])
(unless (or (= expected-arg-count arg-count)
(memq (stxclass-lookup-config) '(try no)))
;; (above: don't check error if stxclass may not be defined yet)
(wrong-syntax id
"too few arguments for syntax-class ~a (expected ~s)"
(syntax-e id)
expected-arg-count))
(define (get-stxclass/check-arity id stx pos-count keywords)
(let ([sc (get-stxclass id)])
(unless (memq (stxclass-lookup-config) '(try no))
(check-arity (stxclass-arity sc) pos-count keywords
(lambda (msg)
(raise-syntax-error #f msg stx))))
sc))
(define (split-id/get-stxclass id0 decls)
@ -286,6 +283,16 @@ DeclEntry =
(datum->syntax id0 (string->symbol (caddr m)) id0 id0))
(declenv-check-unbound decls id (syntax-e scname)
#:blame-declare? #t)
(let ([sc (get-stxclass/check-arg-count scname 0)])
(let ([sc (get-stxclass/check-arity scname id0 0 null)])
(values id sc)))]
[else (values id0 #f)]))
;; ----
(provide get-eh-alternative-set)
(define (get-eh-alternative-set id)
(let ([v (syntax-local-value id (lambda () #f))])
(unless (eh-alternative-set? v)
(wrong-syntax id "not defined as an eh-alternative-set"))
v))

383
collects/syntax/parse/private/rep-patterns.rkt Normal file
View File

@ -0,0 +1,383 @@
#lang racket/base
(require "rep-attrs.rkt"
"kws.rkt"
unstable/struct
(for-syntax racket/base
syntax/stx
unstable/syntax))
(provide (all-defined-out))
#|
Uses Arguments from kws.rkt
|#
#|
A Base is (listof IAttr)
If P = (make-pattern Attrs ...) and A is in Attrs,
the depth of A is with respect to P,
not with respect to the entire enclosing pattern.
|#
#|
A SinglePattern is one of
(pat:any Base)
(pat:var Base id id Arguments (listof IAttr) bool)
(pat:literal Base identifier ct-phase ct-phase)
(pat:datum Base datum)
(pat:action Base ActionPattern SinglePattern)
(pat:head Base HeadPattern SinglePattern)
(pat:dots Base (listof EllipsisHeadPattern) SinglePattern)
(pat:and Base (listof SinglePattern))
(pat:or Base (listof SinglePattern))
(pat:not Base SinglePattern)
(pat:pair Base SinglePattern SinglePattern)
(pat:vector Base SinglePattern)
(pat:box Base SinglePattern)
(pat:pstruct Base key SinglePattern)
(pat:describe Base stx boolean SinglePattern)
(pat:delimit Base SinglePattern)
(pat:commit Base SinglePattern)
(pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
(pat:post Base SinglePattern)
(pat:integrated Base id/#f Arguments id string)
A ListPattern is a subtype of SinglePattern; one of
(pat:datum Base '())
(pat:action Base ActionPattern ListPattern)
(pat:head Base HeadPattern ListPattern)
(pat:pair Base SinglePattern ListPattern)
(pat:dots Base EllipsisHeadPattern SinglePattern)
|#
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser argu nested-attrs commit?) #:prefab)
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:action (attrs action inner) #:prefab)
(define-struct pat:head (attrs head tail) #:prefab)
(define-struct pat:dots (attrs heads tail) #:prefab)
(define-struct pat:and (attrs patterns) #:prefab)
(define-struct pat:or (attrs patterns) #:prefab)
(define-struct pat:not (attrs pattern) #:prefab)
(define-struct pat:pair (attrs head tail) #:prefab)
(define-struct pat:vector (attrs pattern) #:prefab)
(define-struct pat:box (attrs pattern) #:prefab)
(define-struct pat:pstruct (attrs key pattern) #:prefab)
(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
(define-struct pat:delimit (attrs pattern) #:prefab)
(define-struct pat:commit (attrs pattern) #:prefab)
(define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
(define-struct pat:post (attrs pattern) #:prefab)
(define-struct pat:integrated (attrs name argu predicate description) #:prefab)
#|
A ActionPattern is one of
(action:cut Base)
(action:fail Base stx stx)
(action:bind Base (listof clause:attr))
* (action:and Base (listof ActionPattern))
(action:parse Base SinglePattern stx)
(action:do Base (listof stx))
(action:post Base ActionPattern)
action:and is desugared below in create-* procedures
|#
(define-struct action:cut (attrs) #:prefab)
(define-struct action:fail (attrs when message) #:prefab)
(define-struct action:bind (attrs clauses) #:prefab)
(define-struct action:and (attrs patterns) #:prefab)
(define-struct action:parse (attrs pattern expr) #:prefab)
(define-struct action:do (attrs stmts) #:prefab)
(define-struct action:post (attrs pattern) #:prefab)
#|
A HeadPattern is one of
(hpat:var Base id id Arguments (listof IAttr) bool)
(hpat:seq Base ListPattern)
(hpat:action Base ActionPattern HeadPattern)
(hpat:and Base HeadPattern SinglePattern)
(hpat:or Base (listof HeadPattern))
(hpat:optional Base HeadPattern (listof clause:attr))
(hpat:describe Base stx/#f boolean HeadPattern)
(hpat:delimit Base HeadPattern)
(hpat:commit Base HeadPattern)
(hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
(hpat:post Base HeadPattern)
|#
(define-struct hpat:var (attrs name parser argu nested-attrs commit?) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:action (attrs action inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab)
(define-struct hpat:optional (attrs inner defaults) #:prefab)
(define-struct hpat:describe (attrs description transparent? pattern) #:prefab)
(define-struct hpat:delimit (attrs pattern) #:prefab)
(define-struct hpat:commit (attrs pattern) #:prefab)
(define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
(define-struct hpat:post (attrs pattern) #:prefab)
#|
An EllipsisHeadPattern is
(ehpat Base HeadPattern RepConstraint)
A RepConstraint is one of
(rep:once stx stx stx)
(rep:optional stx stx (listof clause:attr))
(rep:bounds nat/#f nat/#f stx stx stx)
#f
|#
(define-struct ehpat (attrs head repc) #:prefab)
(define-struct rep:once (name under-message over-message) #:prefab)
(define-struct rep:optional (name over-message defaults) #:prefab)
(define-struct rep:bounds (min max name under-message over-message) #:prefab)
#|
A SideClause is one of
(clause:fail stx stx)
(clause:with pattern stx (listof stx))
(clause:attr IAttr stx)
(clause:do (listof stx))
|#
(define-struct clause:fail (condition message) #:prefab)
(define-struct clause:with (pattern expr definitions) #:prefab)
(define-struct clause:attr (attr expr) #:prefab)
(define-struct clause:do (stmts) #:prefab)
(define (pattern? x)
(or (pat:any? x)
(pat:var? x)
(pat:literal? x)
(pat:datum? x)
(pat:action? x)
(pat:head? x)
(pat:dots? x)
(pat:and? x)
(pat:or? x)
(pat:not? x)
(pat:pair? x)
(pat:vector? x)
(pat:box? x)
(pat:pstruct? x)
(pat:describe? x)
(pat:delimit? x)
(pat:commit? x)
(pat:reflect? x)
(pat:post? x)
(pat:integrated? x)))
(define (action-pattern? x)
(or (action:cut? x)
(action:bind? x)
(action:fail? x)
(action:and? x)
(action:parse? x)
(action:do? x)
(action:post? x)))
(define (head-pattern? x)
(or (hpat:var? x)
(hpat:seq? x)
(hpat:action? x)
(hpat:and? x)
(hpat:or? x)
(hpat:optional? x)
(hpat:describe? x)
(hpat:delimit? x)
(hpat:commit? x)
(hpat:reflect? x)
(hpat:post? x)))
(define (ellipsis-head-pattern? x)
(ehpat? x))
(define single-pattern? pattern?)
(define (single-or-head-pattern? x)
(or (single-pattern? x)
(head-pattern? x)))
(define pattern-attrs
(let ()
(define-syntax (mk-get-attrs stx)
(syntax-case stx ()
[(_ struct ...)
(with-syntax
([([pred accessor] ...)
(for/list ([s (in-list (stx->list #'(struct ...)))])
(list (format-id s "~a?" (syntax-e s))
(format-id s "~a-attrs" (syntax-e s))))])
#'(lambda (x)
(cond [(pred x) (accessor x)] ...
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
(mk-get-attrs pat:any pat:var pat:datum pat:literal pat:action pat:head
pat:dots pat:and pat:or pat:not pat:describe
pat:pair pat:vector pat:box pat:pstruct
pat:delimit pat:commit pat:reflect pat:post pat:integrated
action:cut action:bind action:fail action:and action:parse
action:do action:post
hpat:var hpat:seq hpat:action hpat:and hpat:or hpat:describe
hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post
ehpat)))
;; ----
;; Helpers to handle attribute calculations
;; Too complicated for a few pattern forms; those are handled in rep.rkt
(define (create-pat:any)
(make pat:any null))
(define (create-pat:var name parser argu nested-attrs commit?)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser argu nested-attrs commit?)))
(define (create-pat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:reflect attrs obj argu attr-decls name nested-attrs)))
(define (create-pat:datum datum)
(make pat:datum null datum))
(define (create-pat:literal literal input-phase lit-phase)
(make pat:literal null literal input-phase lit-phase))
(define (create-pat:action g sp)
(cond [(action:and? g)
(for/fold ([sp sp]) ([g (in-list (reverse (action:and-patterns g)))])
(create-pat:action g sp))]
[else
(let ([attrs (append-iattrs (map pattern-attrs (list g sp)))])
(make pat:action attrs g sp))]))
(define (create-pat:head headp tailp)
(let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))])
(make pat:head attrs headp tailp)))
(define (create-pat:pair headp tailp)
(make pat:pair (append-iattrs (map pattern-attrs (list headp tailp))) headp tailp))
(define (create-pat:vector pattern)
(make pat:vector (pattern-attrs pattern) pattern))
(define (create-pat:box pattern)
(make pat:box (pattern-attrs pattern) pattern))
(define (create-pat:pstruct key pattern)
(make pat:pstruct (pattern-attrs pattern) key pattern))
(define (create-pat:describe description transparent? p)
(make pat:describe (pattern-attrs p) description transparent? p))
(define (create-pat:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make pat:and attrs patterns)))
(define (create-pat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make pat:or attrs patterns)))
(define (create-pat:not pattern)
(make pat:not null pattern))
(define (create-pat:dots headps tailp)
(let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))])
(make pat:dots attrs headps tailp)))
(define (create-pat:delimit pattern)
(make pat:delimit (pattern-attrs pattern) pattern))
(define (create-pat:commit pattern)
(make pat:commit (pattern-attrs pattern) pattern))
(define (create-pat:post pattern)
(make pat:post (pattern-attrs pattern) pattern))
(define (create-pat:integrated name argu predicate description)
(let ([attrs (if name (list (make attr name 0 #t)) null)])
(make pat:integrated attrs name argu predicate description)))
;; ----
(define (create-action:cut)
(make action:cut null))
(define (create-action:fail condition message)
(make action:fail null condition message))
(define (create-action:bind clauses)
(make action:bind (map clause:attr-attr clauses) clauses))
(define (create-action:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make action:and attrs patterns)))
(define (create-action:parse pattern expr)
(make action:parse (pattern-attrs pattern) pattern expr))
(define (create-action:do stmts)
(make action:do null stmts))
(define (create-action:post pattern)
(make action:post (pattern-attrs pattern) pattern))
;; ----
(define (create-hpat:var name parser argu nested-attrs commit?)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser argu nested-attrs commit?)))
(define (create-hpat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:reflect attrs obj argu attr-decls name nested-attrs)))
(define (create-hpat:seq lp)
(make hpat:seq (pattern-attrs lp) lp))
(define (create-hpat:action g hp)
(cond [(action:and? g)
(for/fold ([hp hp]) ([g (in-list (reverse (action:and-patterns g)))])
(create-hpat:action g hp))]
[else
(let ([attrs (append-iattrs (map pattern-attrs (list g hp)))])
(make hpat:action attrs g hp))]))
(define (create-hpat:describe description transparent? p)
(make hpat:describe (pattern-attrs p) description transparent? p))
(define (create-hpat:and hp sp)
(make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp))
(define (create-hpat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make hpat:or attrs patterns)))
(define (create-hpat:delimit pattern)
(make hpat:delimit (pattern-attrs pattern) pattern))
(define (create-hpat:commit pattern)
(make hpat:commit (pattern-attrs pattern) pattern))
(define (create-hpat:post pattern)
(make hpat:post (pattern-attrs pattern) pattern))
;; ----
(define (action/head-pattern->list-pattern p)
(cond [(action-pattern? p)
(create-pat:action p (create-pat:any))]
[(hpat:seq? p)
;; simplification: just extract list pattern from hpat:seq
(hpat:seq-inner p)]
[else
(create-pat:head p (create-pat:datum '()))]))
(define (action-pattern->single-pattern gp)
(create-pat:action gp (create-pat:any)))

908
collects/syntax/private/stxparse/rep.rkt → collects/syntax/parse/private/rep.rkt
View File

File diff suppressed because it is too large Load Diff

200
collects/syntax/parse/private/runtime-failure.rkt Normal file
View File

@ -0,0 +1,200 @@
#lang racket/base
(require "minimatch.rkt"
"runtime-progress.rkt")
(provide (struct-out failure)
expect?
(struct-out expect:thing)
(struct-out expect:atom)
(struct-out expect:literal)
(struct-out expect:message)
(struct-out expect:disj)
normalize-expectstack
simplify-common-expectstacks
maximal-failures
partition/equal?)
;; A Failure is (make-failure PS ExpectStack)
;; A FailureSet is one of
;; - Failure
;; - (cons FailureSet FailureSet)
;; FailFunction = (FailureSet -> Answer)
(define-struct failure (progress expectstack) #:prefab)
;; == Expectations
;; FIXME: add phase to expect:literal
#|
An ExpectStack is (listof (cons Expect syntax))
FIXME: (cons Expect syntax) -> struct instead?
FIXME: replace syntax with progress (better cdr handling)
An Expect is one of
- (make-expect:thing string boolean)
* (make-expect:message string)
* (make-expect:atom atom)
* (make-expect:literal identifier)
* (make-expect:disj (non-empty-listof Expect))
The *-marked variants can only occur at the top of the stack.
|#
(define-struct expect:thing (description transparent?) #:prefab)
(define-struct expect:message (message) #:prefab)
(define-struct expect:atom (atom) #:prefab)
(define-struct expect:literal (literal) #:prefab)
(define-struct expect:disj (expects) #:prefab)
(define (expect? x)
(or (expect:thing? x)
(expect:message? x)
(expect:atom? x)
(expect:literal? x)
(expect:disj? x)))
;; == Failure simplification ==
;; maximal-failures : FailureSet -> (listof (listof Failure))
(define (maximal-failures fs)
(define ann-failures
(for/list ([f (in-list (flatten fs null))])
(cons f (invert-ps (failure-progress f)))))
(maximal/progress ann-failures))
(define (flatten fs onto)
(cond [(pair? fs)
(flatten (car fs) (flatten (cdr fs) onto))]
[else
(cons fs onto)]))
;; == Expectation simplification ==
;; normalize-expectstack : ExpectStack -> ExpectStack
(define (normalize-expectstack es)
(filter-expectstack (truncate-opaque-expectstack es)))
;; truncate-opaque-expectstack : ExpectStack -> ExpectStack
;; Eliminates expectations on top of opaque (ie, transparent=#f) frames.
(define (truncate-opaque-expectstack es)
(let/ec return
(let loop ([es es])
(match es
['() '()]
[(cons (cons (expect:thing description '#f) stx) rest-es)
;; Tricky! If multiple opaque frames, multiple "returns",
;; but innermost one called first, so jumps past the rest.
(return (cons (car es) (loop rest-es)))]
[(cons expect+stx rest-es)
(cons expect+stx (loop rest-es))]))))
;; filter-expectstack : ExpectStack -> ExpectStack
;; Eliminates missing (ie, #f) messages and descriptions
(define (filter-expectstack es)
(filter (lambda (expect)
(match expect
[(cons (expect:thing '#f _) _)
#f]
[(cons (expect:message '#f) _)
#f]
[_ #t]))
es))
#|
Simplification dilemma
What if we have (e1 e2) and (e2)? How do we report that?
Options:
1) consider them separate
2) simplify to (e2), drop e1
Big problem with Option 1:
eg (x:id ...) matching #'1 yields
(union (failure #:progress () #:expectstack ())
(failure #:progress () #:expectstack (#s(expect:atom ()))))
but we don't want to see "expected ()"
So we go with option 2.
|#
;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack)
;; Should call remove-duplicates first.
(define (simplify-common-expectstacks ess)
;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
(define (simplify ress)
(let ([ress-partitions (partition/car ress)])
(if ress-partitions
(apply append
(for/list ([ress-partition (in-list ress-partitions)])
(let ([proto-frame (car (car ress-partition))]
[cdr-ress (map cdr ress-partition)])
(map (lambda (res) (cons proto-frame res))
(simplify/check-leafs cdr-ress)))))
(list null))))
;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
(define (simplify/check-leafs ress)
(let ([ress (simplify ress)])
(cond [(andmap singleton? ress)
;; Assume the syntax parts are the same
(let* ([frames (map car ress)]
[frame-stx (cdr (car frames))])
(list (list (cons (if (singleton? frames)
(car (car frames))
(expect:disj (map car frames)))
frame-stx))))]
[else ress])))
;; singleton? : list -> boolean
(define (singleton? res)
(and (pair? res) (null? (cdr res))))
(map reverse (simplify/check-leafs (map reverse ess))))
;; partition/car : (listof list) -> (listof (listof list))/#f
;; Returns #f if any of lists is empty.
(define (partition/car lists)
(and (andmap pair? lists)
(partition/equal? lists car)))
(define (partition/equal? items key)
(let ([r-keys null] ;; mutated
[key-t (make-hash)])
(for ([item (in-list items)])
(let ([k (key item)])
(let ([entry (hash-ref key-t k null)])
(when (null? entry)
(set! r-keys (cons k r-keys)))
(hash-set! key-t k (cons item entry)))))
(let loop ([r-keys r-keys] [acc null])
(cond [(null? r-keys) acc]
[else
(loop (cdr r-keys)
(cons (reverse (hash-ref key-t (car r-keys)))
acc))]))))
;; ==== Debugging
(provide failureset->sexpr
failure->sexpr
expectstack->sexpr
expect->sexpr)
(define (failureset->sexpr fs)
(let ([fs (flatten fs null)])
(case (length fs)
((1) (failure->sexpr (car fs)))
(else `(union ,@(map failure->sexpr fs))))))
(define (failure->sexpr f)
(match f
[(failure progress expectstack)
`(failure ,(progress->sexpr progress)
#:expected ,(expectstack->sexpr expectstack))]))
(define (expectstack->sexpr es)
(map expect->sexpr es))
(define (expect->sexpr e)
e)

266
collects/syntax/parse/private/runtime-progress.rkt Normal file
View File

@ -0,0 +1,266 @@
#lang racket/base
(require unstable/struct
syntax/stx
"minimatch.rkt")
(provide ps-empty
ps-add-car
ps-add-cdr
ps-add-post
ps-add-stx
ps-add-unbox
ps-add-unvector
ps-add-unpstruct
ps-add-opaque
#|
ps->stx+index
|#
ps-context-syntax
ps-difference
invert-ps
maximal/progress
progress->sexpr)
#|
Progress (PS) is a non-empty list of Progress Frames (PF).
A PF is one of
- stx ;; "Base" frame
- 'car
- nat ;; Represents that many repeated cdrs
- 'post
- 'opaque
stx frame introduced
- always at base (that is, by syntax-parse)
- if syntax-parse has #:context arg, then two stx frames at bottom:
(list to-match-stx context-stx)
- by #:with/~parse
- by #:fail-*/#:when/~fail & stx
Interpretation: Inner PS structures are applied first.
eg, (list 'car 1 #'___)
means ( car of ( cdr once of the term ) )
NOT apply car, then apply cdr once, then stop
|#
(define (ps-empty stx ctx)
(if (eq? stx ctx)
(list stx)
(list stx ctx)))
(define (ps-add-car parent)
(cons 'car parent))
(define (ps-add-cdr parent [times 1])
(if (zero? times)
parent
(match (car parent)
[(? exact-positive-integer? n)
(cons (+ times n) (cdr parent))]
[_
(cons times parent)])))
(define (ps-add-post parent)
(cons 'post parent))
(define (ps-add-stx parent stx)
(cons stx parent))
(define (ps-add-unbox parent)
(ps-add-car parent))
(define (ps-add-unvector parent)
(ps-add-car parent))
(define (ps-add-unpstruct parent)
(ps-add-car parent))
(define (ps-add-opaque parent)
(cons 'opaque parent))
;; ps-context-syntax : Progress -> syntax
(define (ps-context-syntax ps)
;; Bottom frame is always syntax
(car (reverse ps)))
;; ps->stx+index : Progress -> (values stx nat)
;; Gets the innermost stx that should have a real srcloc, and the offset
;; (number of cdrs) within that where the progress ends.
(define (ps->stx+index ps)
(define (interp ps)
(match ps
[(cons (? syntax? stx) _) stx]
[(cons 'car parent)
(let ([d (syntax-e (interp parent))])
(cond [(pair? d) (car d)]
[(vector? d) (vector->list d)]
[(box? d) (unbox d)]
[(prefab-struct-key d) (struct->list d)]
[else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
[(cons (? exact-positive-integer? n) parent)
(for/fold ([stx (interp parent)]) ([i (in-range n)])
(stx-cdr stx))]
[(cons 'post parent)
(interp parent)]))
(match ps
[(cons (? syntax? stx) _)
(values stx 0)]
[(cons 'car parent)
(values (interp ps) 0)]
[(cons (? exact-positive-integer? n) parent)
(values (interp parent) n)]
[(cons 'post parent)
(ps->stx+index parent)]))
;; ps-difference : PS PS -> nat
;; Returns N s.t. B = (ps-add-cdr^N A)
(define (ps-difference a b)
(define (whoops)
(error 'ps-difference "~e is not an extension of ~e"
(progress->sexpr b) (progress->sexpr a)))
(match (list a b)
[(list (cons (? exact-positive-integer? na) pa)
(cons (? exact-positive-integer? nb) pb))
(unless (equal? pa pb) (whoops))
(- nb na)]
[(list pa (cons (? exact-positive-integer? nb) pb))
(unless (equal? pa pb) (whoops))
nb]
[_
(unless (equal? a b) (whoops))
0]))
;; ps-truncate-opaque : PS -> PS
(define (ps-truncate-opaque ps)
(let/ec return
(let loop ([ps ps])
(cond [(null? ps)
null]
[(eq? (car ps) 'opaque)
;; Tricky! We only jump after loop returns,
;; so jump closest to end wins.
(return (loop (cdr ps)))]
[else
;; Either (loop _) jumps, or it is identity
(loop (cdr ps))
ps]))))
#|
Progress ordering
-----------------
Lexicographic generalization of partial order on frames
CAR < CDR < POST, stx incomparable except to self
Progress equality
-----------------
If ps1 = ps2 then both must "blame" the same term,
ie (ps->stx+index ps1) = (ps->stx+index ps2).
|#
;; An Inverted PS (IPS) is a PS inverted for easy comparison.
;; An IPS may not contain any 'opaque frames.
;; invert-ps : PS -> IPS
(define (invert-ps ps)
(reverse (ps-truncate-opaque ps)))
;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A))
;; Returns a list of equivalence sets.
(define (maximal/progress items)
(cond [(null? items)
null]
[(null? (cdr items))
(list (list (car (car items))))]
[else
(let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR)
(partition/pf items)])
(append (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
(if (pair? rSTX)
(maximal/stx rSTX)
null)))]))
;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0
(define (partition/pf items)
(let ([rNULL null]
[rCAR null]
[rCDR null]
[rPOST null]
[rSTX null]
[leastCDR #f])
(for ([a+ips (in-list items)])
(let ([ips (cdr a+ips)])
(cond [(null? ips)
(set! rNULL (cons a+ips rNULL))]
[(eq? (car ips) 'car)
(set! rCAR (cons a+ips rCAR))]
[(exact-positive-integer? (car ips))
(set! rCDR (cons a+ips rCDR))
(set! leastCDR
(if leastCDR
(min leastCDR (car ips))
(car ips)))]
[(eq? (car ips) 'post)
(set! rPOST (cons a+ips rPOST))]
[(syntax? (car ips))
(set! rSTX (cons a+ips rSTX))]
[else
(error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)])))
(values rNULL rCAR rCDR rPOST rSTX leastCDR)))
;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A))
(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
(cond [(pair? rPOST)
(maximal/progress (rmap pop-item-ips rPOST))]
[(pair? rCDR)
(maximal/progress
(rmap (lambda (a+ips)
(let ([a (car a+ips)] [ips (cdr a+ips)])
(cond [(= (car ips) leastCDR)
(cons a (cdr ips))]
[else
(cons a (cons (- (car ips) leastCDR) (cdr ips)))])))
rCDR))]
[(pair? rCAR)
(maximal/progress (rmap pop-item-ips rCAR))]
[(pair? rNULL)
(list (map car rNULL))]
[else
null]))
;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A))
(define (maximal/stx rSTX)
(let ([stxs null]
[table (make-hasheq)])
(for ([a+ips (in-list rSTX)])
(let* ([ips (cdr a+ips)]
[entry (hash-ref table (car ips) null)])
(when (null? entry)
(set! stxs (cons (car ips) stxs)))
(hash-set! table (car ips) (cons a+ips entry))))
(apply append
(map (lambda (key)
(maximal/progress (map pop-item-ips (hash-ref table key))))
stxs))))
;; pop-item-ips : (cons A IPS) -> (cons A IPS)
(define (pop-item-ips a+ips)
(let ([a (car a+ips)]
[ips (cdr a+ips)])
(cons a (cdr ips))))
(define (rmap f xs)
(let rmaploop ([xs xs] [accum null])
(cond [(pair? xs)
(rmaploop (cdr xs) (cons (f (car xs)) accum))]
[else
accum])))
;; == Debugging ==
(provide progress->sexpr)
(define (progress->sexpr ps)
(for/list ([pf (in-list (invert-ps ps))])
(match pf
[(? syntax? stx) 'stx]
['car 'car]
['post 'post]
[(? exact-positive-integer? n) n]
['opaque 'opaque])))

108
collects/syntax/parse/private/runtime-reflect.rkt Normal file
View File

@ -0,0 +1,108 @@
#lang racket/base
(require (for-syntax racket/base
"rep-data.rkt")
"rep-attrs.rkt"
"kws.rkt")
(provide (struct-out reified)
(struct-out reified-syntax-class)
(struct-out reified-splicing-syntax-class)
reify-syntax-class
reified-syntax-class?
reified-splicing-syntax-class?
reflect-parser)
#|
A Reified is
(reified symbol ParserFunction nat (listof (list symbol nat)))
|#
(define-struct reified-base (name) #:transparent)
(define-struct (reified reified-base) (parser arity signature))
(define-struct (reified-syntax-class reified) ())
(define-struct (reified-splicing-syntax-class reified) ())
;; ----
(define-syntax (reify-syntax-class stx)
(if (eq? (syntax-local-context) 'expression)
(syntax-case stx ()
[(rsc sc)
(let* ([stxclass (get-stxclass #'sc)]
[splicing? (stxclass-splicing? stxclass)])
(unless (stxclass-delimit-cut? stxclass)
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
stx #'sc))
(with-syntax ([name (stxclass-name stxclass)]
[parser (stxclass-parser stxclass)]
[arity (stxclass-arity stxclass)]
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
[ctor
(if splicing?
#'reified-splicing-syntax-class
#'reified-syntax-class)])
#'(ctor 'name parser 'arity '((aname adepth) ...))))])
#`(#%expression #,stx)))
;; ----
;; e-arity represents single call; min and max are same
(define (reflect-parser obj e-arity e-attrs splicing?)
(define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
(if splicing?
(unless (reified-splicing-syntax-class? obj)
(raise-type-error who "reified splicing-syntax-class" obj))
(unless (reified-syntax-class? obj)
(raise-type-error who "reified syntax-class" obj)))
(check-params who e-arity (reified-arity obj) obj)
(adapt-parser who
(for/list ([a (in-list e-attrs)])
(list (attr-name a) (attr-depth a)))
(reified-signature obj)
(reified-parser obj)
splicing?))
(define (check-params who e-arity r-arity obj)
(let ([e-pos (arity-minpos e-arity)]
[e-kws (arity-minkws e-arity)])
(check-arity/neg r-arity e-pos e-kws
(lambda (msg)
(raise-mismatch-error who (string-append msg ": ") obj)))))
(define (adapt-parser who esig0 rsig0 parser splicing?)
(if (equal? esig0 rsig0)
parser
(let ([indexes
(let loop ([esig esig0] [rsig rsig0] [index 0])
(cond [(null? esig)
null]
[(and (pair? rsig) (eq? (caar esig) (caar rsig)))
(unless (= (cadar esig) (cadar rsig))
(wrong-depth who (car esig) (car rsig)))
(cons index (loop (cdr esig) (cdr rsig) (add1 index)))]
[(and (pair? rsig)
(string>? (symbol->string (caar esig))
(symbol->string (caar rsig))))
(loop esig (cdr rsig) (add1 index))]
[else
(error who "reified syntax-class is missing declared attribute `~s'"
(caar esig))]))])
(define (take-indexes result indexes)
(let loop ([result result] [indexes indexes] [i 0])
(cond [(null? indexes) null]
[(= (car indexes) i)
(cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))]
[else
(loop (cdr result) indexes (add1 i))])))
(make-keyword-procedure
(lambda (kws kwargs x cx pr es fh cp success . rest)
(keyword-apply parser kws kwargs x cx pr es fh cp
(if splicing?
(lambda (fh cp x cx . result)
(apply success fh cp x cx (take-indexes result indexes)))
(lambda (fh cp . result)
(apply success fh cp (take-indexes result indexes))))
rest))))))
(define (wrong-depth who a b)
(error who
"reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead"
(car a) (cadr a) (cadr b)))

131
collects/syntax/parse/private/runtime-report.rkt Normal file
View File

@ -0,0 +1,131 @@
#lang racket/base
(require racket/contract/base
racket/list
"minimatch.rkt"
racket/stxparam
syntax/stx
(for-syntax racket/base
syntax/stx
racket/private/sc
"rep-data.rkt")
"runtime.rkt"
"kws.rkt")
(provide syntax-patterns-fail
current-failure-handler)
(define ((syntax-patterns-fail stx0) fs)
(call-with-values (lambda () ((current-failure-handler) stx0 fs))
(lambda vals
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e"
(case (length vals)
((1) (car vals))
(else (cons 'values vals)))))))
(define (default-failure-handler stx0 fs)
(report-failureset stx0 fs))
(define current-failure-handler
(make-parameter default-failure-handler))
;; ----
#|
Reporting
---------
First, failures with maximal (normalized) progresses are selected and
grouped into equivalence classes. In principle, each failure in an
equivalence class complains about the same term, but in practice,
special handling of failures like "unexpected term" make things more
complicated.
|#
;; report-failureset : stx FailureSet -> escapes
(define (report-failureset stx0 fs)
(let* ([classes (maximal-failures fs)]
[reports (apply append (map report/class classes))])
(raise-syntax-error/reports stx0 reports)))
;; A Report is
;; - (report string stx)
(define-struct report (message stx) #:prefab)
;; report/class : (non-empty-listof Failure) -> (listof Report)
(define (report/class fs)
(let* ([ess (map failure-expectstack fs)]
[ess (map normalize-expectstack ess)]
[ess (remove-duplicates ess)]
[ess (simplify-common-expectstacks ess)])
(map report/expectstack ess)))
;; report/expectstack : ExpectStack -> Report
(define (report/expectstack es)
(let ([top-frame (and (pair? es) (car es))])
(cond [(not top-frame)
(report "bad syntax" #f)]
[else
(let ([frame-expect (and top-frame (car top-frame))]
[frame-stx (and top-frame (cdr top-frame))])
(cond [(equal? frame-expect (expect:atom '()))
(syntax-case frame-stx ()
[(one . more)
(report "unexpected term" #'one)]
[_
(report/expects (list frame-expect) frame-stx)])]
[(expect:disj? frame-expect)
(report/expects (expect:disj-expects frame-expect) frame-stx)]
[else
(report/expects (list frame-expect) frame-stx)]))])))
;; report/expects : (listof Expect) -> Report
(define (report/expects expects frame-stx)
(report (join-sep (for/list ([expect expects])
(prose-for-expect expect))
";" "or")
frame-stx))
;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
(match e
[(expect:thing description transparent?)
(format "expected ~a" description)]
[(expect:atom atom)
(format "expected the literal ~a~s~a"
(if (symbol? atom) "symbol `" "")
atom
(if (symbol? atom) "'" ""))]
[(expect:literal literal)
(format "expected the identifier `~s'" (syntax-e literal))]
[(expect:message message)
(format "~a" message)]))
;; == Do Report ==
(define (raise-syntax-error/reports stx0 reports)
(cond [(= (length reports) 1)
(raise-syntax-error/report stx0 (car reports))]
[else
(raise-syntax-error/report* stx0 (car reports))]))
(define (raise-syntax-error/report stx0 report)
(raise-syntax-error #f (report-message report) stx0 (report-stx report)))
(define (raise-syntax-error/report* stx0 report)
(let ([message
(string-append
"There were multiple syntax errors. The first error follows:\n"
(report-message report))])
(raise-syntax-error #f message stx0 (report-stx report))))
;; ====
(define (comma-list items)
(join-sep items "," "or"))
(define (improper-stx->list stx)
(syntax-case stx ()
[(a . b) (cons #'a (improper-stx->list #'b))]
[() null]
[rest (list #'rest)]))

340
collects/syntax/parse/private/runtime.rkt Normal file
View File

@ -0,0 +1,340 @@
#lang racket/base
(require racket/contract/base
racket/list
racket/stxparam
unstable/struct
"minimatch.rkt"
"runtime-progress.rkt"
"runtime-failure.rkt"
"kws.rkt"
(for-syntax racket/base
racket/list
syntax/stx
syntax/kerncase
racket/private/sc
unstable/syntax
"rep-data.rkt"
"rep-attrs.rkt"))
(provide (all-from-out "runtime-progress.rkt")
(all-from-out "runtime-failure.rkt")
this-syntax
this-context-syntax
stx-list-take
stx-list-drop/cx
let-attributes
attribute
let/unpack
attribute-binding
check-list^depth)
;; == Syntax Parameters
;; this-syntax
;; Bound to syntax being matched inside of syntax class
(define-syntax-parameter this-syntax
(lambda (stx)
(wrong-syntax stx "used out of context: not within a syntax class")))
;; this-context-syntax
;; Bound to (expression that extracts) context syntax (bottom frame in progress)
(define-syntax-parameter this-context-syntax
(lambda (stx)
(wrong-syntax stx "used out of context: not within a syntax class")))
;; == with ==
(provide with)
(define-syntax (with stx)
(syntax-case stx ()
[(with ([stxparam expr] ...) . body)
(with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))])
(syntax/loc stx
(let ([var expr] ...)
(syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var)))
...)
. body))))]))
;; == Control information ==
(provide fail-handler
cut-prompt
wrap-user-code
fail
try)
(define-syntax-parameter fail-handler
(lambda (stx)
(wrong-syntax stx "internal error: used out of context")))
(define-syntax-parameter cut-prompt
(lambda (stx)
(wrong-syntax stx "internal error: used out of context")))
(define-syntax-rule (wrap-user-code e)
(with ([fail-handler #f]
[cut-prompt #t])
e))
(define-syntax-rule (fail fs)
(fail-handler fs))
(define-syntax (try stx)
(syntax-case stx ()
[(try e0 e ...)
(with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
(with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
(with-syntax ([(next-fh ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)]
[(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)])
#'(let* ([fh (lambda (fs1)
(with ([fail-handler
(lambda (fs2)
(next-fh (cons fs1 fs2)))])
re))]
...)
(with ([fail-handler last-fh])
e0)))))]))
;; -----
(require syntax/stx)
(define (stx-list-take stx n)
(let loop ([stx stx] [n n])
(if (zero? n)
null
(cons (stx-car stx)
(loop (stx-cdr stx) (sub1 n))))))
;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
(define (stx-list-drop/cx x cx n)
(let loop ([x x] [cx cx] [n n])
(if (zero? n)
(values x
(if (syntax? x) x cx))
(loop (stx-cdr x)
(if (syntax? x) x cx)
(sub1 n)))))
;; == Attributes
(begin-for-syntax
(define-struct attribute-mapping (var name depth syntax?)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
(if (attribute-mapping-syntax? self)
#`(#%expression #,(attribute-mapping-var self))
#`(let ([value #,(attribute-mapping-var self)])
(if (check-syntax '#,(attribute-mapping-depth self) value)
value
(raise-syntax-error
#f
(format "attribute is bound to non-syntax value: ~e" value)
(quote-syntax #,(attribute-mapping-name self)))))))))
;; check-syntax : nat any -> boolean
;; Returns #t if value is a (listof^depth syntax)
(define (check-syntax depth value)
(if (zero? depth)
(syntax? value)
(and (list? value)
(for/and ([part (in-list value)])
(check-syntax (sub1 depth) part)))))
(define-syntax (let-attributes stx)
(define (parse-attr x)
(syntax-case x ()
[#s(attr name depth syntax?) #'(name depth syntax?)]))
(syntax-case stx ()
[(let-attributes ([a value] ...) . body)
(with-syntax ([((name depth syntax?) ...)
(map parse-attr (syntax->list #'(a ...)))])
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
[(stmp ...) (generate-temporaries #'(name ...))])
#'(letrec-syntaxes+values
([(stmp) (make-attribute-mapping (quote-syntax vtmp)
'name 'depth 'syntax?)] ...)
([(vtmp) value] ...)
(letrec-syntaxes+values
([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
()
. body))))]))
(define-syntax (attribute stx)
(parameterize ((current-syntax-context stx))
(syntax-case stx ()
[(attribute name)
(identifier? #'name)
(let ([mapping (syntax-local-value #'name (lambda () #f))])
(unless (syntax-pattern-variable? mapping)
(wrong-syntax #'name "not bound as a pattern variable"))
(let ([var (syntax-mapping-valvar mapping)])
(let ([attr (syntax-local-value var (lambda () #f))])
(unless (attribute-mapping? attr)
(wrong-syntax #'name "not bound as an attribute"))
(syntax-property (attribute-mapping-var attr)
'disappeared-use
#'name))))])))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])
(let-attributes ([a tmp] ...) body)))]))
;; (attribute-binding id)
;; mostly for debugging/testing
(define-syntax (attribute-binding stx)
(syntax-case stx ()
[(attribute-bound? name)
(identifier? #'name)
(let ([value (syntax-local-value #'name (lambda () #f))])
(if (syntax-pattern-variable? value)
(let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
(if (attribute-mapping? value)
#`(quote #,(make-attr (attribute-mapping-name value)
(attribute-mapping-depth value)
(attribute-mapping-syntax? value)))
#'(quote #f)))
#'(quote #f)))]))
;; (check-list^depth attr expr)
(define-syntax (check-list^depth stx)
(syntax-case stx ()
[(_ a expr)
(with-syntax ([#s(attr name depth syntax?) #'a])
(quasisyntax/loc #'expr
(check-list^depth* 'name 'depth expr)))]))
(define (check-list^depth* aname n0 v0)
(define (loop n v)
(when (positive? n)
(unless (list? v)
(raise-type-error aname (format "lists nested ~s deep" n0) v))
(for ([x (in-list v)]) (loop (sub1 n) x))))
(loop n0 v0)
v0)
;; ====
(provide check-literal
free-identifier=?/phases)
;; check-literal : id phase-level stx -> void
;; FIXME: change to normal 'error', if src gets stripped away
(define (check-literal id phase ctx)
(unless (identifier-binding id phase)
(raise-syntax-error #f
(format "literal is unbound in phase ~s" phase)
ctx id)))
;; free-identifier=?/phases : id phase-level id phase-level -> boolean
;; Determines whether x has the same binding at phase-level phase-x
;; that y has at phase-level y.
;; At least one of the identifiers MUST have a binding (module or lexical)
(define (free-identifier=?/phases x phase-x y phase-y)
(let ([bx (identifier-binding x phase-x)]
[by (identifier-binding y phase-y)])
(cond [(and (list? bx) (list? by))
(let ([modx (module-path-index-resolve (first bx))]
[namex (second bx)]
[phasex (fifth bx)]
[mody (module-path-index-resolve (first by))]
[namey (second by)]
[phasey (fifth by)])
(and (eq? modx mody) ;; resolved-module-paths are interned
(eq? namex namey)
(equal? phasex phasey)))]
[else
;; One must be lexical (can't be #f, since one must be bound)
;; lexically-bound names bound in only one phase; just compare
(free-identifier=? x y)])))
;; ----
(provide begin-for-syntax/once)
;; (begin-for-syntax/once expr/phase1 ...)
;; evaluates in pass 2 of module/intdefs expansion
(define-syntax (begin-for-syntax/once stx)
(syntax-case stx ()
[(bfs/o e ...)
(cond [(list? (syntax-local-context))
#`(define-values ()
(begin (begin-for-syntax/once e ...)
(values)))]
[else
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
(m))])]))
;; ====
(provide no-shadow)
(begin-for-syntax
(define (check-shadow def)
(syntax-case def ()
[(_def (x ...) . _)
(parameterize ((current-syntax-context def))
(for ([x (in-list (syntax->list #'(x ...)))])
(let ([v (syntax-local-value x (lambda _ #f))])
(when (syntax-pattern-variable? v)
(wrong-syntax
x
;; FIXME: customize "~do pattern" vs "#:do block" as appropriate
"definition in ~~do pattern must not shadow attribute binding")))))])))
(define-syntax (no-shadow stx)
(syntax-case stx ()
[(no-shadow e)
(let ([ee (local-expand #'e (syntax-local-context)
(kernel-form-identifier-list))])
(syntax-case ee (begin define-values defines-syntaxes)
[(begin d ...)
#'(begin (no-shadow d) ...)]
[(define-values . _)
(check-shadow ee)
ee]
[(define-syntaxes . _)
(check-shadow ee)
ee]
[_
ee]))]))
;; ----
(provide curried-stxclass-parser
app-argu)
(define-syntax (curried-stxclass-parser stx)
(syntax-case stx ()
[(cp class argu)
(with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu])
(let ([sc (get-stxclass/check-arity #'class #'class
(length (syntax->list #'(parg ...)))
(syntax->datum #'(kw ...)))])
(with-syntax ([parser (stxclass-parser sc)])
#'(lambda (x cx pr es fh cp success)
(app-argu parser x cx pr es fh cp success argu)))))]))
(define-syntax (app-argu stx)
(syntax-case stx ()
[(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...)))
#|
Use keyword-apply directly?
#'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null)
If so, create separate no-keyword clause.
|#
;; For now, let #%app handle it.
(with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)])
#'(proc kw-part ... ... extra-parg ... parg ...))]))

142
collects/syntax/parse/private/sc.rkt Normal file
View File

@ -0,0 +1,142 @@
#lang racket/base
(require (for-syntax racket/base
syntax/stx
unstable/syntax
"rep-data.rkt"
"rep.rkt")
racket/list
syntax/stx
"parse.rkt"
"keywords.rkt"
"runtime.rkt"
"runtime-report.rkt"
"kws.rkt")
(provide define-syntax-class
define-splicing-syntax-class
syntax-parse
syntax-parser
(except-out (all-from-out "keywords.rkt")
~do
~reflect
~splicing-reflect
~eh-var)
attribute
this-syntax
;;----
parser/rhs)
(begin-for-syntax
(define (defstxclass stx name formals rhss splicing?)
(parameterize ((current-syntax-context stx))
(with-syntax ([name name]
[formals formals]
[rhss rhss])
(let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)]
[arity (parse-kw-formals #'formals #:context stx)]
[opt-rhs+def
(and (stx-list? #'formals) (andmap identifier? (syntax->list #'formals))
(optimize-rhs the-rhs (syntax->list #'formals)))]
[the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
(with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))]
[arity arity]
[attrs (rhs-attrs the-rhs)]
[(opt-def ...)
(if opt-rhs+def
(list (cadr opt-rhs+def))
'())]
[options (rhs-options the-rhs)]
[integrate-expr
(syntax-case (rhs-integrate the-rhs) ()
[#s(integrate predicate description)
#'(integrate (quote-syntax predicate)
'description)]
[#f
#''#f])])
#`(begin (define-syntax name
(stxclass 'name 'arity
'attrs
(quote-syntax parser)
'#,splicing?
options
integrate-expr))
opt-def ...
(define-values (parser)
;; If opt-rhs, do not reparse:
;; need to keep same generated predicate name
#,(if opt-rhs+def
(begin
;; (printf "Integrable syntax class: ~s\n" (syntax->datum #'name))
#`(parser/rhs/parsed
name formals attrs #,the-rhs
#,(and (rhs-description the-rhs) #t)
#,splicing? #,stx))
#`(parser/rhs
name formals attrs rhss #,splicing? #,stx))))))))))
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class name . rhss)
(identifier? #'name)
(defstxclass stx #'name #'() #'rhss #f)]
[(define-syntax-class (name . formals) . rhss)
(identifier? #'name)
(defstxclass stx #'name #'formals #'rhss #f)]))
(define-syntax (define-splicing-syntax-class stx)
(syntax-case stx ()
[(define-splicing-syntax-class name . rhss)
(identifier? #'name)
(defstxclass stx #'name #'() #'rhss #t)]
[(define-splicing-syntax-class (name . formals) . rhss)
(identifier? #'name)
(defstxclass stx #'name #'formals #'rhss #t)]))
;; ----
(define-syntax (parser/rhs stx)
(syntax-case stx ()
[(parser/rhs name formals attrs rhss splicing? ctx)
(with-disappeared-uses
(let ([rhs
(parameterize ((current-syntax-context #'ctx))
(parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
#:context #'ctx))])
#`(parser/rhs/parsed name formals attrs
#,rhs #,(and (rhs-description rhs) #t)
splicing? ctx)))]))
(define-syntax (parser/rhs/parsed stx)
(syntax-case stx ()
[(prp name formals attrs rhs rhs-has-description? splicing? ctx)
#`(let ([get-description
(lambda formals
(if 'rhs-has-description?
#,(rhs-description (syntax-e #'rhs))
(symbol->string 'name)))])
(parse:rhs rhs attrs formals splicing?
(if 'rhs-has-description?
#,(rhs-description (syntax-e #'rhs))
(symbol->string 'name))))]))
;; ====
(define-syntax (syntax-parse stx)
(syntax-case stx ()
[(syntax-parse stx-expr . clauses)
(quasisyntax/loc stx
(let ([x (datum->syntax #f stx-expr)])
(parse:clauses x clauses #,((make-syntax-introducer) stx))))]))
(define-syntax (syntax-parser stx)
(syntax-case stx ()
[(syntax-parser . clauses)
(quasisyntax/loc stx
(lambda (x)
(let ([x (datum->syntax #f x)])
(parse:clauses x clauses #,((make-syntax-introducer) stx)))))]))

0
collects/syntax/private/util/txlift.rkt → collects/syntax/parse/private/txlift.rkt
View File

35
collects/syntax/parse/todo.txt Normal file
View File

@ -0,0 +1,35 @@
Things to do for syntax/parse
=============================
TEST & DOC - Generalize stxclass arities.
TEST & DOC - provide-syntax-class/contract
Refine expr/c.
Wrap default args in stxclass parameters with 'this-syntax'
- other stxparams? like 'this-base-syntax' etc?
Add debugging mode that records *all* intermediate patterns
on expectstack.
Add "roles" to error messages, eg
expected identifier for foo thingummy name
instead of the current
expected identifier
Improve ~do.
Improve reflection.
More cowbell.
Reorganize tests.
Allow reflected syntax classes in conventions.
Rename "conventions" to "convention-set"?
For documentation, talk about "primary attributes" vs "nested
attributes". Helps explain ~eh-var and #:auto-nested-attributes.
Fix syntaxes pinpointed for repetition constraint violations.

44
collects/syntax/private/stxparse/codegen-data.rkt
View File

@ -1,44 +0,0 @@
#lang scheme/base
(require syntax/stx
(for-template scheme/base
syntax/stx
scheme/stxparam
unstable/struct
"runtime.ss"))
(provide (all-defined-out))
(define (get-kind kind)
(syntax-case kind ()
[#:pair pairK]
[#:vector vectorK]
[#:box boxK]
[(#:pstruct key)
(make-kind #`(lambda (x)
(let ([xkey (prefab-struct-key x)])
(and xkey (equal? xkey (quote key)))))
(list (lambda (s d)
#`(datum->syntax #,s (struct->list #,d) #,s)))
(list #'dfc-add-unpstruct))]))
;; A Kind is
;; (make-kind id (listof (id id -> stx)) (listof expr))
(define-struct kind (predicate selectors frontier-procs) #:transparent)
(define pairK
(make-kind #'pair?
(list (lambda (s d) #`(car #,d))
(lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
(list #'dfc-add-car
#'dfc-add-cdr)))
(define vectorK
(make-kind #'vector?
(list (lambda (s d)
#`(datum->syntax #,s (vector->list #,d) #,s)))
(list #'dfc-add-unvector)))
(define boxK
(make-kind #'box?
(list (lambda (s d) #`(unbox #,d)))
(list #'dfc-add-unbox)))

144
collects/syntax/private/stxparse/lib.rkt
View File

@ -1,144 +0,0 @@
#lang racket/base
(require "sc.ss"
"../util.ss"
syntax/stx
racket/struct-info
unstable/srcloc
(for-syntax racket/base
"rep.ss"
(only-in "rep-data.ss" make-literalset))
(for-template racket/base
racket/contract/base))
(provide identifier
boolean
str
character
keyword
number
integer
exact-integer
exact-nonnegative-integer
exact-positive-integer
id
nat
char
expr
expr/c
static
atom-in-list
kernel-literals)
(define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes () #:opaque
(pattern x
#:fail-unless (pred (syntax-e #'x)) #f)))
(define-pred-stxclass identifier symbol?)
(define-pred-stxclass boolean boolean?)
(define-pred-stxclass character char?)
(define-pred-stxclass keyword keyword?)
(define-syntax-class str #:attributes () #:opaque
#:description "string"
(pattern x
#:fail-unless (string? (syntax-e #'x)) #f))
(define-pred-stxclass number number?)
(define-pred-stxclass integer integer?)
(define-pred-stxclass exact-integer exact-integer?)
(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?)
(define-pred-stxclass exact-positive-integer exact-positive-integer?)
;; Aliases
(define-syntax id (make-rename-transformer #'identifier))
(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
(define-syntax char (make-rename-transformer #'character))
(define notfound (box 'notfound))
(define-syntax-class (static pred name)
#:attributes (value)
#:description name
(pattern x:id
#:fail-unless (syntax-transforming?)
"not within the extent of a macro transformer"
#:attr value (syntax-local-value #'x (lambda () notfound))
#:fail-when (eq? (attribute value) notfound) #f
#:fail-unless (pred (attribute value)) #f))
(define-syntax-class (atom-in-list atoms name)
#:attributes ()
#:description name
(pattern x
#:fail-unless (memv (syntax-e #'x) atoms) #f))
(define-syntax-class struct-name
#:description "struct name"
#:attributes (descriptor
constructor
predicate
[accessor 1]
super
complete?)
(pattern s
#:declare s (static struct-info? "struct name")
#:with info (extract-struct-info (attribute s.value))
#:with descriptor (list-ref (attribute info) 0)
#:with constructor (list-ref (attribute info) 1)
#:with predicate (list-ref (attribute info) 2)
#:with r-accessors (reverse (list-ref (attribute info) 3))
#:with (accessor ...)
(datum->syntax #f (let ([r-accessors (attribute r-accessors)])
(if (and (pair? r-accessors) (eq? #f (car r-accessors)))
(cdr r-accessors)
r-accessors)))
#:with super (list-ref (attribute info) 5)
#:attr complete? (or (null? (attribute r-accessors))
(and (pair? (attribute r-accessors))
(not (eq? #f (car (attribute r-accessors))))))))
(define-syntax-class expr
#:attributes ()
(pattern x
#:fail-when (keyword? (syntax-e #'x)) #f))
(define-syntax-class (expr/c ctc)
#:attributes (c)
(pattern x:expr
#:with
c #`(contract #,ctc
x
(quote #,(source-location->string #'x "<<unknown>>"))
'<this-macro>
#f
(quote-syntax x))))
;; Literal sets
(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))

709
collects/syntax/private/stxparse/parse.rkt
View File

@ -1,709 +0,0 @@
#lang scheme/base
(require (for-syntax scheme/base
racket/private/sc
syntax/stx
syntax/id-table
syntax/keyword
unstable/syntax
"rep-data.ss"
"rep.ss"
"codegen-data.ss"
"../util/txlift.ss"
"../util.ss")
scheme/stxparam
scheme/list
syntax/stx
"runtime.ss"
"runtime-prose.ss")
(provide (all-defined-out))
(define-for-syntax (wash stx)
(syntax-e stx))
(define-for-syntax (wash-list washer stx)
(let ([l (stx->list stx)])
(unless l (raise-type-error 'wash-list "stx-list" stx))
(map washer l)))
(define-for-syntax (wash-iattr stx)
(with-syntax ([#s(attr name depth syntax?) stx])
(make-attr #'name (wash #'depth) (wash #'syntax?))))
(define-for-syntax (wash-sattr stx)
(with-syntax ([#s(attr name depth syntax?) stx])
(make-attr (wash #'name) (wash #'depth) (wash #'syntax?))))
(define-for-syntax (wash-iattrs stx)
(wash-list wash-iattr stx))
(define-for-syntax (wash-sattrs stx)
(wash-list wash-sattr stx))
;; ----
;; An FCE is expr[DFC]
;; (fail expr #:expect expr #:fce FCE) : expr
(define-syntax (fail stx)
(syntax-case stx ()
[(fail x #:expect p #:fce fce)
#'(enclosing-fail (make-failure x fce p))]))
;; ----
;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
;; : expr[(values ParseFunction DescriptionFunction)]
;; Takes a list of the relevant attrs; order is significant!
;; Returns either fail or a list having length same as 'relsattrs'
(define-syntax (parse:rhs stx)
(syntax-case stx ()
[(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) commit?)
relsattrs (arg ...) get-description splicing?)
(with-syntax ([(k-param ...)
(if (syntax-e #'commit?)
#'()
#'(return))]
[k-ref/fail
(if (syntax-e #'commit?)
#'values
#'return)]
[k-ref/ok
(if (syntax-e #'commit?)
#'values
#'(lambda (result) (return (cons enclosing-fail result))))])
#| #`(with-error-collector
(make-parser
(lambda ___)
(collect-error)))
|#
#'(lambda (x k-param ... arg ...)
(define (fail-rhs failure)
(k-ref/fail
(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? k-ref/ok)))))]))
;; (parse:variants id (SAttr ...) (Variant ...) boolean)
;; : expr[SyntaxClassResult]
(define-syntax (parse:variants stx)
(syntax-case stx ()
[(parse:variants x relsattrs (variant ...) splicing? k-ref)
#'(try (parse:variant x relsattrs variant splicing? k-ref) ...)]))
(define-syntax (parse:variant stx)
(syntax-case stx ()
[(parse:variant x relsattrs variant #f k-ref)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
#`(let ([fc (dfc-empty x)])
def ...
(parse:S x fc pattern (variant-success x relsattrs variant () k-ref))))]
[(parse:variant x relsattrs variant #t k-ref)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
#`(let ([fc (dfc-empty x)])
def ...
(parse:H x fc pattern rest index
(variant-success x relsattrs variant (rest index) k-ref))))]))
;; (variant-success id (SAttr ...) Variant (expr ...)) : expr[SyntaxClassResult]
(define-syntax (variant-success stx)
(syntax-case stx ()
[(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...) k-ref)
#`(convert-sides x sides
(base-success-expr #,(pattern-attrs (wash #'pattern))
relsattrs
(also ...)
k-ref))]))
;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X]
;; where (m (IAttr ...) MArgs) : expr[X]
(define-syntax (convert-sides stx)
(syntax-case stx ()
[(convert-sides x () kexpr)
#'kexpr]
[(convert-sides x (side0 . sides) (k iattrs . kargs))
(syntax-case #'side0 ()
[#s(clause:fail condition message)
#`(let* ([c (without-fails condition)]
[fc (dfc-add-post (dfc-empty x) (if (syntax? c) c x))])
(if c
(fail (if (syntax? c) c x)
#:expect (expectation-of-message message)
#:fce fc)
(convert-sides x sides (k iattrs . kargs))))]
[#s(clause:with pattern expr (def ...))
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
#`(let* ([y (datum->syntax #f (without-fails expr))]
[fc (dfc-add-post (dfc-empty x) y)])
def ...
(parse:S y fc pattern
(convert-sides x sides
(k (p-iattr ... . iattrs) . kargs)))))]
[#s(clause:attr a expr)
#`(let-attributes ([a (without-fails (check-list^depth a expr))])
(convert-sides x sides (k (a . iattrs) . kargs)))])]))
;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult]
(define-syntax (base-success-expr stx)
(syntax-case stx ()
[(base-success-expr iattrs relsattrs (also ...) k-ref)
(let ([reliattrs
(reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
#'(k-ref (list also ... (attribute name) ...))))]))
;; ----
;; (parse:clauses id (Clause ...))
(define-syntax (parse:clauses stx)
(syntax-case stx ()
[(parse:clauses x clauses ctx)
(with-disappeared-uses
(with-txlifts
(lambda ()
(define-values (chunks clauses-stx)
(parse-keyword-options #'clauses parse-directive-table
#:context #'ctx
#:no-duplicates? #t))
(define context
(options-select-value chunks '#:context #:default #'x))
(define-values (decls0 defs)
(get-decls+defs chunks #t #:context #'ctx))
(define (for-clause clause)
(syntax-case clause ()
[[p . rest]
(let-values ([(rest decls2 defs2 sides)
(parse-pattern-directives #'rest
#:allow-declare? #t
#:decls decls0
#:context #'ctx)])
(unless (and (stx-list? rest) (stx-pair? rest))
(raise-syntax-error #f
"expected non-empty clause body"
#'ctx
clause))
(with-syntax ([rest rest]
[pattern
(parse-whole-pattern #'p decls2 #:context #'ctx)]
[(local-def ...) defs2])
#`(let ([fc (dfc-empty x)])
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))
(raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx))
(with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)]
[(alternative ...)
(map for-clause (stx->list clauses-stx))])
#`(let ([fail (syntax-patterns-fail #,context)])
def ...
(with-enclosing-fail* fail
(try alternative ...)))))))]))
;; (clause-success (IAttr ...) expr) : expr
(define-syntax (clause-success stx)
(syntax-case stx ()
[(clause-success _ expr)
#'expr]))
;; ----
;; (parse:S id FCE SinglePattern expr) : expr
(define-syntax (parse:S stx)
(syntax-case stx ()
[(parse:S x fc pattern0 k)
(syntax-case #'pattern0 ()
[#s(internal-rest-pattern rest rest-fc)
#`(let ([rest x]
[rest-fc fc])
k)]
[#s(pat:name attrs pattern (name ...))
#`(let-attributes ([#s(attr name 0 #t) x] ...)
(parse:S x fc pattern k))]
[#s(pat:any attrs)
#'k]
[#s(pat:var _attrs name #f () () _)
#'(let-attributes ([#s(attr name 0 #t) x])
k)]
[#s(pat:var _attrs name parser (arg ...) (nested-a ...) commit?)
(with-syntax* ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) x])
#'())]
[ok-e
#'(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
k))]
[fail-e
#'(fail x #:expect result #:fce fc)])
(if (syntax-e #'commit?)
#'(let ([result (parser x arg ...)])
(if (ok? result)
ok-e
fail-e))
#'(parser x
(lambda (result)
(if (ok? result)
(let ([fail-k (car result)]
[result (cdr result)])
(with-enclosing-fail fail-k
ok-e))
fail-e))
arg ...)))]
[#s(pat:datum attrs datum)
#`(let ([d (syntax->datum x)])
(if (equal? d (quote datum))
k
(fail x
#:expect (expectation pattern0)
#:fce fc)))]
[#s(pat:literal attrs literal input-phase lit-phase)
#`(if (and (identifier? x)
(free-identifier=?/phases x input-phase
(quote-syntax literal) lit-phase))
k
(fail x
#:expect (expectation pattern0)
#:fce fc))]
[#s(pat:ghost attrs ghost subpattern)
#'(parse:G x fc ghost (parse:S x fc subpattern k))]
[#s(pat:head attrs head tail)
#`(parse:H x fc head rest rest-fc
(parse:S rest rest-fc tail k))]
[#s(pat:dots attrs head tail)
#`(parse:dots x fc head tail k)]
[#s(pat:and attrs subpatterns)
(for/fold ([k #'k]) ([subpattern (reverse (syntax->list #'subpatterns))])
#`(parse:S x fc #,subpattern #,k))]
[#s(pat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fail id ...)
(with-enclosing-fail fail
(let-attributes ([a id] ...) k)))])
(try (parse:S x fc subpattern
(disjunct subpattern success (enclosing-fail) (id ...)))
...)))]
[#s(pat:not () subpattern)
#`(let ([fail-to-succeed (lambda (_failure) k)]
[outer-fail enclosing-fail])
(with-enclosing-fail* fail-to-succeed
(parse:S x fc subpattern
(with-enclosing-fail outer-fail
(fail x #:expect (expectation pattern0) #:fce fc)))))]
[#s(pat:compound attrs kind0 (part-pattern ...))
(let ([kind (get-kind (wash #'kind0))])
(with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))])
(with-syntax ([predicate (kind-predicate kind)]
[(part-fc ...) (generate-temporaries #'(part ...))]
[(part-fc-proc ...) (kind-frontier-procs kind)]
[(part-expr ...)
(for/list ([selector (kind-selectors kind)])
(selector #'x #'datum))])
#`(let ([datum (syntax-e x)])
(if (predicate datum)
(let ([part part-expr] ...)
(let ([part-fc (part-fc-proc fc part)] ...)
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k)))
(fail x
#:expect (expectation pattern0)
#:fce fc))))))]
[#s(pat:describe attrs description transparent? pattern)
#`(let ([previous-fail enclosing-fail]
[previous-cut-fail enclosing-cut-fail])
(define (new-fail failure)
(fail x
#:expect (expectation-of-thing description transparent? failure)
#:fce fc))
(with-enclosing-fail* new-fail
(let ([new-fc (dfc-empty x)])
(parse:S x new-fc pattern
(with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail
k))))))])]))
;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr
(define-syntax parse:S*
(syntax-rules ()
[(parse:S* () () () k)
k]
[(parse:S* (part0 . parts) (fc0 . fcs) (pattern0 . patterns) k)
(parse:S part0 fc0 pattern0 (parse:S* parts fcs patterns k))]))
;; (disjunct Pattern id (expr ...) (id ...)) : expr
(define-syntax (disjunct stx)
(syntax-case stx ()
[(disjunct pattern success (pre ...) (id ...))
(with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))])
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success pre ... id ...))))))]))
;; (disjunct (clause:attr ...) id (expr ...) (id ...)) : expr
(define-syntax (disjunct/sides stx)
(syntax-case stx ()
[(disjunct/sides clauses success (pre ...) (id ...))
(with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses])
(with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success pre ... id ...))))))]))
;; (parse:G id FCE SinglePattern expr) : expr
(define-syntax (parse:G stx)
(syntax-case stx ()
[(parse:G x fc pattern0 k)
(syntax-case #'pattern0 ()
[#s(ghost:cut _)
#`(with-enclosing-fail enclosing-cut-fail k)]
[#s(ghost:bind _ clauses)
#`(convert-sides x clauses (clause-success () k))]
[#s(ghost:fail _ early? condition message)
#`(let* ([c (without-fails condition)]
[fc* (if (quote early?)
fc
(dfc-add-post fc (if (syntax? c) c x)))])
(if c
(fail (if (syntax? c) c x)
#:expect (expectation pattern0)
#:fce fc*)
k))]
[#s(ghost:parse _ pattern expr)
#`(let* ([y (datum->syntax #f (without-fails expr))]
[fc* (dfc-add-post fc y)])
(parse:S y fc* pattern k))])]))
(begin-for-syntax
;; convert-list-pattern : ListPattern id -> SinglePattern
;; Converts '() datum pattern at end of list to bind (cons stx index)
;; to rest-var.
(define (convert-list-pattern pattern end-pattern)
(syntax-case pattern ()
[#s(pat:datum () ())
end-pattern]
[#s(pat:name attrs pattern names)
(with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)])
#'#s(pat:name attrs pattern names))]
[#s(pat:ghost attrs ghost tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:ghost attrs ghost tail))]
[#s(pat:head attrs head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:head attrs head tail))]
[#s(pat:dots attrs head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:dots attrs head tail))]
[#s(pat:compound attrs #:pair (head-part tail-part))
(with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)])
#'#s(pat:compound attrs #:pair (head-part tail-part)))])))
;; (parse:H id FCE HeadPattern id id expr) : expr
;; x must not alias rest
(define-syntax (parse:H stx)
(syntax-case stx ()
[(parse:H x fc head rest rest-fc k)
(syntax-case #'head ()
[#s(hpat:describe _ description transparent? pattern)
#`(let ([previous-fail enclosing-fail]
[previous-cut-fail enclosing-cut-fail])
(define (new-fail failure)
(fail x
#:expect (expectation-of-thing description transparent? failure)
#:fce fc))
(let ([fc* (dfc-empty x)])
(with-enclosing-fail* new-fail
(parse:H x fc* pattern rest rest-fc
(with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail
k))))))]
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...) commit?)
(with-syntax* ([(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x (dfc->index local-fc))])
#'())]
[ok-e
#'(let* ([rest (car result)]
[local-fc (cadr result)]
[rest-fc (dfc-append fc local-fc)])
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) (cddr result))
k)))]
[fail-e
#'(fail x #:expect result #:fce fc)])
(if (syntax-e #'commit?)
#'(let ([result (parser x arg ...)])
(if (ok? result)
ok-e
fail-e))
#'(parser x
(lambda (result)
(if (ok? result)
(let ([fail-k (car result)]
[result (cdr result)])
(with-enclosing-fail fail-k
ok-e))
fail-e))
arg ...)))]
[#s(hpat:and (a ...) head single)
#`(parse:H x fc head rest rest-fc
(let ([lst (stx-list-take x (dfc-difference fc rest-fc))])
(parse:S lst fc single k)))]
[#s(hpat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (rest rest-fc fail id ...)
(with-enclosing-fail fail
(let-attributes ([a id] ...) k)))])
(try (parse:H x fc subpattern rest rest-fc
(disjunct subpattern success
(rest rest-fc enclosing-fail) (id ...)))
...)))]
[#s(hpat:seq attrs pattern)
(with-syntax ([pattern
(convert-list-pattern
#'pattern
#'#s(internal-rest-pattern rest rest-fc))])
#'(parse:S x fc pattern k))]
[#s(hpat:optional (a ...) pattern defaults)
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (rest rest-fc fail id ...)
(with-enclosing-fail fail
(let-attributes ([a id] ...) k)))])
(try (parse:H x fc pattern rest rest-fc
(success rest rest-fc enclosing-fail (attribute id) ...))
(let ([rest x]
[rest-fc fc])
(convert-sides x defaults
(clause-success ()
(disjunct/sides defaults success
(rest rest-fc enclosing-fail)
(id ...))))))))]
[_
(with-syntax ([attrs (pattern-attrs (wash #'head))])
#'(parse:S x fc
#s(pat:compound attrs
#:pair
(head #s(internal-rest-pattern rest rest-fc)))
k))])]))
;; (parse:dots id FCE EHPattern SinglePattern expr) : expr
(define-syntax (parse:dots stx)
(syntax-case stx ()
[(parse:dots x fc (#s(ehpat head-attrs head head-repc) ...) tail k)
(let ()
(define repcs (wash-list wash #'(head-repc ...)))
(define rep-ids (for/list ([repc repcs])
(and repc (generate-temporary 'rep))))
(define rel-repcs (filter values repcs))
(define rel-rep-ids (filter values rep-ids))
(define aattrs
(for/list ([head-attrs (syntax->list #'(head-attrs ...))]
[repc repcs]
#:when #t
[a (wash-iattrs head-attrs)])
(cons a repc)))
(define attrs (map car aattrs))
(define attr-repcs (map cdr aattrs))
(define ids (map attr-name attrs))
(with-syntax ([(id ...) ids]
[(alt-id ...) (generate-temporaries ids)]
[reps rel-rep-ids]
[(head-rep ...) rep-ids]
[(rel-rep ...) rel-rep-ids]
[(rel-repc ...) rel-repcs]
[(a ...) attrs]
[(attr-repc ...) attr-repcs])
(define-pattern-variable alt-map #'((id . alt-id) ...))
(define-pattern-variable loop-k
#'(dots-loop dx* loop-fc* enclosing-fail rel-rep ... alt-id ...))
#`(let ()
(define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...)
(with-enclosing-fail loop-fail
(try (parse:EH dx loop-fc head head-repc dx* loop-fc* alt-map head-rep
loop-k)
...
(cond [(< rel-rep (rep:min-number rel-repc))
(fail dx
#:expect (expectation-of-reps/too-few rel-rep rel-repc)
#:fce (dfc-add-pre loop-fc #f))]
...
[else
(let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
(parse:S dx loop-fc tail k))]))))
(let ([rel-rep 0] ...
[alt-id (rep:initial-value attr-repc)] ...)
(dots-loop x fc enclosing-fail rel-rep ... alt-id ...)))))]))
;; (parse:EH id FCE EHPattern id id ((id . id) ...)
;; RepConstraint/#f expr) : expr
(define-syntax (parse:EH stx)
(syntax-case stx ()
[(parse:EH x fc head repc x* fc* alts rep k0)
(let ()
(define-pattern-variable k
(let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))]
[ids (map attr-name main-attrs)]
[alt-ids
(let ([table (make-bound-id-table)])
(for ([entry (syntax->list #'alts)])
(let ([entry (syntax-e entry)])
(bound-id-table-set! table (car entry) (cdr entry))))
(for/list ([id ids]) (bound-id-table-ref table id)))])
(with-syntax ([(id ...) ids]
[(alt-id ...) alt-ids]
[(alt-a ...) (map rename-attr main-attrs alt-ids)])
#`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
k0))))
(syntax-case #'repc ()
[#f #`(parse:H x fc head x* fc* k)]
[_ #`(parse:H x fc head x* fc*
(if (< rep (rep:max-number repc))
(let ([rep (add1 rep)]) k)
(fail x*
#:expect (expectation-of-reps/too-many rep repc)
#:fce fc*)))]))]))
;; (rep:initial-value RepConstraint) : expr
(define-syntax (rep:initial-value stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'#f]
[(_ #s(rep:optional _ _ _)) #'#f]
[(_ _) #'null]))
;; (rep:finalize RepConstraint expr) : expr
(define-syntax (rep:finalize stx)
(syntax-case stx ()
[(_ a #s(rep:optional _ _ defaults) v)
(with-syntax ([#s(attr name _ _) #'a]
[(#s(clause:attr da de) ...) #'defaults])
(let ([default
(for/or ([da (syntax->list #'(da ...))]
[de (syntax->list #'(de ...))])
(with-syntax ([#s(attr dname _ _) da])
(and (bound-identifier=? #'name #'dname) de)))])
(if default
#`(or v #,default)
#'v)))]
[(_ a #s(rep:once _ _ _) v) #'v]
[(_ a _ v) #'(reverse v)]))
;; (rep:min-number RepConstraint) : expr
(define-syntax (rep:min-number stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'1]
[(_ #s(rep:optional _ _ _)) #'0]
[(_ #s(rep:bounds min max _ _ _)) #'min]))
;; (rep:max-number RepConstraint) : expr
(define-syntax (rep:max-number stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'1]
[(_ #s(rep:optional _ _ _)) #'1]
[(_ #s(rep:bounds min max _ _ _)) #'max]))
;; (rep:combine RepConstraint expr expr) : expr
(define-syntax (rep:combine stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _) a b) #'a]
[(_ #s(rep:optional _ _ _) a b) #'a]
[(_ _ a b) #'(cons a b)]))
;; ----
;; (expectation Pattern)
(define-syntax (expectation stx)
(syntax-case stx ()
[(_ #s(pat:datum attrs d))
#'(begin (collect-error '(datum d))
(make-expect:atom 'd))]
[(_ #s(pat:literal attrs lit input-phase lit-phase))
#'(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 ...)))
#'(collect-error 'ineffable)]
[(_ #s(pat:not _ pattern))
#'(collect-error 'ineffable)]
[(_ #s(ghost:fail _ _e condition message))
#'(expectation-of-message message)]))
;; ----
(define-syntax-rule (expectation-of-thing description transparent? chained)
(make-expect:thing description transparent? chained))
(define-syntax-rule (expectation-of-message message)
(let ([msg (collect-error message)])
(if msg
(make-expect:message msg)
'ineffable)))
(define-syntax expectation-of-reps/too-few
(syntax-rules ()
[(_ rep #s(rep:once name too-few-msg too-many-msg))
(expectation-of-message/too-few too-few-msg name)]
[(_ rep #s(rep:optional name too-many-msg _))
(error 'impossible)]
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
(expectation-of-message/too-few too-few-msg name)]))
(define-syntax expectation-of-reps/too-many
(syntax-rules ()
[(_ rep #s(rep:once name too-few-msg too-many-msg))
(expectation-of-message/too-many too-many-msg name)]
[(_ rep #s(rep:optional name too-many-msg _))
(expectation-of-message/too-many too-many-msg name)]
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
(expectation-of-message/too-many too-many-msg name)]))
(define-syntax expectation-of-message/too-few
(syntax-rules ()
[(emtf #f #f)
(expectation-of-message "repetition constraint violated")]
[(emtf #f name)
(expectation-of-message
(format "missing required occurrence of ~a" name))]
[(emtf msg _)
(expectation-of-message msg)]))
(define-syntax expectation-of-message/too-many
(syntax-rules ()
[(emtm #f #f)
(expectation-of-message
(format "repetition constraint violated"))]
[(emtm #f name)
(expectation-of-message
(format "too many occurrences of ~a" name))]
[(emtm msg _)
(expectation-of-message 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))))

280
collects/syntax/private/stxparse/rep-patterns.rkt
View File

@ -1,280 +0,0 @@
#lang scheme/base
(require "rep-attrs.ss"
unstable/struct
(for-syntax scheme/base
syntax/stx
unstable/syntax))
(provide (all-defined-out))
#|
A Base is (listof IAttr)
If P = (make-pattern Attrs ...) and A is in Attrs,
the depth of A is with respect to P,
not with respect to the entire enclosing pattern.
|#
#|
A SinglePattern is one of
(make-pat:any Base)
(make-pat:var Base id id (listof stx) (listof IAttr) bool)
(make-pat:literal Base identifier ct-phase ct-phase)
(make-pat:datum Base datum)
(make-pat:ghost Base GhostPattern SinglePattern)
(make-pat:head Base HeadPattern SinglePattern)
(make-pat:dots Base (listof EllipsisHeadPattern) SinglePattern)
(make-pat:and Base (listof SinglePattern))
(make-pat:or Base (listof SinglePattern))
(make-pat:not Base SinglePattern)
(make-pat:compound Base Kind (listof SinglePattern))
(make-pat:describe Base stx boolean SinglePattern)
A ListPattern is a subtype of SinglePattern; one of
(make-pat:datum Base '())
(make-pat:ghost Base GhostPattern ListPattern)
(make-pat:head Base HeadPattern ListPattern)
(make-pat:compound Base '#:pair (list SinglePattern ListPattern))
(make-pat:dots Base EllipsisHeadPattern SinglePattern)
|#
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab)
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:ghost (attrs ghost inner) #:prefab)
(define-struct pat:head (attrs head tail) #:prefab)
(define-struct pat:dots (attrs heads tail) #:prefab)
(define-struct pat:and (attrs patterns) #:prefab)
(define-struct pat:or (attrs patterns) #:prefab)
(define-struct pat:not (attrs pattern) #:prefab)
(define-struct pat:compound (attrs kind patterns) #:prefab)
(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
#|
A GhostPattern is one of
(make-ghost:cut Base)
(make-ghost:fail Base bool stx stx)
(make-ghost:bind Base (listof clause:attr))
* (make-ghost:and Base (listof GhostPattern))
(make-ghost:parse Base SinglePattern stx)
ghost:and is desugared below in create-* procedures
|#
(define-struct ghost:cut (attrs) #:prefab)
(define-struct ghost:fail (attrs early? when message) #:prefab)
(define-struct ghost:bind (attrs clauses) #:prefab)
(define-struct ghost:and (attrs patterns) #:prefab)
(define-struct ghost:parse (attrs pattern expr) #:prefab)
#|
A HeadPattern is one of
(make-hpat:var Base id id (listof stx) (listof IAttr) bool)
(make-hpat:seq Base ListPattern)
(make-hpat:ghost Base GhostPattern HeadPattern)
(make-hpat:and Base HeadPattern SinglePattern)
(make-hpat:or Base (listof HeadPattern))
(make-hpat:optional Base HeadPattern (listof clause:attr))
(make-hpat:describe Base stx/#f boolean HeadPattern)
|#
(define-struct hpat:var (attrs name parser args nested-attrs commit?) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:ghost (attrs ghost inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab)
(define-struct hpat:optional (attrs inner defaults) #:prefab)
(define-struct hpat:describe (attrs description transparent? pattern) #:prefab)
#|
An EllipsisHeadPattern is
(make-ehpat Base HeadPattern RepConstraint)
A RepConstraint is one of
(make-rep:once stx stx stx)
(make-rep:optional stx stx (listof clause:attr))
(make-rep:bounds nat/#f nat/#f stx stx stx)
#f
|#
(define-struct ehpat (attrs head repc) #:prefab)
(define-struct rep:once (name under-message over-message) #:prefab)
(define-struct rep:optional (name over-message defaults) #:prefab)
(define-struct rep:bounds (min max name under-message over-message) #:prefab)
#|
A Kind is one of
'#:pair
'#:box
'#:vector
(list '#:pstruct prefab-struct-key)
|#
(define (pattern? x)
(or (pat:any? x)
(pat:var? x)
(pat:literal? x)
(pat:datum? x)
(pat:ghost? x)
(pat:head? x)
(pat:dots? x)
(pat:and? x)
(pat:or? x)
(pat:not? x)
(pat:compound? x)
(pat:describe? x)))
(define (ghost-pattern? x)
(or (ghost:cut? x)
(ghost:bind? x)
(ghost:fail? x)
(ghost:and? x)
(ghost:parse? x)))
(define (head-pattern? x)
(or (hpat:var? x)
(hpat:seq? x)
(hpat:ghost? x)
(hpat:and? x)
(hpat:or? x)
(hpat:optional? x)
(hpat:describe? x)))
(define (ellipsis-head-pattern? x)
(ehpat? x))
(define single-pattern? pattern?)
(define (single-or-head-pattern? x)
(or (single-pattern? x)
(head-pattern? x)))
(define pattern-attrs
(let ()
(define-syntax (mk-get-attrs stx)
(syntax-case stx ()
[(_ struct ...)
(with-syntax
([([pred accessor] ...)
(for/list ([s (stx->list #'(struct ...))])
(list (format-id s "~a?" (syntax-e s))
(format-id s "~a-attrs" (syntax-e s))))])
#'(lambda (x)
(cond [(pred x) (accessor x)] ...
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
(mk-get-attrs pat:any pat:var pat:datum pat:literal pat:ghost pat:head
pat:dots pat:and pat:or pat:not pat:compound pat:describe
ghost:cut ghost:bind ghost:fail ghost:and ghost:parse
hpat:var hpat:seq hpat:ghost hpat:and hpat:or hpat:describe
hpat:optional
ehpat)))
;; ----
;; Helpers to handle attribute calculations
;; Too complicated for a few pattern forms; those are handled in rep.ss
(define (create-pat:any)
(make pat:any null))
(define (create-pat:var name parser args nested-attrs commit?)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser args nested-attrs commit?)))
(define (create-pat:datum datum)
(make pat:datum null datum))
(define (create-pat:literal literal input-phase lit-phase)
(make pat:literal null literal input-phase lit-phase))
(define (create-pat:ghost g sp)
(cond [(ghost:and? g)
(for/fold ([sp sp]) ([g (reverse (ghost:and-patterns g))])
(create-pat:ghost g sp))]
[else
(let ([attrs (append-iattrs (map pattern-attrs (list g sp)))])
(make pat:ghost attrs g sp))]))
(define (create-pat:head headp tailp)
(let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))])
(make pat:head attrs headp tailp)))
(define (create-pat:compound kind ps)
(make pat:compound (append-iattrs (map pattern-attrs ps)) kind ps))
(define (create-pat:describe description transparent? p)
(make pat:describe (pattern-attrs p) description transparent? p))
(define (create-pat:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make pat:and attrs patterns)))
(define (create-pat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make pat:or attrs patterns)))
(define (create-pat:not pattern)
(make pat:not null pattern))
(define (create-pat:dots headps tailp)
(let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))])
(make pat:dots attrs headps tailp)))
;; ----
(define (create-ghost:cut)
(make ghost:cut null))
(define (create-ghost:fail early? condition message)
(make ghost:fail null early? condition message))
(define (create-ghost:and patterns)
(let ([attrs (append-iattrs (map pattern-attrs patterns))])
(make ghost:and attrs patterns)))
(define (create-ghost:parse pattern expr)
(make ghost:parse (pattern-attrs pattern) pattern expr))
;; ----
(define (create-hpat:var name parser args nested-attrs commit?)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser args nested-attrs commit?)))
(define (create-hpat:seq lp)
(make hpat:seq (pattern-attrs lp) lp))
(define (create-hpat:ghost g hp)
(cond [(ghost:and? g)
(for/fold ([hp hp]) ([g (reverse (ghost:and-patterns g))])
(create-hpat:ghost g hp))]
[else
(let ([attrs (append-iattrs (map pattern-attrs (list g hp)))])
(make hpat:ghost attrs g hp))]))
(define (create-hpat:describe description transparent? p)
(make hpat:describe (pattern-attrs p) description transparent? p))
(define (create-hpat:and hp sp)
(make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp))
(define (create-hpat:or patterns)
(let ([attrs (union-iattrs (map pattern-attrs patterns))])
(make hpat:or attrs patterns)))
;; ----
(define (ghost/head-pattern->list-pattern p)
(cond [(ghost-pattern? p)
(create-pat:ghost p (create-pat:any))]
[(hpat:seq? p)
;; simplification: just extract list pattern from hpat:seq
(hpat:seq-inner p)]
[else
(create-pat:head p (create-pat:datum '()))]))
(define (ghost-pattern->single-pattern gp)
(create-pat:ghost gp (create-pat:any)))

238
collects/syntax/private/stxparse/runtime-prose.rkt
View File

@ -1,238 +0,0 @@
#lang racket/base
(require racket/contract/base
racket/list
"minimatch.ss"
racket/stxparam
syntax/stx
(for-syntax racket/base)
(for-syntax syntax/stx)
(for-syntax racket/private/sc)
(for-syntax "rep-data.ss")
(for-syntax "../util.ss")
"runtime.ss")
(provide syntax-patterns-fail
current-failure-handler
simplify-failure)
;; Failure reporting parameter & default
(define (default-failure-handler stx0 f)
(match (simplify-failure f)
[(make failure x frontier expectation)
(report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
(define current-failure-handler
(make-parameter default-failure-handler))
(define ((syntax-patterns-fail stx0) f)
(call-with-values (lambda () ((current-failure-handler) stx0 f))
(lambda vals
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e"
(case (length vals)
((1) (car vals))
(else (cons 'values vals)))))))
;; report-failure : stx stx number stx Expectation -> (escapes)
(define (report-failure stx0 x index frontier-stx expected)
(define (err msg stx0 stx)
(raise-syntax-error #f msg stx0 stx))
(cond [(expectation-of-null? expected)
;; FIXME: "extra term(s) after <pattern>"
(syntax-case x ()
[(one)
(err "unexpected term" stx0 #'one)]
[(first . more)
;; TODO: report error with all elements (use improper-stx->list)
(err "unexpected terms starting here" stx0 #'first)]
[_
(err "unexpected term" stx0 x)])]
[(and expected (prose-for-expectation expected index x))
=>
(lambda (msg)
(err (format "~a~a"
msg
(cond [(zero? index) ""]
[else (format " after ~s ~a"
index
(if (= 1 index) "term" "terms"))]))
stx0
frontier-stx))]
[else
(err "bad syntax" stx0 stx0)]))
;; simplify-failure : Failure -> SimpleFailure
(define (simplify-failure f)
(simplify* f))
;; simplify* : Failure -> SimpleFailure
(define (simplify* f)
(match f
[(make join-failures f1 f2)
(choose-error (simplify* f1) (simplify* f2))]
[(make failure x frontier expectation)
(match expectation
[(make expect:thing description '#t chained)
(let ([chained* (simplify* chained)])
(match chained*
[(make failure _ chained*-frontier chained*-expectation)
(cond [(ineffable? chained*-expectation)
;; If simplified chained failure is ineffable,
;; keep (& adjust) its frontier
;; and attach enclosing description
(adjust-failure
(make-failure x chained*-frontier
(make-expect:thing description #f #f))
frontier)]
[else
;; Otherwise, "expose" the chained failure and
;; adjust its frontier
(adjust-failure chained* frontier)])]))]
[_ f])]))
;; FIXME: try different selection/simplification algorithms/heuristics
(define (simplify-failure0 f)
(match f
[(make join-failures f1 f2)
(choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
[(make failure x frontier expectation)
(match expectation
[(make expect:thing description '#t chained)
(let ([chained* (simplify-failure0 chained)])
(match chained*
[(make failure _ _ chained*-expectation)
(cond [(ineffable? chained*-expectation)
;; If simplified chained failure is ineffable, ignore it
;; and stick to the one with the description
f]
[else
;; Otherwise, "expose" the chained failure
;; and adjust its frontier
(adjust-failure chained* frontier)])]))]
[_ f])]))
(define (adjust-failure f base-frontier)
(match f
[(make failure x frontier expectation)
(let ([frontier (dfc-append base-frontier frontier)])
(make-failure x frontier expectation))]))
;; choose-error : Failure Failure -> Failure
(define (choose-error f1 f2)
(case (compare-idfcs (invert-dfc (failure-frontier f1))
(invert-dfc (failure-frontier f2)))
[(>) f1]
[(<) f2]
[(=) (merge-failures f1 f2)]))
;; merge-failures : failure failure -> failure
(define (merge-failures f1 f2)
(make-failure (failure-stx f1)
(failure-frontier f1)
(merge-expectations (failure-expectation f1)
(failure-expectation f2))))
;; ----
;; prose-for-expectation : Expectation syntax -> string/#f
(define (prose-for-expectation e index stx)
(cond [(expect? e)
(let ([alts (expect->alternatives e)])
(and alts
(join-sep (for/list ([alt alts])
(for-alternative alt index stx))
";" "or")))]
[(eq? e 'ineffable)
#f]
[else (error 'prose-for-expectation "unexpected: ~e" e)]))
(define (for-alternative e index stx)
(match e
[(make expect:thing description transparent? chained)
(format "expected ~a" description)]
[(make expect:atom atom)
(format "expected the literal ~s" atom)]
[(make expect:literal literal)
(format "expected the literal identifier ~s" (syntax-e literal))]
[(make expect:message message)
(format "~a" message)]
[(make expect:pair)
(cond [(= index 0)
"expected sequence of terms"]
[else
(if (stx-null? stx)
"expected more terms in sequence"
"expected sequence of terms")])]))
(define (comma-list items)
(join-sep items "," "or"))
(define (join-sep items sep0 ult0 [prefix ""])
(define sep (string-append sep0 " "))
(define ult (string-append ult0 " "))
(define (loop items)
(cond [(null? items)
null]
[(null? (cdr items))
(list sep ult (car items))]
[else
(list* sep (car items) (loop (cdr items)))]))
(case (length items)
[(0) #f]
[(1) (string-append prefix (car items))]
[(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
[else (let ([strings (list* (car items) (loop (cdr items)))])
(apply string-append prefix strings))]))
(define (improper-stx->list stx)
(syntax-case stx ()
[(a . b) (cons #'a (improper-stx->list #'b))]
[() null]
[rest (list #'rest)]))
;; Ad-hoc interpretation of error message expressions
(provide interpret-error-expression)
;; Recognize application of 'format' procedure
(define (interpret-error-expression e)
(define vars '(X Y Z))
;; minieval : syntax -> (or syntax datum)
;; Returns syntax on NON-evalable stuff, datum otherwise
(define (minieval x)
(syntax-case x (format quote datum literal)
[(format str arg ...)
(string? (syntax-e #'str))
(let ([args (map minieval (syntax->list #'(arg ...)))])
(define args*
(cond [(<= (length (filter syntax? args)) (length vars))
(for/list ([arg args])
(if (syntax? arg)
(begin0 (car vars) (set! vars (cdr vars)))
arg))]
[else
(let ([counter 1])
(for/list ([arg args])
(if (syntax? arg)
(begin0 (format "Q~a" counter)
(set! counter (add1 counter)))
arg)))]))
(apply format (syntax-e #'str) args*))]
[(quote (datum d))
(format "expected the literal ~a" (syntax->datum #'d))]
[(quote (literal lit))
(format "expected the literal identifier ~s" (syntax-e #'lit))]
[(quote thing)
(syntax->datum #'thing)]
[d
(let ([d (syntax->datum #'d)])
(or (string? d) (number? d) (boolean? d)))
(syntax->datum #'d)]
[_
x]))
(let ([ie (minieval e)])
(if (syntax? ie)
(syntax->datum ie)
ie)))

652
collects/syntax/private/stxparse/runtime.rkt
View File

@ -1,652 +0,0 @@
#lang racket/base
(require racket/contract/base
racket/stxparam
racket/list
unstable/struct
"minimatch.ss"
(for-syntax racket/base
syntax/stx
racket/private/sc
"rep-data.ss"
"rep-attrs.ss"
"../util.ss"))
(provide pattern
~var
~datum
~literal
~and
~or
~not
~seq
~between
~once
~optional
~rest
~describe
~!
~bind
~fail
~early-fail
~parse
...+
current-expression
current-macro-name
this-syntax
expect?
expectation?
(struct-out expect:thing)
(struct-out expect:atom)
(struct-out expect:literal)
(struct-out expect:message)
(struct-out expect:pair)
(struct-out expect:disj)
merge-expectations
expect->alternatives
ineffable?
expectation-of-null?
enclosing-fail
enclosing-cut-fail
with-enclosing-fail
with-enclosing-cut-fail
with-enclosing-fail*
without-fails
ok?
(struct-out failure)
(struct-out join-failures)
try
stx-list-take
let-attributes
attribute
let/unpack
attribute-binding
check-list^depth)
;; == Keywords
(define-syntax-rule (define-keyword name)
(define-syntax name
(lambda (stx)
(raise-syntax-error #f "keyword used out of context" stx))))
(define-keyword pattern)
(define-keyword ~var)
(define-keyword ~datum)
(define-keyword ~literal)
(define-keyword ~and)
(define-keyword ~or)
(define-keyword ~not)
(define-keyword ~seq)
(define-keyword ~between)
(define-keyword ~once)
(define-keyword ~optional)
(define-keyword ~rest)
(define-keyword ~describe)
(define-keyword ~!)
(define-keyword ~bind)
(define-keyword ~fail)
(define-keyword ~early-fail)
(define-keyword ~parse)
(define-keyword ...+)
;; == Parameters & Syntax Parameters
;; this-syntax
;; Bound to syntax being matched inside of syntax class
(define-syntax-parameter this-syntax
(lambda (stx)
(wrong-syntax stx "used out of context: not within a syntax class")))
(define current-expression (make-parameter #f))
(define (current-macro-name)
(let ([expr (current-expression)])
(and expr
(syntax-case expr (set!)
[(set! kw . _)
#'kw]
[(kw . _)
(identifier? #'kw)
#'kw]
[kw
(identifier? #'kw)
#'kw]
[_ #f]))))
;; == Dynamic Frontier Contexts (DFCs)
(provide (struct-out dfc:empty)
(struct-out dfc:car)
(struct-out dfc:cdr)
(struct-out dfc:pre)
(struct-out dfc:post)
dfc-empty
dfc-add-car
dfc-add-cdr
dfc-add-pre
dfc-add-post
dfc-add-unbox
dfc-add-unvector
dfc-add-unpstruct
dfc->index
dfc->stx
dfc-difference
dfc-append
invert-dfc
compare-idfcs
idfc>?
idfc=?)
#|
A Dynamic Frontier Context (DFC) is one of
- (make-dfc:empty stx)
- (make-dfc:car DFC stx)
- (make-dfc:cdr DFC positive-integer)
- (make-dfc:pre DFC stx)
- (make-dfc:post DFC stx)
|#
(define-struct dfc:empty (stx) #:prefab)
(define-struct dfc:car (parent stx) #:prefab)
(define-struct dfc:cdr (parent n) #:prefab)
(define-struct dfc:pre (parent stx) #:prefab)
(define-struct dfc:post (parent stx) #:prefab)
(define (dfc-empty x) (make dfc:empty x))
(define (dfc-add-car parent stx)
(make dfc:car parent stx))
(define (dfc-add-cdr parent _)
(match parent
[(make dfc:cdr uberparent n)
(make dfc:cdr uberparent (add1 n))]
[_ (make dfc:cdr parent 1)]))
(define (dfc-add-pre parent stx)
(make dfc:pre parent stx))
(define (dfc-add-post parent stx)
(make dfc:post parent stx))
(define (dfc-add-unbox parent stx)
(dfc-add-car parent stx))
(define (dfc-add-unvector parent stx)
(dfc-add-car parent stx))
(define (dfc-add-unpstruct parent stx)
(dfc-add-car parent stx))
(define (dfc->index dfc)
(match dfc
[(make dfc:cdr parent n) n]
[_ 0]))
(define (dfc->stx dfc)
(match dfc
[(make dfc:empty stx) stx]
[(make dfc:car parent stx) stx]
[(make dfc:cdr parent n) (dfc->stx parent)]
[(make dfc:pre parent stx) stx]
[(make dfc:post parent stx) stx]))
;; dfc-difference : DFC DFC -> nat
;; Returns N s.t. B = (dfc-add-cdr^N A)
(define (dfc-difference a b)
(define (whoops)
(error 'dfc-difference "~e is not an extension of ~e"
(frontier->sexpr b) (frontier->sexpr a)))
(match (list a b)
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
(unless (equal? pa pb) (whoops))
(- nb na)]
[(list pa (make dfc:cdr pb nb))
(unless (equal? pa pb) (whoops))
nb]
[_
(unless (equal? a b) (whoops))
0]))
;; dfc-append : DFC DFC -> DFC
;; puts A at the base, B on top
(define (dfc-append a b)
(match b
[(make dfc:empty stx) a]
[(make dfc:car pb stx) (make dfc:car (dfc-append a pb) stx)]
[(make dfc:cdr (make dfc:empty _) nb)
;; Special case to merge "consecutive" cdr frames
(match a
[(make dfc:cdr pa na) (make dfc:cdr pa (+ na nb))]
[_ (make dfc:cdr a nb)])]
[(make dfc:cdr pb nb) (make dfc:cdr (dfc-append a pb) nb)]
[(make dfc:pre pb stx) (make dfc:pre (dfc-append a pb) stx)]
[(make dfc:post pb stx) (make dfc:post (dfc-append a pb) stx)]))
;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison.
(define (invert-dfc dfc)
(define (invert dfc acc)
(match dfc
[(make dfc:empty _) acc]
[(make dfc:car parent stx)
(invert parent (make dfc:car acc stx))]
[(make dfc:cdr parent n)
(invert parent (make dfc:cdr acc n))]
[(make dfc:pre parent stx)
(invert parent (make dfc:pre acc stx))]
[(make dfc:post parent stx)
(invert parent (make dfc:post acc stx))]))
(invert dfc (dfc-empty 'dummy)))
;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>)
;; Note A>B means A is "further along" than B.
;; Lexicographic generalization of PRE < CAR < CDR < POST
(define (compare-idfcs a b)
(match (list a b)
;; Same constructors
[(list (make dfc:empty _) (make dfc:empty _)) '=]
[(list (make dfc:car pa _) (make dfc:car pb _))
(compare-idfcs pa pb)]
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
(cond [(< na nb) (compare-idfcs pa (make dfc:cdr pb (- nb na)))]
[(> na nb) (compare-idfcs (make-dfc:cdr pa (- na nb)) pb)]
[(= na nb) (compare-idfcs pa pb)])]
[(list (make dfc:pre pa _) (make dfc:pre pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
(compare-idfcs pa pb)]
[(list (make dfc:post pa _) (make dfc:post pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
(compare-idfcs pa pb)]
;; Different constructors
[(list (make dfc:empty _) _) '<]
[(list _ (make dfc:empty _)) '>]
[(list (make dfc:pre _ _) _) '<]
[(list _ (make dfc:pre _ _)) '>]
[(list (make dfc:car _ _) _) '<]
[(list _ (make dfc:car _ _)) '>]
[(list (make dfc:cdr _ _) _) '<]
[(list _ (make dfc:cdr _ _)) '>]))
(define (idfc>? a b)
(eq? (compare-idfcs a b) '>))
(define (idfc=? a b)
(eq? (compare-idfcs a b) '=))
;; == Codegen internal syntax parameters
(define-for-syntax not-allowed/not-parsing
(lambda (stx)
(wrong-syntax stx "used out of context: not parsing pattern")))
(define-syntax-parameter pattern-source not-allowed/not-parsing)
;; Two levels of fail continuation:
;; - enclosing-fail : ordinary fail
;; - enclosing-cut-fail : last cut "prompt"
(define-syntax-parameter enclosing-fail not-allowed/not-parsing)
(define-syntax-parameter enclosing-cut-fail not-allowed/not-parsing)
(define-syntax-rule (with-enclosing-fail failvar expr)
(syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar))))
expr))
(define-syntax-rule (with-enclosing-cut-fail failvar expr)
(syntax-parameterize ((enclosing-cut-fail (make-rename-transformer (quote-syntax failvar))))
expr))
(define-syntax-rule (with-enclosing-fail* failvar expr)
(syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar)))
(enclosing-cut-fail (make-rename-transformer (quote-syntax failvar))))
expr))
(define-syntax-rule (without-fails body)
(syntax-parameterize ((enclosing-fail not-allowed/not-parsing)
(enclosing-cut-fail not-allowed/not-parsing))
body))
;; == Success and Failure
;; A Failure is one of
;; (make-failure stx DFC expectation/c)
;; (make-join-failures Failure Failure)
(define ok? list?)
(define-struct failure (stx frontier expectation) #:prefab)
(define-struct join-failures (f1 f2) #:prefab)
;; (try expr ...)
(define-syntax (try stx)
(syntax-case stx ()
[(try expr ...)
(when (stx-null? #'(expr ...))
(raise-syntax-error #f "must have at least one attempt" stx))
#'(try* (list (lambda (fail)
(with-enclosing-fail fail expr))
...)
enclosing-fail)]))
;; FailFunction = (Failure -> Result)
;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result
(define (try* attempts fail)
(let ([first-attempt (car attempts)]
[rest-attempts (cdr attempts)])
(if (null? rest-attempts)
(first-attempt fail)
(let ([next-fail
(lambda (f1)
(let ([combining-fail
(lambda (f2)
(fail (make join-failures f1 f2)))])
(try* rest-attempts combining-fail)))])
(first-attempt next-fail)))))
;; == Expectations
;; FIXME: add phase to expect:literal
#|
An Expectation is one of
'ineffable
(make-expect:thing string boolean Failure/#f)
(make-expect:atom atom)
(make-expect:literal identifier)
(make-expect:message string)
(make-expect:pair)
(make-expect:disj Expectation Expectation)
|#
(define-struct expect:thing (description transparent? chained) #:prefab)
(define-struct expect:atom (atom) #:prefab)
(define-struct expect:literal (literal) #:prefab)
(define-struct expect:message (message) #:prefab)
(define-struct expect:pair () #:prefab)
(define-struct expect:disj (a b) #:prefab)
(define (expect? x)
(or (expect:thing? x)
(expect:atom? x)
(expect:literal? x)
(expect:message? x)
(expect:pair? x)
(expect:disj? x)))
(define expectation?
(or/c expect? (symbols 'ineffable)))
(define (merge-expectations a b)
(make expect:disj a b))
;; expect->alternatives : Expectation -> (listof Expectation)/#f
;; #f indicates 'ineffable somewhere in expectation
(define (expect->alternatives e)
(define (loop-onto e rest)
(cond [(expect:disj? e)
(loop-onto (expect:disj-a e)
(loop-onto (expect:disj-b e) rest))]
[else (cons e rest)]))
(let ([alts (remove-duplicates (loop-onto e null))])
(if (for/or ([alt alts]) (eq? alt 'ineffable))
#f
alts)))
(define (expectation-of-null? e)
(or (equal? e '#s(expect:atom ()))
(and (expect:disj? e)
(expectation-of-null? (expect:disj-a e))
(expectation-of-null? (expect:disj-b e)))))
(define (ineffable? e)
(or (eq? e 'ineffable)
(and (expect:disj? e)
(or (ineffable? (expect:disj-a e))
(ineffable? (expect:disj-b e))))))
;; -----
(require syntax/stx)
(define (stx-list-take stx n)
(datum->syntax stx
(let loop ([stx stx] [n n])
(if (zero? n)
null
(cons (stx-car stx)
(loop (stx-cdr stx) (sub1 n)))))
stx))
;; == Attributes
(begin-for-syntax
(define-struct attribute-mapping (var name depth syntax?)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
(if (attribute-mapping-syntax? self)
#`(#%expression #,(attribute-mapping-var self))
#`(let ([value #,(attribute-mapping-var self)])
(if (check-syntax '#,(attribute-mapping-depth self) value)
value
(raise-syntax-error
#f
(format "attribute is bound to non-syntax value: ~e" value)
(quote-syntax #,(attribute-mapping-name self)))))))))
;; check-syntax : nat any -> boolean
;; Returns #t if value is a (listof^depth syntax)
(define (check-syntax depth value)
(if (zero? depth)
(syntax? value)
(and (list? value)
(for/and ([part value])
(check-syntax (sub1 depth) part)))))
(define-syntax (let-attributes stx)
(define (parse-attr x)
(syntax-case x ()
[#s(attr name depth syntax?) #'(name depth syntax?)]))
(syntax-case stx ()
[(let-attributes ([a value] ...) . body)
(with-syntax ([((name depth syntax?) ...)
(map parse-attr (syntax->list #'(a ...)))])
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
[(stmp ...) (generate-temporaries #'(name ...))])
#'(letrec-syntaxes+values
([(stmp) (make-attribute-mapping (quote-syntax vtmp) 'name 'depth 'syntax?)] ...)
([(vtmp) value] ...)
(letrec-syntaxes+values
([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
()
. body))))]))
(define-syntax (attribute stx)
(parameterize ((current-syntax-context stx))
(syntax-case stx ()
[(attribute name)
(identifier? #'name)
(let ([mapping (syntax-local-value #'name (lambda () #f))])
(unless (syntax-pattern-variable? mapping)
(wrong-syntax #'name "not bound as a pattern variable"))
(let ([var (syntax-mapping-valvar mapping)])
(let ([attr (syntax-local-value var (lambda () #f))])
(unless (attribute-mapping? attr)
(wrong-syntax #'name "not bound as an attribute"))
(syntax-property (attribute-mapping-var attr)
'disappeared-use
#'name))))])))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])
(let-attributes ([a tmp] ...) body)))]))
;; (attribute-binding id)
;; mostly for debugging/testing
(define-syntax (attribute-binding stx)
(syntax-case stx ()
[(attribute-bound? name)
(identifier? #'name)
(let ([value (syntax-local-value #'name (lambda () #f))])
(if (syntax-pattern-variable? value)
(let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
(if (attribute-mapping? value)
#`(quote #,(make-attr (attribute-mapping-name value)
(attribute-mapping-depth value)
(attribute-mapping-syntax? value)))
#'(quote #f)))
#'(quote #f)))]))
;; (check-list^depth attr expr)
(define-syntax (check-list^depth stx)
(syntax-case stx ()
[(_ a expr)
(with-syntax ([#s(attr name depth syntax?) #'a])
(quasisyntax/loc #'expr
(check-list^depth* 'name 'depth expr)))]))
(define (check-list^depth* aname n0 v0)
(define (loop n v)
(when (positive? n)
(unless (list? v)
(raise-type-error aname (format "lists nested ~s deep" n0) v))
(for ([x v]) (loop (sub1 n) x))))
(loop n0 v0)
v0)
;; ----
;; debugging
(provide failure->sexpr
one-failure->sexpr
frontier->sexpr
expectation->sexpr)
(define (failure->sexpr f)
(define fs
(let loop ([f f])
(match f
[(make join-failures f1 f2)
(append (loop f1) (loop f2))]
[_ (list f)])))
(case (length fs)
((1) (one-failure->sexpr f))
(else `(union ,@(map one-failure->sexpr fs)))))
(define (one-failure->sexpr f)
(match f
[(make failure x frontier expectation)
`(failure ,(frontier->sexpr frontier)
#:term ,(syntax->datum x)
#:expected ,(expectation->sexpr expectation))]))
(define (frontier->sexpr dfc)
(match (invert-dfc dfc)
[(make dfc:empty _) '()]
[(make dfc:car p _) (cons 'car (frontier->sexpr p))]
[(make dfc:cdr p n) (cons n (frontier->sexpr p))]
[(make dfc:pre p _) (cons 'pre (frontier->sexpr p))]
[(make dfc:post p _) (cons 'post (frontier->sexpr p))]))
(define (expectation->sexpr expectation)
(match expectation
[(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))
;;
(provide curried-stxclass-procedures)
(define-syntax (curried-stxclass-procedures stx)
(syntax-case stx ()
[(cp class (arg ...))
(let* ([args (syntax->list #'(arg ...))]
[sc (get-stxclass/check-arg-count #'class (length args))])
(with-syntax ([parser (stxclass-parser-name sc)]
[get-description (stxclass-description sc)]
[(extra ...)
(if (stxclass-commit? sc)
#'()
#'(k))])
#'(values (lambda (x extra ...) (parser x extra ... arg ...))
(lambda () (get-description arg ...)))))]))
;;
(provide check-literal
free-identifier=?/phases)
;; check-literal : id phase-level stx -> void
;; FIXME: change to normal 'error', if src gets stripped away
(define (check-literal id phase ctx)
(unless (identifier-binding id phase)
(raise-syntax-error #f
(format "literal is unbound in phase ~s" phase)
ctx id)))
;; free-identifier=?/phases : id phase-level id phase-level -> boolean
;; Determines whether x has the same binding at phase-level phase-x
;; that y has at phase-level y.
;; At least one of the identifiers MUST have a binding (module or lexical)
(define (free-identifier=?/phases x phase-x y phase-y)
(let ([bx (identifier-binding x phase-x)]
[by (identifier-binding y phase-y)])
(cond [(and (list? bx) (list? by))
(let ([modx (module-path-index-resolve (first bx))]
[namex (second bx)]
[phasex (fifth bx)]
[mody (module-path-index-resolve (first by))]
[namey (second by)]
[phasey (fifth by)])
(and (eq? modx mody) ;; resolved-module-paths are interned
(eq? namex namey)
(equal? phasex phasey)))]
[else
;; One must be lexical (can't be #f, since one must be bound)
;; lexically-bound names bound in only one phase; just compare
(free-identifier=? x y)])))
;; ----
(provide begin-for-syntax/once)
;; (begin-for-syntax/once expr/phase1 ...)
;; evaluates in pass 2 of module/intdefs expansion
(define-syntax (begin-for-syntax/once stx)
(syntax-case stx ()
[(bfs/o e ...)
(cond [(list? (syntax-local-context))
#`(define-values ()
(begin (begin-for-syntax/once e ...)
(values)))]
[else
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
(m))])]))

291
collects/syntax/private/stxparse/sc.rkt
View File

@ -1,291 +0,0 @@
#lang racket/base
(require (for-syntax racket/base
racket/private/sc
unstable/syntax
unstable/struct
"minimatch.ss"
"../util/txlift.ss"
"rep-data.ss"
"rep.ss")
racket/list
syntax/stx
"parse.ss"
"runtime.ss"
"runtime-prose.ss")
(provide define-syntax-class
define-splicing-syntax-class
define-literal-set
define-conventions
syntax-class-parse
syntax-class-attributes
syntax-class-possible-errors
debug-rhs
debug-pattern
debug-parse
syntax-parse
syntax-parser
pattern
~var
~datum
~literal
~and
~or
~not
~seq
~between
~once
~optional
~rest
~describe
~!
~bind
~fail
;; ~early-fail
~parse
...+
attribute
this-syntax)
(begin-for-syntax
(define (defstxclass stx name args rhss splicing?)
(with-syntax ([name name]
[(arg ...) args]
[rhss rhss])
(let ([the-rhs
(parameterize ((current-syntax-context stx))
(parse-rhs #'rhss #f splicing? #:context stx))])
(with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))]
[attrs (rhs-attrs the-rhs)]
[commit? (rhs-commit? the-rhs)])
#`(begin (define-syntax name
(make stxclass 'name '(arg ...)
'attrs
((syntax-local-certifier) (quote-syntax parser))
((syntax-local-certifier) (quote-syntax description))
'#,splicing?
'commit?))
(define-values (parser description)
(functions/rhs name (arg ...) attrs rhss #,splicing? #,stx))))))))
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class name . rhss)
(identifier? #'name)
(defstxclass stx #'name #'() #'rhss #f)]
[(define-syntax-class (name arg ...) . rhss)
(andmap identifier? (syntax->list #'(name arg ...)))
(defstxclass stx #'name #'(arg ...) #'rhss #f)]))
(define-syntax (define-splicing-syntax-class stx)
(syntax-case stx ()
[(define-splicing-syntax-class name . rhss)
(identifier? #'name)
(defstxclass stx #'name #'() #'rhss #t)]
[(define-splicing-syntax-class (name arg ...) . rhss)
(andmap identifier? (syntax->list #'(name arg ...)))
(defstxclass stx #'name #'(arg ...) #'rhss #t)]))
(define-syntax (define-conventions stx)
(syntax-case stx ()
[(define-conventions (name param ...) rule ...)
(let ([params (syntax->list #'(param ...))])
(for ([x (syntax->list #'(name param ...))])
(unless (identifier? x)
(raise-syntax-error #f "expected identifier" stx x)))
(let ()
(define rules (check-conventions-rules #'(rule ...) stx))
(define rxs (map car rules))
(define dens0 (map cadr rules))
(define den+defs-list
(for/list ([den0 dens0])
(let-values ([(den defs) (create-aux-def den0)])
(cons den defs))))
(define dens (map car den+defs-list))
(define defs (apply append (map cdr den+defs-list)))
(define/with-syntax (rx ...) rxs)
(define/with-syntax (def ...) defs)
(define/with-syntax (parser ...)
(map den:delayed-parser dens))
(define/with-syntax (description ...)
(map den:delayed-description dens))
(define/with-syntax (class-name ...)
(map den:delayed-class dens))
#'(begin
(define-syntax name
(make-conventions
(quote-syntax get-procedures)
(lambda ()
(let ([class-names (list (quote-syntax class-name) ...)])
(map list
(list 'rx ...)
(map make-den:delayed
(generate-temporaries class-names)
(generate-temporaries class-names)
class-names))))))
(define get-procedures
(lambda (param ...)
def ...
(values (list parser ...)
(list description ...)))))))]
[(define-conventions name rule ...)
(identifier? #'name)
#'(define-conventions (name) rule ...)]))
(define-syntax (define-literal-set stx)
(syntax-case stx ()
[(define-literal-set name (lit ...))
(let ([phase-of-definition (syntax-local-phase-level)])
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(let ([lits (check-literals-list/litset #'(lit ...) stx)])
(with-syntax ([((internal external) ...) lits])
#`(begin
(define phase-of-literals
(phase-of-enclosing-module))
(define-syntax name
(make-literalset
(list (list 'internal (quote-syntax external)) ...)
(quote-syntax phase-of-literals)))
(begin-for-syntax/once
(for ([x (syntax->list #'(external ...))])
(unless (identifier-binding x 0)
(raise-syntax-error #f "literal is unbound in phase 0"
(quote-syntax #,stx) x))))))))]))
(define-syntax (phase-of-enclosing-module stx)
(syntax-case stx ()
[(poem)
(let ([phase-within-module (syntax-local-phase-level)])
#`(let ([phase-of-this-expression
(variable-reference->phase (#%variable-reference))])
(- phase-of-this-expression
#,(if (zero? phase-within-module) 0 1))))]))
#|
Literal sets: The goal is for literals to refer to their bindings at
phase 0 relative to the enclosing module
Use cases, explained:
1) module X with def-lit-set is required-for-syntax
phase-of-mod-inst = 1
phase-of-def = 0
literals looked up at abs phase 1
which is phase 0 rel to module X
2) module X with local def-lit-set within define-syntax
phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax)
phase-of-def = 1
literals looked up at abs phase 0
which is phase 0 rel to module X
3) module X with def-lit-set in phase-2 position (really uncommon case!)
phase-of-mod-inst = 1 (not 2, apparently)
phase-of-def = 2
literals looked up at abs phase 0
(that's why the weird (if (z?) 0 1) term)
|#
;; ----
(define-syntax (functions/rhs stx)
(syntax-case stx ()
[(functions/S-rhs name args attrs rhss splicing? ctx)
(with-disappeared-uses
(let ([rhs
(parameterize ((current-syntax-context #'ctx))
(parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
#:context #'ctx))])
#`(let ([get-description
(lambda args
#,(or (rhs-description rhs)
#'(symbol->string 'name)))])
(values (parse:rhs #,rhs
attrs
args
get-description
splicing?)
get-description))))]))
(define-syntax (syntax-class-parse stx)
(syntax-case stx ()
[(_ s x arg ...)
(parameterize ((current-syntax-context stx))
(let* ([arg-count (length (syntax->list #'(arg ...)))]
[stxclass (get-stxclass/check-arg-count #'s arg-count)]
[attrs (stxclass-attrs stxclass)])
(with-syntax ([parser (stxclass-parser-name stxclass)]
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([raw (parser x arg ...)])
(if (ok? raw)
(map vector '(name ...) '(depth ...) raw)
raw)))))]))
(define-syntax (syntax-class-attributes stx)
(syntax-case stx ()
[(_ s)
(parameterize ((current-syntax-context stx))
(let ([attrs (stxclass-attrs (get-stxclass #'s))])
(with-syntax ([(a ...) (map attr-name attrs)]
[(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))])
#'(remove-duplicates
(map interpret-error-expression
(parser-errors p)))))]))
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f #f #:context stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p)
(let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)])
#`(quote #,p))]))
(define-syntax-rule (debug-parse x p)
(let/ec escape
(parameterize ((current-failure-handler
(lambda (_ f)
(escape (failure->sexpr f)
(failure->sexpr (simplify-failure f))))))
(syntax-parse x [p 'success]))))
(define-syntax (syntax-parse stx)
(syntax-case stx ()
[(syntax-parse stx-expr . clauses)
(quasisyntax/loc stx
(let ([x (datum->syntax #f stx-expr)])
(parse:clauses x clauses #,((make-syntax-introducer) stx))))]))
(define-syntax (syntax-parser stx)
(syntax-case stx ()
[(syntax-parser . clauses)
(quasisyntax/loc stx
(lambda (x)
(let ([x (datum->syntax #f x)])
(parse:clauses x clauses #,((make-syntax-introducer) stx)))))]))
(define-syntax with-patterns
(syntax-rules ()
[(with-patterns () . b)
(let () . b)]
[(with-patterns ([p x] . more) . b)
(syntax-parse x [p (with-patterns more . b)])]))

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

@ -1,898 +1,31 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
scheme/sandbox
(for-label scheme/base
scheme/contract
(except-in syntax/parse ...+)
syntax/kerncase))
@(define ellipses @scheme[...])
@(begin
(define (fixup exn)
(let ([src (ormap values (exn:fail:syntax-exprs exn))])
(if src
(make-exn:fail:syntax
(format "~a at: ~a" (exn-message exn) (syntax->datum src))
(exn-continuation-marks exn)
(exn:fail:syntax-exprs exn))
exn)))
(define the-eval
(parameterize ((sandbox-output 'string)
(sandbox-error-output 'string)
(sandbox-make-code-inspector current-code-inspector)
(sandbox-eval-handlers
(list #f
(lambda (thunk)
(with-handlers ([exn:fail:syntax?
(lambda (e) (raise (fixup e)))])
(thunk))))))
(make-evaluator 'scheme/base
#:requires '(syntax/parse (for-syntax scheme/base)))))
(the-eval '(error-print-source-location #f))
(define-syntax-rule (myexamples e ...)
(examples #:eval the-eval e ...)))
(for-label syntax/parse))
@title[#:tag "stxparse" #:style '(toc)]{Parsing and classifying syntax}
The @schememodname[syntax/parse] library provides a framework for
describing and parsing syntax. Using @schememodname[syntax/parse],
macro writers can define new syntactic categories, specify their legal
syntax, and use them to write clear, concise, and robust macros. The
library also provides a pattern-matching form, @scheme[syntax-parse],
which offers many improvements over @scheme[syntax-case].
writing macros and processing syntax. The library provides a powerful
language of syntax patterns, used by the pattern-matching form
@scheme[syntax-parse] and the specification form
@scheme[define-syntax-class]. Macros that use @scheme[syntax-parse]
automatically generate error messages based on descriptions and
messages embedded in the macro's syntax patterns.
@defmodule[syntax/parse]
@local-table-of-contents[]
@;{----------}
@include-section["parse/intro.scrbl"]
@include-section["parse/examples.scrbl"]
@include-section["parse/parsing.scrbl"]
@include-section["parse/patterns.scrbl"]
@include-section["parse/litconv.scrbl"]
@include-section["parse/lib.scrbl"]
@section{Quick Start}
@;{Description of how error reporting works}
@;{and designing for good errors}
This section provides a rapid introduction to the
@schememodname[syntax/parse] library for the macro programmer.
@;{Cut and Commit for efficiency and error reporting.}
To use @scheme[syntax-parse] to write a macro transformer, import it
@scheme[for-syntax]:
@schemeblock[(require (for-syntax syntax/parse))]
For example, here is is a module that defines
@schemekeywordfont{mylet}, a macro that has the same behavior as the
standard @scheme[let] form (including ``named @scheme[let]''):
@schemeblock[
(module example racket/base
(require (for-syntax scheme/base syntax/parse))
(define-syntax (mylet stx)
(syntax-parse stx
[(_ loop:id ((x:id e:expr) ...) . body)
#'(letrec ([loop (lambda (x ...) . body)])
(loop e ...))]
[(_ ((x:id e:expr) ...) . body)
#'((lambda (x ...) . body) e ...)])))
]
The macro is defined as a procedure that takes one argument,
@scheme[stx]. The @scheme[syntax-parse] form is similar to
@scheme[syntax-case], except that there is no literals list between
the syntax argument and the sequence of clauses.
@bold{Note: } Remember not to put a @scheme[syntax-case] style
literals list between the syntax argument and the clauses!
The patterns contain identifiers consisting of two parts separated by
a colon character, such as @scheme[loop:id] or @scheme[e:expr]. These
are pattern variables annotated with syntax classes. For example,
@scheme[loop:id] is a pattern variable named @scheme[loop] with the
syntax class @scheme[id] (identifier). Note that only the pattern
variable part is used in the syntax template.
Syntax classes restrict what a pattern variable can match. Above,
@scheme[loop] only matches an identifier, so the first clause only
matches the ``named-let'' syntax. Syntax classes replace some uses of
@scheme[syntax-case]'s ``fenders'' or guard expressions. They also
enable @scheme[syntax-parse] to automatically give specific error
messages.
The @schememodname[syntax/parse] library provides several built-in
syntax classes (see @secref{lib} for a list). Programmers can also
define their own using @scheme[define-syntax-class]:
@schemeblock[
(module example-syntax racket/base
(require syntax/parse)
(provide binding)
(define-syntax-class binding
#:attributes (x e)
(pattern (x:id e:expr))))
(module example racket/base
(require (for-syntax racket/base
syntax/parse
'example-syntax))
(define-syntax (mylet stx)
(syntax-parse stx
[(_ loop:id (b:binding ...) . body)
#'(letrec ([loop (lambda (b.x ...) . body)])
(loop b.e ...))]
[(_ (b:binding ...) . body)
#'((lambda (b.x ...) . body) b.e ...)])))
]
@bold{Note:} Syntax classes must be defined in the same phase as the
@scheme[syntax-parse] expression they're used in. The right-hand side
of a macro is at phase 1, so syntax classes it uses must be defined in
a separate module and required @scheme[for-syntax]. Since the
auxiliary module uses @scheme[define-syntax-class] at phase 0, it has
@scheme[(require syntax/parse)], with no @scheme[for-syntax].
Alternatively, the syntax class could be made a local definition,
thus:
@schemeblock[
(module example racket/base
(require (for-syntax scheme/base
syntax/parse))
(define-syntax (mylet stx)
(define-syntax-class binding
#:attributes (x e)
(pattern (x:id e:expr)))
(syntax-parse stx
[(_ loop:id (b:binding ...) . body)
#'(letrec ([loop (lambda (b.x ...) . body)])
(loop b.e ...))]
[(_ (b:binding ...) . body)
#'((lambda (b.x ...) . body) b.e ...)])))
]
A syntax class is an abstraction of a syntax pattern. The syntax class
@scheme[binding] gives a name to the repeated pattern fragment
@scheme[(x:id e:expr)]. The components of the fragment, @scheme[x] and
@scheme[e], become @tech{attributes} of the syntax class. When
@scheme[b:binding] matches, @scheme[b] gets bound to the whole binding
pair, and @scheme[b.x] and @scheme[b.e] get bound to the variable name
and expression, respectively. Actually, all of them are bound to
sequences, because of the ellipses.
Syntax classes can have multiple alternative patterns. Suppose we
wanted to extend @schemekeywordfont{mylet} to allow a simple
identifier as a binding, in which case it would get the value
@scheme[#f]:
@schemeblock[
(mylet ([a 1] b [c 'foo]) ....)
]
Here's how the syntax class would change:
@margin-note{The @scheme[(require (for-template scheme/base))] is
needed for the @scheme[quote] expression. If the syntax class
definition were a local definition in the same module, the
@scheme[for-template] would be unnecessary.}
@;
@SCHEMEBLOCK[
(module example-syntax scheme/base
(require syntax/parse)
(require (for-template scheme/base))
(provide binding)
(define-syntax-class binding
#:attributes (x e)
(pattern (x:id e:expr))
(pattern x:id
#:with e #'(quote #f))))
]
The second pattern matches unparenthesized identifiers. The @scheme[e]
attribute is bound using a @scheme[#:with] clause, which matches the
pattern @scheme[e] against the syntax from evaluating @scheme[#'#f].
Optional keyword arguments are supported via @tech{head
patterns}. Unlike normal patterns, which match one term, head patterns
can match a variable number of subterms in a list.
Suppose @schemekeywordfont{mylet} accepted an optional
@scheme[#:check] keyword with one argument, a procedure that would be
applied to every variable's value. Here's one way to write it
(dropping the named-let variant for simplicity):
@SCHEMEBLOCK[
(define-syntax (mylet stx)
(syntax-parse stx
[(_ (~optional (~seq #:check pred)) (b:binding ...) . body)
#`((lambda (b.x ...)
#,(if (attribute pred)
#'(unless (and (pred b.x) ...) (error 'check))
#'(void))
. body)
b.e ...)]))
]
An optional subpattern might not match, so attributes within an
@scheme[~optional] form might not be bound to syntax. Such
non-syntax-valued attributes may not be used within syntax
templates. The @scheme[attribute] special form is used to get the
value of an attribute; if the attribute didn't get matched, the value
is @scheme[#f].
Here's another way write it, using @scheme[#:defaults] to give the
@scheme[pred] attribute a default value:
@schemeblock[
(define-syntax (mylet stx)
(syntax-parse stx
[(_ (~optional (~seq #:check pred)
#:defaults ([pred #'(lambda (x) #t)]))
(b:binding ...) . body)
#`((lambda (b.x ...)
(unless (and (pred b.x) ...) (error 'check))
. body)
b.e ...)]))
]
Programmers can also create abstractions over head patterns, using
@scheme[define-splicing-syntax-class]. Here it is, rewritten to use
multiple alternatives instead of @scheme[~optional]:
@schemeblock[
(define-splicing-syntax-class optional-check
#:attributes (pred)
(pattern (~seq #:check pred))
(pattern (~seq)
#:with pred #'(lambda (x) #t)))
]
@bold{Note: } When defining a splicing syntax class, remember to
include @scheme[~seq] in the pattern!
Here is the corresponding macro:
@schemeblock[
(define-syntax (mylet stx)
(syntax-parse stx
[(_ c:optional-check (b:binding ...) . body)
#'((lambda (b.x ...)
(unless (and (c.pred b.x) ...) (error 'check))
. body)
b.e ...)]))
]
The documentation in the following sections contains additional
examples of @schememodname[syntax/parse] features.
@;{----------}
@section{Parsing and classifying syntax}
This section describes @schememodname[syntax/parse]'s facilities for
parsing and classifying syntax. These facilities use a common language
of @tech{syntax patterns}, which is described in detail in the next
section, @secref{syntax-patterns}.
@subsection{Parsing syntax}
Two parsing forms are provided: @scheme[syntax-parse] and
@scheme[syntax-parser].
@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+)
([parse-option (code:line #:context context-expr)
(code:line #:literals (literal ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[literal literal-id
(pattern-id literal-id)
(pattern-id literal-id #:phase phase-expr)]
[literal-set literal-set-id
(literal-set-id literal-set-option ...)]
[literal-set-option (code:line #:at context-id)
(code:line #:phase phase-expr)]
[clause (syntax-pattern pattern-directive ... expr ...+)])
#:contracts ([stx-expr syntax?])]{
Evaluates @scheme[stx-expr], which should produce a syntax object, and
matches it against the @scheme[clause]s in order. If some clause's
pattern matches, its attributes are bound to the corresponding
subterms of the syntax object and that clause's side conditions and
@scheme[expr] is evaluated. The result is the result of @scheme[expr].
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.
The following options are supported:
@specsubform[(code:line #:context context-expr)
#:contracts ([context-expr syntax?])]{
When present, @scheme[context-expr] is used in reporting parse
failures; otherwise @scheme[stx-expr] is used.
@(myexamples
(syntax-parse #'(a b 3)
[(x:id ...) 'ok])
(syntax-parse #'(a b 3)
#:context #'(lambda (a b 3) (+ a b))
[(x:id ...) 'ok]))
}
@specsubform/subs[(code:line #:literals (literal ...))
([literal literal-id
(pattern-id literal-id)
(pattern-id literal-id #:phase phase-expr)])]{
@margin-note{
Unlike @scheme[syntax-case], @scheme[syntax-parse] requires all
literals to have a binding. To match identifiers by their symbolic
names, use the @scheme[~datum] pattern form instead.
}
@;
The @scheme[#:literals] option specifies identifiers that should be
treated as @tech{literals} rather than @tech{pattern variables}. An
entry in the literals list has two components: the identifier used
within the pattern to signify the positions to be matched
(@scheme[pattern-id]), and the identifier expected to occur in those
positions (@scheme[literal-id]). If the entry is a single identifier,
that identifier is used for both purposes.
If the @scheme[#:phase] option is given, then the literal is compared
at phase @scheme[phase-expr]. Specifically, the binding of the
@scheme[literal-id] at phase @scheme[phase-expr] must match the
input's binding at phase @scheme[phase-expr].
}
@specsubform/subs[(code:line #:literal-sets (literal-set ...))
([literal-set literal-set-id
(literal-set-id literal-set-option ...)]
[literal-set-option (code:line #:at context-id)
(code:line #:phase phase-expr)])]{
Many literals can be declared at once via one or more @tech{literal
sets}, imported with the @scheme[#:literal-sets] option. See
@tech{literal sets} for more information.
}
@specsubform[(code:line #:conventions (conventions-id ...))]{
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. See the section on @tech{conventions} for examples.
}
Each clause consists of a @tech{syntax pattern}, an optional sequence
of @tech{pattern directives}, and a non-empty sequence of body
expressions.
}
@defform[(syntax-parser parse-option ... clause ...+)]{
Like @scheme[syntax-parse], but produces a matching procedure. The
procedure accepts a single argument, which should be a syntax object.
}
@;{----------}
@subsection{Classifying syntax}
Syntax classes provide an abstraction mechanism for @tech{syntax
patterns}. Built-in syntax classes are supplied that recognize basic
classes such as @scheme[identifier] and @scheme[keyword]. Programmers
can compose basic syntax classes to build specifications of more
complex syntax, such as lists of distinct identifiers and formal
arguments with keywords. Macros that manipulate the same syntactic
structures can share syntax class definitions.
@defform*/subs[#:literals (pattern)
[(define-syntax-class name-id stxclass-option ...
stxclass-variant ...+)
(define-syntax-class (name-id arg-id ...) stxclass-option ...
stxclass-variant ...+)]
([stxclass-option
(code:line #:attributes (attr-arity-decl ...))
(code:line #:description description-expr)
(code:line #:opaque)
(code:line #:literals (literal-entry ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[attr-arity-decl
attr-name-id
(attr-name-id depth)]
[stxclass-variant
(pattern syntax-pattern pattern-directive ...)])]{
Defines @scheme[name-id] as a @deftech{syntax class}, which
encapsulates one or more @tech{single-term patterns}.
When the @scheme[arg-id]s are present, they are bound as variables in
the body. The body of the syntax-class definition contains a non-empty
sequence of @scheme[pattern] variants.
The following options are supported:
@specsubform/subs[(code:line #:attributes (attr-arity-decl ...))
([attr-arity-decl attr-id
(attr-id depth)])]{
Declares the attributes of the syntax class. An attribute arity
declaration consists of the attribute name and optionally its ellipsis
depth (zero if not explicitly specified).
If the attributes are not explicitly listed, they are inferred as the
set of all @tech{pattern variables} occurring in every variant of the
syntax class. Pattern variables that occur at different ellipsis
depths are not included, nor are nested attributes from
@tech{annotated pattern variables}.
}
@specsubform[(code:line #:description description-expr)]{
The @scheme[description] argument is an expression (evaluated in a
scope containing the syntax class's parameters) that should evaluate
to a string. It is used in error messages involving the syntax
class. For example, if a term is rejected by the syntax class, an
error of the form @schemevalfont{"expected @scheme[description]"} may
be synthesized.
If absent, the name of the syntax class is used instead.
}
@specsubform[#:opaque]{
Indicates that errors should not be reported with respect to the
internal structure of the syntax class.
}
@specsubform[(code:line #:literals (literal-entry))]
@specsubform[(code:line #:literal-sets (literal-set ...))]
@specsubform[(code:line #:conventions (convention-id ...))]{
Declares the literals and conventions that apply to the syntax class's
variant patterns and their immediate @scheme[#:with] clauses. Patterns
occuring within subexpressions of the syntax class (for example, on
the right-hand side of a @scheme[#:fail-when] clause) are not
affected.
These options have the same meaning as in @scheme[syntax-parse].
}
Each variant of a syntax class is specified as a separate
@scheme[pattern]-form whose syntax pattern is a @tech{single-term
pattern}.
}
@defform*[#:literals (pattern)
[(define-splicing-syntax-class name-id stxclass-option ...
stxclass-variant ...+)
(define-splicing-syntax-class (name-id arg-id ...) stxclass-option ...
stxclass-variant ...+)]]{
Defines @scheme[name-id] as a @deftech{splicing syntax class},
analogous to a @tech{syntax class} but encapsulating @tech{head
patterns} rather than @tech{single-term patterns}.
The options are the same as for @scheme[define-syntax-class].
Each variant of a splicing syntax class is specified as a separate
@scheme[pattern]-form whose syntax pattern is a @tech{head pattern}.
}
@defform[#:literals (pattern)
(pattern syntax-pattern pattern-directive ...)]{
Used to indicate a variant of a syntax class or splicing syntax
class. The variant accepts syntax matching the given syntax pattern
with the accompanying @tech{pattern directives}.
When used within @scheme[define-syntax-class], @scheme[syntax-pattern]
should be a @tech{single-term pattern}; within
@scheme[define-splicing-syntax-class], it should be a @tech{head
pattern}.
The attributes of the variant are the attributes of the pattern
together with all attributes bound by @scheme[#:with] clauses,
including nested attributes produced by syntax classes associated with
the pattern variables.
}
@;{--------}
@subsection{Pattern directives}
Both the parsing forms and syntax class definition forms support
@deftech{pattern directives} for annotating syntax patterns and
specifying side conditions. The grammar for pattern directives
follows:
@schemegrammar[pattern-directive
(code:line #:declare pattern-id syntax-class-id)
(code:line #:declare pattern-id (syntax-class-id expr ...))
(code:line #:with syntax-pattern expr)
(code:line #:attr attr-id expr)
(code:line #:fail-when condition-expr message-expr)
(code:line #:fail-unless condition-expr message-expr)
(code:line #:when condition-expr)]
@specsubform[(code:line #:declare pvar-id syntax-class-id)]
@specsubform[(code:line #:declare pvar-id (syntax-class-id expr ...))]{
The first form is equivalent to using the
@svar[pvar-id:syntax-class-id] form in the pattern (but it is illegal
to use both for the same pattern variable).
The second form allows the use of parameterized syntax classes, which
cannot be expressed using the ``colon'' notation. The @scheme[expr]s
are evaluated outside the scope of any of the attribute bindings from
pattern that the @scheme[#:declare] directive applies to.
}
@specsubform[(code:line #:with syntax-pattern stx-expr)]{
Evaluates the @scheme[stx-expr] in the context of all previous
attribute bindings and matches it against the pattern. If the match
succeeds, the pattern's attributes are added to environment for the
evaluation of subsequent side conditions. If the @scheme[#:with] match
fails, the matching process backtracks. Since a syntax object may
match a pattern in several ways, backtracking may cause the same
clause to be tried multiple times before the next clause is reached.
}
@specsubform[(code:line #:attr attr-id expr)]{
Evaluates the @scheme[expr] in the context of all previous attribute
bindings and binds it to the attribute named by @scheme[attr-id]. The
value of @scheme[expr] need not be syntax.
}
@specsubform[(code:line #:fail-when condition-expr message-expr)]{
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is any true value (not @scheme[#f]),
the matching process backtracks (with the given message); otherwise,
it continues. If the value of the condition expression is a syntax
object, it is indicated as the cause of the error.
}
@specsubform[(code:line #:fail-unless condition-expr message-expr)]{
Like @scheme[#:fail-when] with the condition negated.
}
@specsubform[(code:line #:when condition-expr)]{
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is @scheme[#f], the matching process
backtracks. In other words, @scheme[#:when] is like
@scheme[#:fail-unless] without the message argument.
}
@;{----------}
@subsection{Pattern variables and attributes}
An @deftech{attribute} is a name bound by a syntax pattern. An
attribute can be a @tech{pattern variable} itself, or it can be a
@tech{nested attribute} bound by an @tech{annotated pattern
variable}. The name of a nested attribute is computed by concatenating
the pattern variable name with the syntax class's exported attribute's
name, separated by a dot (see the example below).
Attribute names cannot be used directly as expressions; that is,
attributes are not variables. Instead, an attribute's value can be
gotten using the @scheme[attribute] special form.
@defform[(attribute attr-id)]{
Returns the value associated with the attribute named
@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an
error is raised.
}
The value of an attribute need not be syntax. Non-syntax-valued
attributes can be used to return a parsed representation of a subterm
or the results of an analysis on the subterm. A non-syntax-valued
attribute should be bound using the @scheme[#:attr] directive or a
@scheme[~bind] pattern.
@myexamples[
(define-syntax-class table
(pattern ((key value) ...)
#:attr hash
(for/hash ([k (syntax->datum #'(key ...))]
[v (syntax->datum #'(value ...))])
(values k v))))
(syntax-parse #'((a 1) (b 2) (c 3))
[t:table
(attribute t.hash)])
]
A syntax-valued attribute is an attribute whose value is a syntax
object or a syntax list of the appropriate @tech{ellipsis
depth}. Syntax-valued attributes can be used within @scheme[syntax],
@scheme[quasisyntax], etc as part of a syntax template. If a
non-syntax-valued attribute is used in a syntax template, a runtime
error is signalled.
@myexamples[
(syntax-parse #'((a 1) (b 2) (c 3))
[t:table
#'(t.key ...)])
(syntax-parse #'((a 1) (b 2) (c 3))
[t:table
#'t.hash])
]
Every attribute has an associated @deftech{ellipsis depth} that
determines how it can be used in a syntax template (see the discussion
of ellipses in @scheme[syntax]). For a pattern variable, the ellipsis
depth is the number of ellipses the pattern variable ``occurs under''
in the pattern. For a nested attribute the depth is the sum of the
pattern variable's depth and the depth of the attribute in the syntax
class. Consider the following code:
@schemeblock[
(define-syntax-class quark
(pattern (a b ...)))
(syntax-parse some-term
[(x (y:quark ...) ... z:quark)
some-code])
]
The syntax class @scheme[quark] exports two attributes: @scheme[a] at
depth 0 and @scheme[b] at depth 1. The @scheme[syntax-parse] pattern
has three pattern variables: @scheme[x] at depth 0, @scheme[y] at
depth 2, and @scheme[z] at depth 0. Since @scheme[x] and @scheme[y]
are annotated with the @scheme[quark] syntax class, the pattern also
binds the following nested attributes: @scheme[y.a] at depth 2,
@scheme[y.b] at depth 3, @scheme[z.a] at depth 0, and @scheme[z.b] at
depth 1.
An attribute's ellipsis nesting depth is @emph{not} a guarantee that
its value has that level of list nesting. In particular, @scheme[~or]
and @scheme[~optional] patterns may result in attributes with fewer
than expected levels of list nesting.
@(myexamples
(syntax-parse #'(1 2 3)
[(~or (x:id ...) _)
(attribute x)]))
@;{--------}
@subsection{Inspection tools}
The following special forms are for debugging syntax classes.
@defform[(syntax-class-attributes syntax-class-id)]{
Returns a list of the syntax class's attributes. Each attribute is
listed by its name and ellipsis depth.
}
@defform[(syntax-class-parse syntax-class-id stx-expr arg-expr ...)]{
Runs the parser for the syntax class (parameterized by the
@scheme[arg-expr]s) on the syntax object produced by
@scheme[stx-expr]. On success, the result is a list of vectors
representing the attribute bindings of the syntax class. Each vector
contains the attribute name, depth, and associated value. On failure,
the result is some internal representation of the failure.
}
@;{----------}
@include-section["parse-patterns.scrbl"]
@;{----------}
@section{Literal sets and Conventions}
Sometimes the same literals are recognized in a number of different
places. The most common example is the literals for fully expanded
programs, which are used in many analysis and transformation
tools. Specifying literals individually is burdensome and error-prone.
As a remedy, @schememodname[syntax/parse] offers @deftech{literal
sets}. A literal set is defined via @scheme[define-literal-set] and
used via the @scheme[#:literal-set] option of @scheme[syntax-parse].
@defform/subs[(define-literal-set name-id (literal ...))
([literal literal-id
(pattern-id literal-id)])]{
Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal]
can have a separate @scheme[pattern-id] and @scheme[literal-id]. The
@scheme[pattern-id] determines what identifiers in the pattern are
treated as literals. The @scheme[literal-id] determines what
identifiers the literal matches.
@myexamples[
(define-literal-set def-litset
(define-values define-syntaxes))
(syntax-parse #'(define-syntaxes (x) 12)
#:literal-sets (def-litset)
[(define-values (x:id ...) e:expr) 'v]
[(define-syntaxes (x:id ...) e:expr) 's])
]
The literals in a literal set always refer to the phase-0 bindings of
the enclosing module. For example:
@myexamples[
(module common racket/base
(define x 'something)
(provide x))
(module lits racket/base
(require syntax/parse 'common)
(define-literal-set common-lits (x))
(provide common-lits))
]
In the literal set @scheme[common-lits], the literal @scheme[x] always
recognizes identifiers bound to the variable @scheme[x] defined in
module @schememodname['common].
When a literal set is used with the @scheme[#:phase phase-expr]
option, the literals' fixed bindings are compared against the binding of
the input literal at the specified phase. Continuing the example:
@myexamples[
(require syntax/parse 'lits (for-syntax 'common))
(syntax-parse #'x #:literal-sets ([common-lits #:phase 1])
[x 'yes]
[_ 'no])
]
The occurrence of @scheme[x] in the pattern matches any identifier
whose binding at phase 1 is the @scheme[x] from module
@schememodname['common].
}
@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 ...)])]{
Defines @deftech{conventions} that supply default syntax classes for
pattern variables. A pattern variable that has no explicit syntax
class is checked against each @scheme[id-pattern], and the first one
that matches determines the syntax class for the pattern. If no
@scheme[id-pattern] matches, then the pattern variable has no syntax
class.
@myexamples[
(define-conventions xyz-as-ids
[x id] [y id] [z id])
(syntax-parse #'(a b c 1 2 3)
#:conventions (xyz-as-ids)
[(x ... n ...) (syntax->datum #'(x ...))])
(define-conventions xn-prefixes
[#rx"^x" id]
[#rx"^n" nat])
(syntax-parse #'(a b c 1 2 3)
#:conventions (xn-prefixes)
[(x0 x ... n0 n ...)
(syntax->datum #'(x0 (x ...) n0 (n ...)))])
]
Local conventions, introduced with the @scheme[#:local-conventions]
keyword argument of @scheme[syntax-parse] and syntax class
definitions, may refer to local bindings:
@myexamples[
(define-syntax-class (nat> bound)
(pattern n:nat
#:fail-unless (> (syntax-e #'n) bound)
(format "expected number > ~s" bound)))
(define-syntax-class (natlist> bound)
#:local-conventions ([N (nat> bound)])
(pattern (N ...)))
(define (parse-natlist> bound x)
(syntax-parse x
#:local-conventions ([NS (natlist> bound)])
[NS 'ok]))
(parse-natlist> 0 #'(1 2 3))
(parse-natlist> 5 #'(8 6 4 2))
]
}
@;{----------}
@section[#:tag "lib"]{Library syntax classes and literal sets}
@subsection{Syntax classes}
@(begin
(define-syntax-rule (defstxclass name . pre-flows)
(defidform name . pre-flows))
(define-syntax-rule (defstxclass* (name arg ...) . pre-flows)
(defform (name arg ...) . pre-flows)))
@defstxclass[expr]{
Matches anything except a keyword literal (to distinguish expressions
from the start of a keyword argument sequence). The term is not
otherwise inspected, and no guarantee is made that the term is
actually a valid expression.
}
@deftogether[(
@defstxclass[identifier]
@defstxclass[boolean]
@defstxclass[str]
@defstxclass[char]
@defstxclass[keyword]
@defstxclass[number]
@defstxclass[integer]
@defstxclass[exact-integer]
@defstxclass[exact-nonnegative-integer]
@defstxclass[exact-positive-integer])]{
Match syntax satisfying the corresponding predicates.
}
@defstxclass[id]{ Alias for @scheme[identifier]. }
@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. }
@defform[(static predicate description)]{
Matches an identifier that is bound in the syntactic environment to
static information (see @scheme[syntax-local-value]) satisfying the
given @scheme[predicate]. If the term does not match, the
@scheme[description] argument is used to describe the expected syntax.
When used outside of the dynamic extent of a macro transformer (see
@scheme[syntax-transforming?]), matching fails.
The attribute @var[value] contains the value the name is bound to.
}
@defform[(atom-in-list atoms description)]{
Matches a syntax object whose inner datum is @scheme[eqv?] to some
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.
}
@subsection{Literal sets}
@defidform[kernel-literals]{
Literal set containing the identifiers for fully-expanded code
(@secref[#:doc '(lib "scribblings/reference/reference.scrbl")
"fully-expanded"]). The set contains all of the forms listed by
@scheme[kernel-form-identifier-list], plus @scheme[module],
@scheme[#%plain-module-begin], @scheme[#%require], and
@scheme[#%provide].
Note that the literal-set uses the names @scheme[#%plain-lambda] and
@scheme[#%plain-app], not @scheme[lambda] and @scheme[#%app].
}
@include-section["parse/debug.scrbl"]
@include-section["parse/experimental.scrbl"]

56
collects/syntax/scribblings/parse/debug.scrbl Normal file
View File

@ -0,0 +1,56 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt")
@title{Debugging and inspection tools}
@defmodule[syntax/parse/debug]
The following special forms are for debugging syntax classes.
@defform[(syntax-class-attributes syntax-class-id)]{
Returns a list of the syntax class's attributes. Each attribute entry
consists of the attribute's name and ellipsis depth.
}
@deftogether[[
@defform[(syntax-class-arity syntax-class-id)]
@defform[(syntax-class-keywords syntax-class-id)]]]{
Returns the syntax class's arity and keywords, respectively. Compare
with @scheme[procedure-arity] and @scheme[procedure-keywords].
}
@defform[(syntax-class-parse syntax-class-id stx-expr arg ...)
#:contracts ([stx-expr syntax?])]{
Runs the parser for the syntax class (parameterized by the
@scheme[arg-expr]s) on the syntax object produced by
@scheme[stx-expr]. On success, the result is a list of vectors
representing the attribute bindings of the syntax class. Each vector
contains the attribute name, depth, and associated value. On failure,
the result is some internal representation of the failure.
}
@defform[(debug-parse stx-expr S-pattern ...+)
#:contracts ([stx-expr syntax?])]{
Tries to match @scheme[stx-expr] against the @scheme[S-pattern]s. If
matching succeeds, the the symbol @scheme['success] is
returned. Otherwise, an S-expression describing the failure is returned.
The failure S-expression shows both the raw set of failures (unsorted)
and the failures with maximal progress. The maximal failures are
divided into equivalence classes based on their progress (progress is
a partial order); that is, failures within an equivalence class have
the same progress and, in principle, pinpoint the same term as the
problematic term. Multiple equivalence classes only arise from
@scheme[~parse] patterns (or equivalently, @scheme[#:with] clauses)
that match computed terms or @scheme[~fail] (@scheme[#:fail-when],
etc) clauses that allow a computed term to be pinpointed.
}

42
collects/syntax/scribblings/parse/ex-exprc.scrbl Normal file
View File

@ -0,0 +1,42 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title[#:tag "exprc"]{Experimental: Contracts on macro sub-expressions}
@emph{This section involves facilities that are experimental and
subject to change.}
Just as procedures often expect certain kinds of values as arguments,
macros often have expectations about the expressions they are
given. And just as procedures express those expectations via
contracts, so can macros, using the @scheme[expr/c] syntax class.
For example, here is a macro @scheme[myparameterize] that behaves like
@scheme[parameterize] but enforces the @scheme[parameter?] contract on
the parameter expressions.
@myinteraction[
(define-syntax (myparameterize stx)
(syntax-parse stx
[(_ ((p v:expr) ...) body:expr)
#:declare p (expr/c #'parameter?
#:name "parameter argument")
#'(parameterize ((p.c v) ...) body)]))
(myparameterize ((current-input-port
(open-input-string "(1 2 3)")))
(read))
(myparameterize (('whoops 'something))
'whatever)
]
@bold{Important:} Make sure when using @scheme[expr/c] to use the
@scheme[c] attribute. If the macro above had used @scheme[p] in the
template, the expansion would have used the raw, unchecked
expressions. The @scheme[expr/c] syntax class does not change how
pattern variables are bound; it only computes an attribute that
represents the checked expression.

86
collects/syntax/scribblings/parse/ex-kw-args.scrbl Normal file
View File

@ -0,0 +1,86 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title{Optional keyword arguments}
This section explains how to write a macro that accepts (simple)
optional keyword arguments. We use the example @scheme[mycond], which
is like Racket's @scheme[cond] except that it takes an optional
keyword argument that controls what happens if none of the clauses
match.
Optional keyword arguments are supported via @tech{head
patterns}. Unlike normal patterns, which match one term, head patterns
can match a variable number of subterms in a list. Some important
head-pattern forms are @scheme[~seq], @scheme[~or], and
@scheme[~optional].
Here's one way to do it:
@myinteraction[
(define-syntax (mycond stx)
(syntax-parse stx
[(mycond (~or (~seq #:error-on-fallthrough who:expr) (~seq))
clause ...)
(with-syntax ([error? (if (attribute who) #'#t #'#f)]
[who (or (attribute who) #'#f)])
#'(mycond* error? who clause ...))]))
(define-syntax mycond*
(syntax-rules ()
[(mycond error? who [question answer] . clauses)
(if question answer (mycond* error? who . clauses))]
[(mycond #t who)
(error who "no clauses matched")]
[(mycond #f _)
(void)]))
]
We cannot write @scheme[#'who] in the macro's right-hand side, because
the @scheme[who] attribute does not receive a value if the keyword
argument is omitted. Instead we must write @scheme[(attribute who)],
which produces @scheme[#f] if matching did not assign a value to the
attribute.
@myinteraction[
(mycond [(even? 13) 'blue]
[(odd? 4) 'red])
(mycond #:error-on-fallthrough 'myfun
[(even? 13) 'blue]
[(odd? 4) 'red])
]
There's a simpler way of writing the @scheme[~or] pattern above:
@schemeblock[
(~optional (~seq #:error-on-fallthrough who:expr))
]
Yet another way is to introduce a @tech{splicing syntax class}, which
is like an ordinary syntax class but for head patterns.
@myinteraction[
(define-syntax (mycond stx)
(define-splicing-syntax-class maybe-fallthrough-option
(pattern (~seq #:error-on-fallthough who:expr)
#:with error? #'#t)
(pattern (~seq)
#:with error? #'#f
#:with who #'#f))
(syntax-parse stx
[(mycond fo:maybe-fallthrough-option clause ...)
#'(mycond* fo.error? fo.who clause ...)]))
]
Defining a splicing syntax class also makes it easy to eliminate the
case analysis we did before using @scheme[attribute] by defining
@scheme[error?] and @scheme[who] as attributes within both of the
syntax class's variants. (This is possible to do in the inline pattern
version too, using @scheme[~and] and @scheme[~parse], just less
convenient.) Splicing syntax classes also closely parallel the style
of grammars in macro documentation.

137
collects/syntax/scribblings/parse/ex-many-kws.scrbl Normal file
View File

@ -0,0 +1,137 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title{More keyword arguments}
This section shows how to express the syntax of @scheme[struct]'s
optional keyword arguments using @scheme[syntax-parse] patterns.
The part of @scheme[struct]'s syntax that is difficult to specify is
the sequence of struct options. Let's get the easy part out of the way
first.
@myinteraction[
(define-splicing-syntax-class maybe-super
(pattern (~seq super:id))
(pattern (~seq)))
(define-syntax-class field-option
(pattern #:mutable)
(pattern #:auto))
(define-syntax-class field
(pattern field:id
#:with (option ...) '())
(pattern [field:id option:field-option ...]))
]
Given those auxiliary syntax classes, here is a first approximation of
the main pattern, including the struct options:
@schemeblock[
(struct name:id super:maybe-super (field:field ...)
(~or (~seq #:mutable)
(~seq #:super super-expr:expr)
(~seq #:inspector inspector:expr)
(~seq #:auto-value auto:expr)
(~seq #:guard guard:expr)
(~seq #:property prop:expr prop-val:expr)
(~seq #:transparent)
(~seq #:prefab)
(~seq #:constructor-name constructor-name:id)
(~seq #:extra-constructor-name extra-constructor-name:id)
(~seq #:omit-define-syntaxes)
(~seq #:omit-define-values))
...)
]
The fact that @scheme[expr] does not match keywords helps in the case
where the programmer omits a keyword's argument; instead of accepting
the next keyword as the argument expression, @scheme[syntax-parse]
reports that an expression was expected.
There are two main problems with the pattern above:
@itemize[
@item{There's no way to tell whether a zero-argument keyword like
@scheme[#:mutable] was seen.}
@item{Some options, like @scheme[#:mutable], should appear at most
once.}
]
The first problem can be remedied using @scheme[~and] patterns to bind
a pattern variable to the keyword itself, as in this sub-pattern:
@schemeblock[
(~seq (~and #:mutable mutable-kw))
]
The second problem can be solved using @emph{repetition constraints}:
@schemeblock[
(struct name:id super:maybe-super (field:field ...)
(~or (~optional (~seq (~and #:mutable) mutable-kw))
(~optional (~seq #:super super-expr:expr))
(~optional (~seq #:inspector inspector:expr))
(~optional (~seq #:auto-value auto:expr))
(~optional (~seq #:guard guard:expr))
(~seq #:property prop:expr prop-val:expr)
(~optional (~seq (~and #:transparent transparent-kw)))
(~optional (~seq (~and #:prefab prefab-kw)))
(~optional (~seq #:constructor-name constructor-name:id))
(~optional
(~seq #:extra-constructor-name extra-constructor-name:id))
(~optional
(~seq (~and #:omit-define-syntaxes omit-def-stxs-kw)))
(~optional (~seq (~and #:omit-define-values omit-def-vals-kw))))
...)
]
The @scheme[~optional] repetition constraint indicates that an
alternative can appear at most once. (There is a @scheme[~once] form
that means it must appear exactly once.) In @scheme[struct]'s keyword
options, only @scheme[#:property] may occur any number of times.
There are still some problems, though. Without additional help,
@scheme[~optional] does not report particularly good errors. We must
give it the language to use, just as we had to give descriptions to
sub-patterns via syntax classes. Also, some related options are
mutually exclusive, such as @scheme[#:inspector],
@scheme[#:transparent], and @scheme[#:prefab].
@schemeblock[
(struct name:id super:maybe-super (field:field ...)
(~or (~optional
(~or (~seq #:inspector inspector:expr)
(~seq (~and #:transparent transparent-kw))
(~seq (~and #:prefab prefab-kw)))
#:name "#:inspector, #:transparent, or #:prefab option")
(~optional (~seq (~and #:mutable) mutable-kw)
#:name "#:mutable option")
(~optional (~seq #:super super-expr:expr)
#:name "#:super option")
(~optional (~seq #:auto-value auto:expr)
#:name "#:auto-value option")
(~optional (~seq #:guard guard:expr)
#:name "#:guard option")
(~seq #:property prop:expr prop-val:expr)
(~optional (~seq #:constructor-name constructor-name:id)
#:name "#:constructor-name option")
(~optional
(~seq #:extra-constructor-name extra-constructor-name:id)
#:name "#:extra-constructor-name option")
(~optional (~seq (~and #:omit-define-syntaxes omit-def-stxs-kw))
#:name "#:omit-define-syntaxes option")
(~optional (~seq (~and #:omit-define-values omit-def-vals-kw))
#:name "#:omit-define-values option"))
...)
]
Here we have grouped the three incompatible options together under a
single @scheme[~optional] constraint. That means that at most one of
any of those options is allowed. We have given names to the optional
clauses. See @scheme[~optional] for other customization options.
Note that there are other constraints that we have not represented in
the pattern. For example, @scheme[#:prefab] is also incompatible with
both @scheme[#:guard] and @scheme[#:property]. Repetition constraints
cannot express arbitrary incompatibility relations. The best way to
handle such contraints is with a side condition using
@scheme[#:fail-when].

107
collects/syntax/scribblings/parse/ex-mods-stxclasses.scrbl Normal file
View File

@ -0,0 +1,107 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title{Modules and reusable syntax classes}
As demonstrated in the @secref{stxparse-intro}, the simplest place to
define a syntax class is within the macro definition that uses it. But
this location, of course, limits the scope of the syntax class to the
one client macro. Creating reusable syntax classes is slightly
complicated, however, by the Racket @tech[#:doc '(lib
"scribblings/reference/reference.scrbl")]{phase level} separation. A
syntax class defined within a module cannot be used by macros in the
same module; it is defined at the wrong phase.
@myinteraction[
(module phase-mismatch-mod racket
(require syntax/parse (for-syntax syntax/parse))
(define-syntax-class foo
(pattern (a b c)))
(define-syntax (macro stx)
(syntax-parse stx
[(_ f:foo) #'(+ f.a f.b f.c)])))
]
In the module above, the syntax class @scheme[foo] is defined at phase
level 0. The reference to @scheme[foo] within @scheme[macro], however,
is at phase level 1, being the implementation of a macro
transformer. (Needing to require @schememodname[syntax/parse] twice,
once normally and once @scheme[for-syntax] is another sign of the
phase level incompatibility.) The only way to define reusable syntax
classes that can be used within macros is to define them in a separate
module and require that module @scheme[for-syntax].
@myinteraction[
(module stxclass-mod racket
(require syntax/parse)
(define-syntax-class foo
(pattern (a b c)))
(provide foo))
(module macro-mod racket
(require (for-syntax syntax/parse
'stxclass-mod))
(define-syntax (macro stx)
(syntax-parse stx
[(_ f:foo) #'(+ f.a f.b f.c)]))
(provide macro))
(require 'macro-mod)
(macro (1 2 3))
]
If the syntax classes refer to keywords, or if they compute
expressions via syntax templates, then the module containing the
syntax classes must generally require the keywords or bindings used in
the syntax templates @scheme[for-template].
@myinteraction[
(module arith-keywords-mod racket
(define-syntax plus (syntax-rules ()))
(define-syntax times (syntax-rules ()))
(provide plus times))
(module arith-stxclass-mod racket
(require syntax/parse
(for-template 'arith-keywords-mod
racket))
(define-syntax-class arith
#:literals (plus times)
(pattern n:nat
#:with expr #'n)
(pattern (plus a:arith b:arith)
#:with expr #'(+ a.expr b.expr))
(pattern (times a:arith b:arith)
#:with expr #'(* a.expr b.expr)))
(provide arith))
(module arith-macro-mod racket
(require (for-syntax syntax/parse
'arith-stxclass-mod)
'arith-keywords-mod)
(define-syntax (arith-macro stx)
(syntax-parse stx
[(_ a:arith)
#'(values 'a.expr a.expr)]))
(provide arith-macro
(all-from-out 'arith-keywords-mod)))
(require 'arith-macro-mod)
(arith-macro (plus 1 (times 2 3)))
]
In @scheme['arith-stxclass-mod], the module
@scheme['arith-keywords-mod] must be required @scheme[for-template]
because the keywords are used in phase-0 expressions. Likewise, the
module @schememodname[racket] must be required @scheme[for-template]
because the syntax class contains syntax templates involving
@scheme[+] and @scheme[*] (and, in fact, the implicit @scheme[#%app]
syntax). All of these identifiers (the keywords @scheme[plus] and
@scheme[times]; the procedures @scheme[+] and @scheme[*]; and the
implicit syntax @scheme[#%app]) must be bound at ``absolute'' phase
level 0. Since the module @scheme['arith-stxclass-mod] is required
with a phase level offset of 1 (that is, @scheme[for-syntax]), it must
compensate with a phase level offset of -1, or @scheme[for-template].

143
collects/syntax/scribblings/parse/ex-uniform.scrbl Normal file
View File

@ -0,0 +1,143 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title[#:tag "uniform-meanings"]{Variants with uniform meanings}
Syntax classes not only validate syntax, they also extract some
measure of meaning from it. From the perspective of meaning, there are
essentially two kinds of syntax class. In the first, all of the syntax
class's variants have the same kind of meaning. In the second,
variants may have different kinds of meaning.@margin-note*{In other
words, some syntax classes' meanings are products and others' meanings
are sums.} This section discusses the first kind, syntax classes with
uniform meanings. The next section discusses @secref{varied-meanings}.
If all of a syntax class's variants express the same kind of
information, that information can be cleanly represented via
attributes, and it can be concisely processed using ellipses.
One example of a syntax class with uniform meaning: the
@scheme[init-decl] syntax of the @scheme[class] macro. Here is the
specification of @scheme[init-decl]:
@schemegrammar*[[init-decl
id
(maybe-renamed)
(maybe-renamed default-expr)]
[maybe-renamed
id
(internal-id external-id)]]
The @scheme[init-decl] syntax class has three variants, plus an
auxiliary syntax class that has two variants of its own. But all forms
of @scheme[init-decl] ultimately carry just three pieces of
information: an internal name, an external name, and a default
configuration of some sort. The simpler syntactic variants are just
abbreviations for the full information.
The three pieces of information determine the syntax class's
attributes. It is useful to declare the attributes explicitly using
the @scheme[#:attributes] keyword; the declaration acts both as
in-code documentation and as a check on the variants.
@schemeblock[
(define-syntax-class init-decl
#:attributes (internal external default)
___)
]
Next we fill in the syntactic variants, deferring the computation of
the attributes:
@schemeblock[
(define-syntax-class init-decl
#:attributes (internal external default)
(pattern ???:id
___)
(pattern (???:maybe-renamed)
___)
(pattern (???:maybe-renamed ???:expr)
___))
]
We perform a similar analysis of @scheme[maybe-renamed]:
@schemeblock[
(define-syntax-class maybe-renamed
#:attributes (internal external)
(pattern ???:id
___)
(pattern (???:id ???:id)
___))
]
Here's one straightforward way of matching syntactic structure with
attributes for @scheme[maybe-renamed]:
@schemeblock[
(define-syntax-class maybe-renamed
#:attributes (internal external)
(pattern internal:id
#:with external #'internal)
(pattern (internal:id external:id)))
]
Given that definition of @scheme[maybe-renamed], we can fill in most
of the definition of @scheme[init-decl]:
@schemeblock[
(define-syntax-class init-decl
#:attributes (internal external default)
(pattern internal:id
#:with external #:internal
#:with default ???)
(pattern (mr:maybe-renamed)
#:with internal #'mr.internal
#:with external #'mr.external
#:with default ???)
(pattern (mr:maybe-renamed default0:expr)
#:with internal #'mr.internal
#:with external #'mr.external
#:with default ???))
]
At this point we realize we have not decided on a representation for
the default configuration. In fact, it is an example of
@seclink["varied-meanings"]{syntax with varied meanings} (aka sum or
disjoint union). The following section discusses representation
options in greater detail; for the sake of completeness, we present
one of them here.
There are two kinds of default configuration. One indicates that the
initialization argument is optional, with a default value computed
from the given expression. The other indicates that the initialization
argument is mandatory. We represent the variants as a (syntax) list
containing the default expression and as the empty (syntax) list,
respectively. More precisely:
@schemeblock[
(define-syntax-class init-decl
#:attributes (internal external default)
(pattern internal:id
#:with external #:internal
#:with default #'())
(pattern (mr:maybe-renamed)
#:with internal #'mr.internal
#:with external #'mr.external
#:with default #'())
(pattern (mr:maybe-renamed default0:expr)
#:with internal #'mr.internal
#:with external #'mr.external
#:with default #'(default0)))
]
Another way to look at this aspect of syntax class design is as the
algebraic factoring of sums-of-products (concrete syntax variants)
into products-of-sums (attributes and abstract syntax variants). The
advantages of the latter form are the ``dot'' notation for data
extraction, avoiding or reducing additional case analysis, and the
ability to concisely manipulate sequences using ellipses.

107
collects/syntax/scribblings/parse/ex-varied.scrbl Normal file
View File

@ -0,0 +1,107 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title[#:tag "varied-meanings"]{Variants with varied meanings}
As explained in the @seclink["uniform-meanings"]{previous section},
the meaning of a syntax class can be uniform, or it can be varied;
that is, different instances of the syntax class can carry different
kinds of information. This section discusses the latter kind of syntax
class.
A good example of a syntax class with varied meanings is the
@scheme[for-clause] of the @scheme[for] family of special forms.
@schemegrammar[for-clause
[id seq-expr]
[(id ...) seq-expr]
(code:line #:when guard-expr)]
The first two variants carry the same kind of information; both
consist of identifiers to bind and a sequence expression. The third
variant, however, means something totally different: a condition that
determines whether to continue the current iteration of the loop, plus
a change in scoping for subsequent @scheme[seq-expr]s. The information
of a @scheme[for-clause] must be represented in a way that a client
macro can do further case analysis to distinguish the ``bind variables
from a sequence'' case from the ``skip or continue this iteration and
enter a new scope'' case.
This section discusses two ways of representing varied kinds of
information.
@section{Syntactic normalization}
One approach is based on the observation that the syntactic variants
already constitute a representation of the information they carry. So
why not adapt that representation, removing redundancies and
eliminating simplifying the syntax to make subsequent re-parsing
trivial.
@schemeblock[
(define-splicing-syntax-class for-clause
#:attribute (norm)
(pattern [var:id seq:expr]
#:with norm #'[(var) seq])
(pattern [(var:id ...) seq:expr]
#:with norm #'[(var ...) seq])
(pattern (~seq #:when guard:expr)
#:with norm #'[#:when guard]))
]
First, note that since the @scheme[#:when] variant consists of two
separate terms, we define @scheme[for-clause] as a splicing syntax
class. Second, that kind of irregularity is just the sort of thing
we'd like to remove so we don't have to deal with it again later. Thus
we represent the normalized syntax as a single term beginning with
either a sequence of identifiers (the first two cases) or the keyword
@scheme[#:when] (the third case). The two normalized cases are easy to
process and easy to tell apart. We have also taken the opportunity to
desugar the first case into the second.
A normalized syntactic representation is most useful when the
subsequent case analysis is performed by @scheme[syntax-parse] or a
similar form.
@section{Non-syntax-valued attributes}
When the information carried by the syntax is destined for complicated
processing by Racket code, it is often better to parse it into an
intermediate representation using idiomatic Racket data structures,
such as lists, hashes, structs, and even objects.
Thus far we have only used syntax pattern variables and the
@scheme[#:with] keyword to bind attribues, and the values of the
attributes have always been syntax. To bind attributes to values other
than syntax, use the @scheme[#:attr] keyword.
@schemeblock[
(code:comment "A ForClause is either")
(code:comment " - (bind-clause (listof identifier) syntax)")
(code:comment " - (when-clause syntax)")
(struct bind-clause (vars seq-expr))
(struct when-clause (guard))
(define-splicing-syntax-class for-clause
#:attributes (ast)
(pattern [var:id seq:expr]
#:attr ast (bind-clause (list #'var) #'seq))
(pattern [(var:id ...) seq:expr]
#:attr ast (bind-clause (syntax->list #'(var ...))
#'seq))
(pattern (~seq #:when guard:expr)
#:attr ast (when-clause #'guard)))
]
Be careful! If we had used @scheme[#:with] instead of @scheme[#:attr],
the @scheme[#f] would have been coerced to a syntax object before
being matched against the pattern @scheme[default].
Attributes with non-syntax values cannot be used in syntax
templates. Use the @scheme[attribute] form to get the value of an
attribute.

27
collects/syntax/scribblings/parse/examples.scrbl Normal file
View File

@ -0,0 +1,27 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label racket/class))
@title[#:tag "stxparse-examples" #:style '(toc)]{Examples}
This section provides an extended introduction to
@schememodname[syntax/parse] as a series of worked examples.
@local-table-of-contents[]
@include-section["ex-mods-stxclasses.scrbl"]
@include-section["ex-kw-args.scrbl"]
@include-section["ex-uniform.scrbl"]
@include-section["ex-varied.scrbl"]
@include-section["ex-many-kws.scrbl"] @;{needs revision}
@include-section["ex-exprc.scrbl"]
@;{
@section{Communication via static bindings}
@section{Control: cut and commit}
@section{Analyzing expanded code}
}

258
collects/syntax/scribblings/parse/experimental.scrbl Normal file
View File

@ -0,0 +1,258 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt")
@title{Experimental}
The following facilities are experimental.
@section{Contracts for macro sub-expressions}
@defmodule[syntax/parse/experimental/contract]
Macros can apply contracts to their sub-expressions using the
@defidentifier[#'expr/c #:form? #t] syntax class.
@defproc[(expr/c [contract-expr syntax?]
[#:positive pos-blame 'use-site]
[#:negative neg-blame 'from-macro]
[#:name expr-name #f]
[#:macro macro-name #f]
[#:context ctx #f])
(attributes c)]{
Accepts an expression (@scheme[expr]) and computes an attribute
@scheme[c] that represents the expression wrapped with the contract
represented by @scheme[contract-expr].
See @secref{exprc} for an example.
}
@section{Contracts for syntax classes}
@defmodule[syntax/parse/experimental/provide]
@defform/subs[#:literals (syntax-class/c)
(provide-syntax-class/contract
[syntax-class-id syntax-class-contract] ...)
([syntax-class-contract
(syntax-class/c (mandatory-arg ...))
(syntax-class/c (mandatory-arg ...)
(optional-arg ...))]
[arg contract-expr (code:line keyword contract-expr)])
#:contracts ([contract-expr contract?])]{
Provides the syntax class (or splicing syntax class)
@scheme[syntax-class-id] with the given contracts imposed on its
formal parameters.
}
@defidform[syntax-class/c]{
Keyword recognized by @scheme[provide-syntax-class/contract].
}
@section{Reflection}
@defmodule[syntax/parse/experimental/reflect]
A syntax class can be reified into a run-time value, and a reified
syntax class can be used in a pattern via the @scheme[~reflect] and
@scheme[~splicing-reflect] pattern forms.
@defform[(reify-syntax-class syntax-class-id)]{
Reifies the syntax class named @scheme[syntax-class-id] as a run-time
value. The same form also handles splicing syntax classes. Syntax
classes with the @scheme[#:no-delimit-cut] option cannot be reified.
}
@deftogether[(
@defproc[(reified-syntax-class? [x any/c]) boolean?]
@defproc[(reified-splicing-syntax-class? [x any/c]) boolean?])]{
Returns @scheme[#t] if @scheme[x] is a reified (normal) syntax class
or a reified splicing syntax class, respectively.
}
@defproc[(reified-syntax-class-attributes
[r (or/c reified-syntax-class? reified-splicing-syntax-class?)])
(listof (list/c symbol? exact-nonnegative-integer?))]{
Returns the reified syntax class's attributes.
}
@deftogether[[
@defproc[(reified-syntax-class-arity
[r (or/c reified-syntax-class? reified-splicing-syntax-class?)])
procedure-arity?]
@defproc[(reified-syntax-class-keywords
[r (or/c reified-syntax-class? reified-splicing-syntax-class?)])
(values (listof keyword?) (listof keyword?))]]]{
Returns the reified syntax class's arity and keywords,
respectively. Compare with @scheme[procedure-arity] and
@scheme[procedure-keywords].
}
@defproc[(reified-syntax-class-curry
[r (or/c reified-syntax-class? reified-splicing-syntax-class?)]
[arg any/c] ...
[#:<kw> kw-arg any/c] ...)
(or/c reified-syntax-class? reified-splicing-syntax-class?)]{
Partially applies the reified syntax class to the given arguments. If
more arguments are given than the reified syntax class accepts, an
error is raised.
}
@schemegrammar*[#:literals (~reflect ~splicing-reflect)
[S-pattern ....
(~reflect var-id (reified-expr arg-expr ...) maybe-attrs)]
[H-pattern ....
(~splicing-reflect var-id (reified-expr arg-expr ...)
maybe-attrs)]]
@specsubform/subs[(@#,(defhere ~reflect) var-id (reified-expr arg-expr ...) maybe-attrs)
([maybe-attrs (code:line)
(code:line #:attributes (attr-arity-decl ...))])]{
Like @scheme[~var], except that the syntax class position is an
expression evaluating to a reified syntax object, not a syntax class
name, and the attributes bound by the reified syntax class (if any)
must be specified explicitly.
}
@specsubform[(@#,(defhere ~splicing-reflect) var-id (reified-expr arg-expr ...) maybe-attrs)]{
Like @scheme[~reflect] but for reified splicing syntax classes.
}
@myexamples[
(define-syntax-class (nat> x)
#:description (format "natural number greater than ~s" x)
#:attributes (diff)
(pattern n:nat
#:when (> (syntax-e #'n) x)
#:with diff (- (syntax-e #'n) x)))
(define-syntax-class (nat/mult x)
#:description (format "natural number multiple of ~s" x)
#:attributes (quot)
(pattern n:nat
#:when (zero? (remainder (syntax-e #'n) x))
#:with quot (quotient (syntax-e #'n) x)))
(define r-nat> (reify-syntax-class nat>))
(define r-nat/mult (reify-syntax-class nat/mult))
(define (partition/r stx r n)
(syntax-parse stx
[((~or (~reflect yes (r n)) no) ...)
#'((yes ...) (no ...))]))
(partition/r #'(1 2 3 4 5) r-nat> 3)
(partition/r #'(1 2 3 4 5) r-nat/mult 2)
(define (bad-attrs r)
(syntax-parse #'6
[(~reflect x (r 3) #:attributes (diff))
#'x.diff]))
(bad-attrs r-nat>)
(bad-attrs r-nat/mult)
]
@;{--------}
@section{Procedural splicing syntax classes}
@defmodule[syntax/parse/experimental/splicing]
@defform[(define-primitive-splicing-syntax-class (name-id param-id ...)
maybe-description maybe-attrs
parser-expr)
#:contracts ([parser (-> syntax?
(->* () ((or/c string? #f) -> any))
(list syntax? exact-positive-integer? any/c ...))])]{
Defines a splicing syntax via a procedural parser.
The parser procedure is given two arguments, the syntax to parse and a
failure procedure. To signal a successful parse, the parser procedure
returns a list of 2+@scheme[N] elements, where @scheme[N] is the
number of attributes declared by the splicing syntax class. The first
two elements are the unconsumed part of the syntax and the size of the
prefix consumed. The rest of the list contains the values of the
attributes.
To indicate failure, the parser calls the failure procedure with an
optional message argument.
}
@;{--------}
@section{Ellipsis-head alternative sets}
@defmodule[syntax/parse/experimental/eh]
Unlike @tech{@Spatterns} and @tech{@Hpatterns}, @tech{@EHpatterns}
cannot be encapsulated by syntax classes, since they describe not only
sets of terms but also repetition constraints.
This module provides @deftech{ellipsis-head alternative sets},
reusable encapsulations of @|EHpatterns|.
@defform/subs[#:literals (pattern)
(define-eh-alternative-set name eh-alternative ...)
([alternative (pattern EH-pattern)])]{
Defines @scheme[name] as an ellipsis-head alternative set. Using
@scheme[name] (via @scheme[~eh-var]) in an ellipsis-head pattern is
equivalent to including each of the alternatives in the pattern via
@ref[~or eh], except that the attributes bound by the alternatives are
prefixed with the name given to @scheme[~eh-var].
Unlike syntax classes, ellipsis-head alternative sets must be defined
before they are referenced.
}
@schemegrammar*[#:literals (~eh-var)
[EH-pattern ....
(~eh-var name eh-alternative-set-id)]]
@specsubform[(@#,(defhere ~eh-var) name eh-alternative-set-id)]{
Includes the alternatives of @scheme[eh-alternative-set-id], prefixing
their attributes with @scheme[name].
}
@myexamples[
(define-eh-alternative-set options
(pattern (~once (~seq #:a a:expr) #:name "#:a option"))
(pattern (~seq #:b b:expr)))
(define (parse/options stx)
(syntax-parse stx
[(_ (~eh-var s options) ...)
#'(s.a (s.b ...))]))
(parse/options #'(m #:a 1 #:b 2 #:b 3))
(parse/options #'(m #:a 1 #:a 2))
(define (parse/more-options stx)
(syntax-parse stx
[(_ (~or (~eh-var s options)
(~seq #:c c1:expr c2:expr))
...)
#'(s.a (s.b ...) ((c1 c2) ...))]))
(parse/more-options #'(m #:a 1 #:b 2 #:c 3 4 #:c 5 6))
(define-eh-alternative-set ext-options
(pattern (~eh-var s options))
(pattern (~seq #:c c1 c2)))
(syntax-parse #'(m #:a 1 #:b 2 #:c 3 4 #:c 5 6)
[(_ (~eh-var x ext-options) ...)
#'(x.s.a (x.s.b ...) ((x.c1 x.c2) ...))])
]

353
collects/syntax/scribblings/parse/intro.scrbl Normal file
View File

@ -0,0 +1,353 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label (only-in syntax/parse ...+)))
@(define-syntax-rule (defdummy id)
(defidentifier (quote-syntax id)
#:form? #t #:index? #f #:show-libs? #f))
@title[#:tag "stxparse-intro"]{Introduction}
@;{Dummy declaration}
@declare-exporting[syntax/scribblings/parse/parse-dummy-bindings]
This section provides an introduction to writing robust macros with
@scheme[syntax-parse] and syntax classes.
The task is to write a macro named @scheme[mylet] that has the same
syntax and behavior as Racket's @scheme[let] form. The macro should
good error messages when used incorrectly.
Here is the specification of @scheme[mylet]'s syntax:
@;{bleh!}
@specform[#:literals (mylet)
(code:line (@#,(defdummy mylet) ([var-id rhs-expr] ...) body ...+)
(mylet loop-id ([var-id rhs-expr] ...) body ...+))]
For simplicify, we handle only the first case for now. We return to
the second case later in the introduction.
First, we import @scheme[syntax-parse] @scheme[for-syntax], since we
will use it to implement a macro transformer.
@myinteraction[(require (for-syntax syntax/parse))]
We get the first version of @scheme[mylet] by essentially
transliterating the syntax specification above. The result is similar
to what one would write using @scheme[syntax-rules] or perhaps
@scheme[syntax-case].
@myinteraction[
(define-syntax (mylet stx)
(syntax-parse stx
[(_ ([var-id rhs-expr] ...) body ...+)
#'((lambda (var-id ...) body ...) rhs-expr ...)]))
]
Note the use of @scheme[...] and @scheme[...+] in the pattern;
@scheme[...] means match zero or more repetitions of the preceeding
pattern; @scheme[...+] means match one or more. Only @scheme[...] may
be used in the template, however.
@myinteraction[
(mylet ([a 1] [b 2]) (+ a b))
(mylet (b 2) (sub1 b))
(mylet ([1 a]) (add1 a))
(mylet ([#:x 1] [y 2]) (* x y))
]
When used correctly, the macro works, but it behaves very badly in the
presence of errors. In some cases, @scheme[mylet] blithely accepts
illegal syntax and passes it along to @scheme[lambda], with strange
consequences.
These examples of illegal syntax are not to suggest that a typical
programmer would make such mistakes attempting to use
@scheme[mylet]. At least, not often. After an initial learning
curve. But macros are also used by inexpert programmers and as targets
of other macros (or code generators), and many macros are far more
complex than @scheme[mylet]. Macros must validate their syntax and
report appropriate errors. Furthermore, the macro writer benefits from
the @emph{machine-checked} specification of syntax in the form of more
readable, maintainable code.
The first step toward validation and high-quality error reporting is
annotating each of the macro's pattern variables with the @tech{syntax
class} that describes its acceptable syntax. In @scheme[mylet], each
variable must be an @scheme[identifier] (@scheme[id] for short) and
each right-hand side must be an @scheme[expr] (expression). An
@tech{annotated pattern variable} is written by concatenating the
pattern variable name, a colon character, and the syntax class
name.@margin-note*{For an alternative to the ``colon'' syntax, see the
@scheme[~var] pattern form.}
@myinteraction[
(define-syntax (mylet stx)
(syntax-parse stx
[(_ ((var:id rhs:expr) ...) body ...+)
#'((lambda (var ...) body ...) rhs ...)]))
]
Note that the syntax class annotations do not appear in the template
(i.e., @scheme[var], not @scheme[var:id]).
The syntax class annotations are checked when we use the macro.
@myinteraction[
(mylet ([a 1] [b 2]) (+ a b))
(mylet (["a" 1]) (add1 a))
]
The @scheme[expr] syntax class does not actually check that the term
it matches is a valid expression---that would require calling that
macro expander. Instead, @scheme[expr] just means not a keyword.
@myinteraction[
(mylet ([a #:whoops]) 1)
]
Also, @scheme[syntax-parse] knows how to report a few kinds of errors
without any help:
@myinteraction[
(mylet ([a 1 2]) (* a a))
]
There are other kinds of errors, however, that this macro does not
handle gracefully:
@myinteraction[
(mylet (a 1) (+ a 2))
]
It's too much to ask for the macro to respond, ``This expression is
missing a pair of parentheses around @scheme[(a 1)].'' The pattern
matcher is not that smart. But it can pinpoint the source of the
error: when it encountered @scheme[a] it was expecting what we might
call a ``binding pair,'' but that term is not in its vocabulary yet.
To allow @scheme[syntax-parse] to synthesize better errors, we must
attach @emph{descriptions} to the patterns we recognize as discrete
syntactic categories. One way of doing that is by defining new syntax
classes:@margin-note*{Another way is the @scheme[~describe] pattern
form.}
@myinteraction[
(define-syntax (mylet stx)
(define-syntax-class binding
#:description "binding pair"
(pattern (var:id rhs:expr)))
(syntax-parse stx
[(_ (b:binding ...) body ...+)
#'((lambda (b.var ...) body ...) b.rhs ...)]))
]
Note that we write @scheme[b.var] and @scheme[b.rhs] now. They are the
@tech{nested attributes} formed from the annotated pattern variable
@scheme[b] and the attributes @scheme[var] and @scheme[rhs] of the
syntax class @scheme[binding].
Now the error messages can talk about ``binding pairs.''
@myinteraction[
(mylet (a 1) (+ a 2))
]
Errors are still reported in more specific terms when possible:
@myinteraction[
(mylet (["a" 1]) (+ a 2))
]
There is one other constraint on the legal syntax of
@scheme[mylet]. The variables bound by the different binding pairs
must be distinct. Otherwise the macro creates an illegal
@scheme[lambda] form:
@myinteraction[
(mylet ([a 1] [a 2]) (+ a a))
]
Constraints such as the distinctness requirement are expressed as side
conditions, thus:
@myinteraction[
(define-syntax (mylet stx)
(define-syntax-class binding
#:description "binding pair"
(pattern (var:id rhs:expr)))
(syntax-parse stx
[(_ (b:binding ...) body ...+)
#:fail-when (check-duplicate-identifier
(syntax->list #'(b.var ...)))
"duplicate variable name"
#'((lambda (b.var ...) body ...) b.rhs ...)]))
]
@myinteraction[
(mylet ([a 1] [a 2]) (+ a a))
]
The @scheme[#:fail-when] keyword is followed by two expressions: the
condition and the error message. When the condition evaluates to
anything but @scheme[#f], the pattern fails. Additionally, if the
condition evaluates to a syntax object, that syntax object is used to
pinpoint the cause of the failure.
Syntax classes can have side conditions, too. Here is the macro
rewritten to include another syntax class representing a ``sequence of
distinct binding pairs.''
@myinteraction[
(define-syntax (mylet stx)
(define-syntax-class binding
#:description "binding pair"
(pattern (var:id rhs:expr)))
(define-syntax-class distinct-bindings
#:description "sequence of distinct binding pairs"
(pattern (b:binding ...)
#:fail-when (check-duplicate-identifier
(syntax->list #'(b.var ...)))
"duplicate variable name"
#:with (var ...) #'(b.var ...)
#:with (rhs ...) #'(b.rhs ...)))
(syntax-parse stx
[(_ bs:distinct-bindings . body)
#'((lambda (bs.var ...) . body) bs.rhs ...)]))
]
Here we've introduced the @scheme[#:with] clause. A @scheme[#:with]
clause matches a pattern with a computed term. Here we use it to bind
@scheme[var] and @scheme[rhs] as attributes of
@scheme[distinct-bindings]. By default, a syntax class only exports
its patterns' pattern variables as attributes, not their nested
attributes.@margin-note*{The alternative would be to explicitly declare
the attributes of @scheme[distinct-bindings] to include the nested
attributes @scheme[b.var] and @scheme[b.rhs], using the
@scheme[#:attribute] option. Then the macro would refer to
@scheme[bs.b.var] and @scheme[bs.b.rhs].}
Alas, so far the macro only implements half of the functionality
offered by Racket's @scheme[let]. We must add the
``named-@scheme[let]'' form. That turns out to be as simple as adding
a new clause:
@myinteraction[
(define-syntax (mylet stx)
(define-syntax-class binding
#:description "binding pair"
(pattern (var:id rhs:expr)))
(define-syntax-class distinct-bindings
#:description "sequence of distinct binding pairs"
(pattern (b:binding ...)
#:fail-when (check-duplicate-identifier
(syntax->list #'(b.var ...)))
"duplicate variable name"
#:with (var ...) #'(b.var ...)
#:with (rhs ...) #'(b.rhs ...)))
(syntax-parse stx
[(_ bs:distinct-bindings body ...+)
#'((lambda (bs.var ...) body ...) bs.rhs ...)]
[(_ loop:id bs:distinct-bindings body ...+)
#'(letrec ([loop (lambda (bs.var ...) body ...)])
(loop bs.rhs ...))]))
]
We are able to reuse the @scheme[distinct-bindings] syntax class, so
the addition of the ``named-@scheme[let]'' syntax requires only three
lines.
But does adding this new case affect @scheme[syntax-parse]'s ability
to pinpoint and report errors?
@myinteraction[
(mylet ([a 1] [b 2]) (+ a b))
(mylet (["a" 1]) (add1 a))
(mylet ([a #:whoops]) 1)
(mylet ([a 1 2]) (* a a))
(mylet (a 1) (+ a 2))
(mylet ([a 1] [a 2]) (+ a a))
]
The error reporting for the original syntax seems intact. We should
verify that the named-@scheme[let] syntax is working, that
@scheme[syntax-parse] is not simply ignoring that clause.
@myinteraction[
(mylet loop ([a 1] [b 2]) (+ a b))
(mylet loop (["a" 1]) (add1 a))
(mylet loop ([a #:whoops]) 1)
(mylet loop ([a 1 2]) (* a a))
(mylet loop (a 1) (+ a 2))
(mylet loop ([a 1] [a 2]) (+ a a))
]
How does @scheme[syntax-parse] decide which clause the programmer was
attempting, so it can use it as a basis for error reporting? After
all, each of the bad uses of the named-@scheme[let] syntax are also
bad uses of the normal syntax, and vice versa. And yet the macro doen
not produce errors like ``@scheme[mylet]: expected sequence of
distinct binding pairs at: @scheme[loop].''
The answer is that @scheme[syntax-parse] records a list of all the
potential errors (including ones like @scheme[loop] not matching
@scheme[distinct-binding]) along with the @emph{progress} made before
each error. Only the error with the most progress is reported.
For example, in this bad use of the macro,
@myinteraction[
(mylet loop (["a" 1]) (add1 a))
]
there are two potential errors: expected @scheme[distinct-bindings] at
@scheme[loop] and expected @scheme[identifier] at @scheme["a"]. The
second error occurs further in the term than the first, so it is
reported.
For another example, consider this term:
@myinteraction[
(mylet (["a" 1]) (add1 a))
]
Again, there are two potential errors: expected @scheme[identifier] at
@scheme[(["a" 1])] and expected @scheme[identifier] at
@scheme["a"]. They both occur at the second term (or first argument,
if you prefer), but the second error occurs deeper in the
term. Progress is based on a left-to-right traversal of the syntax.
A final example: consider the following:
@myinteraction[
(mylet ([a 1] [a 2]) (+ a a))
]
There are two errors again: duplicate variable name at @scheme[([a 1]
[a 2])] and expected @scheme[identifier] at @scheme[([a 1] [a
2])]. Note that as far as @scheme[syntax-parse] is concerned, the
progress associated with the duplicate error message is the second
term (first argument), not the second occurrence of @scheme[a]. That's
because the check is associated with the entire
@scheme[distinct-bindings] pattern. It would seem that both errors
have the same progress, and yet only the first one is reported. The
difference between the two is that the first error is from a
@emph{post-traversal} check, whereas the second is from a normal
(i.e., pre-traversal) check. A post-traveral check is considered to
have made more progress than a pre-traversal check of the same term;
indeed, it also has greater progress than any failure @emph{within}
the term.
It is, however, possible for multiple potential errors to occur with
the same progress. Here's one example:
@myinteraction[
(mylet "not-even-close")
]
In this case @scheme[syntax-parse] reports both errors.
Even with all of the annotations we have added to our macro, there are
still some misuses that defy @scheme[syntax-parse]'s error reporting
capabilities, such as this example:
@myinteraction[
(mylet)
]
The philosophy behind @scheme[syntax-parse] is that in these
situations, a generic error such as ``bad syntax'' is justified. The
use of @scheme[mylet] here is so far off that the only informative
error message would include a complete recapitulation of the syntax of
@scheme[mylet]. That is not the role of error messages, however; it is
the role of documentation.
This section has provided an introduction to syntax classes, side
conditions, and progress-ordered error reporting. But
@scheme[syntax-parse] has many more features. Continue to the
@secref{stxparse-examples} section for samples of other features in
working code, or skip to the subsequent sections for the complete
reference documentation.

75
collects/syntax/scribblings/parse/lib.scrbl Normal file
View File

@ -0,0 +1,75 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt"
(for-label syntax/kerncase))
@title[#:tag "stxparse-lib"]{Library syntax classes and literal sets}
@section{Syntax classes}
@(begin
(define-syntax-rule (defstxclass name . pre-flows)
(defidform name . pre-flows))
(define-syntax-rule (defstxclass* (name arg ...) . pre-flows)
(defform (name arg ...) . pre-flows)))
@defstxclass[expr]{
Matches anything except a keyword literal (to distinguish expressions
from the start of a keyword argument sequence). The term is not
otherwise inspected, since it is not feasible to check if it is
actually a valid expression.
}
@deftogether[(
@defstxclass[identifier]
@defstxclass[boolean]
@defstxclass[str]
@defstxclass[char]
@defstxclass[keyword]
@defstxclass[number]
@defstxclass[integer]
@defstxclass[exact-integer]
@defstxclass[exact-nonnegative-integer]
@defstxclass[exact-positive-integer])]{
Match syntax satisfying the corresponding predicates.
}
@defstxclass[id]{ Alias for @scheme[identifier]. }
@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. }
@defproc[(static [predicate (-> any/c any/c)]
[description (or/c string? #f)])
(attributes value)]{
The @defidentifier[#'static #:form? #t] syntax class matches an
identifier that is bound in the syntactic environment to static
information (see @scheme[syntax-local-value]) satisfying the given
@scheme[predicate]. If the term does not match, the
@scheme[description] argument is used to describe the expected syntax.
When used outside of the dynamic extent of a macro transformer (see
@scheme[syntax-transforming?]), matching fails.
The attribute @var[value] contains the value the name is bound to.
}
@section{Literal sets}
@defidform[kernel-literals]{
Literal set containing the identifiers for fully-expanded code
(@secref[#:doc '(lib "scribblings/reference/reference.scrbl")
"fully-expanded"]). The set contains all of the forms listed by
@scheme[kernel-form-identifier-list], plus @scheme[module],
@scheme[#%plain-module-begin], @scheme[#%require], and
@scheme[#%provide].
Note that the literal-set uses the names @scheme[#%plain-lambda] and
@scheme[#%plain-app], not @scheme[lambda] and @scheme[#%app].
}

122
collects/syntax/scribblings/parse/litconv.scrbl Normal file
View File

@ -0,0 +1,122 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt")
@title[#:tag "stxparse-litconv"]{Literal sets and Conventions}
Sometimes the same literals are recognized in a number of different
places. The most common example is the literals for fully expanded
programs, which are used in many analysis and transformation
tools. Specifying literals individually is burdensome and error-prone.
As a remedy, @schememodname[syntax/parse] offers @deftech{literal
sets}. A literal set is defined via @scheme[define-literal-set] and
used via the @scheme[#:literal-set] option of @scheme[syntax-parse].
@defform/subs[(define-literal-set name-id (literal ...))
([literal literal-id
(pattern-id literal-id)])]{
Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal]
can have a separate @scheme[pattern-id] and @scheme[literal-id]. The
@scheme[pattern-id] determines what identifiers in the pattern are
treated as literals. The @scheme[literal-id] determines what
identifiers the literal matches.
@myexamples[
(define-literal-set def-litset
(define-values define-syntaxes))
(syntax-parse #'(define-syntaxes (x) 12)
#:literal-sets (def-litset)
[(define-values (x:id ...) e:expr) 'v]
[(define-syntaxes (x:id ...) e:expr) 's])
]
The literals in a literal set always refer to the phase-0 bindings of
the enclosing module. For example:
@myexamples[
(module common racket/base
(define x 'something)
(provide x))
(module lits racket/base
(require syntax/parse 'common)
(define-literal-set common-lits (x))
(provide common-lits))
]
In the literal set @scheme[common-lits], the literal @scheme[x] always
recognizes identifiers bound to the variable @scheme[x] defined in
module @schememodname['common].
When a literal set is used with the @scheme[#:phase phase-expr]
option, the literals' fixed bindings are compared against the binding of
the input literal at the specified phase. Continuing the example:
@myexamples[
(require syntax/parse 'lits (for-syntax 'common))
(syntax-parse #'x #:literal-sets ([common-lits #:phase 1])
[x 'yes]
[_ 'no])
]
The occurrence of @scheme[x] in the pattern matches any identifier
whose binding at phase 1 is the @scheme[x] from module
@schememodname['common].
}
@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 ...)])]{
Defines @deftech{conventions} that supply default syntax classes for
pattern variables. A pattern variable that has no explicit syntax
class is checked against each @scheme[id-pattern], and the first one
that matches determines the syntax class for the pattern. If no
@scheme[id-pattern] matches, then the pattern variable has no syntax
class.
@myexamples[
(define-conventions xyz-as-ids
[x id] [y id] [z id])
(syntax-parse #'(a b c 1 2 3)
#:conventions (xyz-as-ids)
[(x ... n ...) (syntax->datum #'(x ...))])
(define-conventions xn-prefixes
[#rx"^x" id]
[#rx"^n" nat])
(syntax-parse #'(a b c 1 2 3)
#:conventions (xn-prefixes)
[(x0 x ... n0 n ...)
(syntax->datum #'(x0 (x ...) n0 (n ...)))])
]
Local conventions, introduced with the @scheme[#:local-conventions]
keyword argument of @scheme[syntax-parse] and syntax class
definitions, may refer to local bindings:
@myexamples[
(define-syntax-class (nat> bound)
(pattern n:nat
#:fail-unless (> (syntax-e #'n) bound)
(format "expected number > ~s" bound)))
(define-syntax-class (natlist> bound)
#:local-conventions ([N (nat> bound)])
(pattern (N ...)))
(define (parse-natlist> bound x)
(syntax-parse x
#:local-conventions ([NS (natlist> bound)])
[NS 'ok]))
(parse-natlist> 0 #'(1 2 3))
(parse-natlist> 5 #'(8 6 4 2))
]
}

116
collects/syntax/scribblings/parse/parse-common.rkt Normal file
View File

@ -0,0 +1,116 @@
#lang racket/base
(require scribble/manual
scribble/eval
racket/sandbox)
(provide ellipses
the-eval
myexamples
myinteraction)
(define ellipses (scheme ...))
(define (fixup exn)
(let ([src (ormap values (exn:fail:syntax-exprs exn))])
(if src
(make-exn:fail:syntax
(format "~a at: ~s" (exn-message exn) (syntax->datum src))
(exn-continuation-marks exn)
(exn:fail:syntax-exprs exn))
exn)))
(define the-eval
(parameterize ((sandbox-output 'string)
(sandbox-error-output 'string)
(sandbox-make-code-inspector current-code-inspector)
(sandbox-eval-handlers
(list #f
(lambda (thunk)
(with-handlers ([exn:fail:syntax?
(lambda (e) (raise (fixup e)))])
(thunk))))))
(make-evaluator 'racket/base
#:requires (let ([mods '(syntax/parse
syntax/parse/debug
syntax/parse/experimental/splicing
syntax/parse/experimental/contract
syntax/parse/experimental/reflect
syntax/parse/experimental/eh)])
`((for-syntax racket/base ,@mods)
,@mods)))))
(the-eval '(error-print-source-location #f))
(define-syntax-rule (myexamples e ...)
(examples #:eval the-eval e ...))
(define-syntax-rule (myinteraction e ...)
(interaction #:eval the-eval e ...))
;; ----
(define Spattern "single-term pattern")
(define Lpattern "list pattern")
(define Hpattern "head pattern")
(define EHpattern "ellipsis-head pattern")
(define Apattern "action pattern")
(define Spatterns "single-term patterns")
(define Lpatterns "list patterns")
(define Hpatterns "head patterns")
(define EHpatterns "ellipsis-head patterns")
(define Apatterns "action patterns")
(provide Spattern
Lpattern
Hpattern
EHpattern
Apattern
Spatterns
Lpatterns
Hpatterns
EHpatterns
Apatterns)
;; ----
(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t))
(define-syntax ref
(syntax-rules ()
[(ref id suffix ...)
(elemref (list 'pattern-link (list 'id 'suffix ...))
(schemekeywordfont (symbol->string 'id))
(superscript (symbol->string 'suffix)) ...
#:underline? #f)]))
(define-syntax def
(syntax-rules ()
[(def id suffix ...)
(elemtag (list 'pattern-link (list 'id 'suffix ...))
(scheme id)
#|(superscript (symbol->string 'suffix)) ...|# )]))
(provide defhere
ref
def)
;; ----
(require (for-label racket/base
racket/contract
(except-in syntax/parse ...+)
syntax/parse/debug
syntax/parse/experimental/contract
syntax/parse/experimental/splicing
syntax/parse/experimental/reflect
syntax/parse/experimental/provide
syntax/parse/experimental/eh
"parse-dummy-bindings.rkt"))
(provide (for-label (all-from-out racket/base)
(all-from-out racket/contract)
(all-from-out syntax/parse)
(all-from-out syntax/parse/debug)
(all-from-out syntax/parse/experimental/contract)
(all-from-out syntax/parse/experimental/splicing)
(all-from-out syntax/parse/experimental/reflect)
(all-from-out syntax/parse/experimental/provide)
(all-from-out syntax/parse/experimental/eh)
(all-from-out "parse-dummy-bindings.rkt")))

4
collects/syntax/scribblings/parse/parse-dummy-bindings.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(provide mylet)
(define mylet 'dummy-binding)

462
collects/syntax/scribblings/parse/parsing.scrbl Normal file
View File

@ -0,0 +1,462 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
"parse-common.rkt")
@title[#:tag "stxparse-parsing"]{Parsing and classifying syntax}
This section describes @schememodname[syntax/parse]'s facilities for
parsing and classifying syntax. These facilities use a common language
of @tech{syntax patterns}, which is described in detail in the next
section, @secref{stxparse-patterns}.
@declare-exporting[syntax/parse]
@section{Parsing syntax}
Two parsing forms are provided: @scheme[syntax-parse] and
@scheme[syntax-parser].
@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+)
([parse-option (code:line #:context context-expr)
(code:line #:literals (literal ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[literal literal-id
(pattern-id literal-id)
(pattern-id literal-id #:phase phase-expr)]
[literal-set literal-set-id
(literal-set-id literal-set-option ...)]
[literal-set-option (code:line #:at context-id)
(code:line #:phase phase-expr)]
[clause (syntax-pattern pattern-directive ... expr ...+)])
#:contracts ([stx-expr syntax?]
[context-expr syntax?]
[phase-expr (or/c exact-integer? #f)])]{
Evaluates @scheme[stx-expr], which should produce a syntax object, and
matches it against the @scheme[clause]s in order. If some clause's
pattern matches, its attributes are bound to the corresponding
subterms of the syntax object and that clause's side conditions and
@scheme[expr] is evaluated. The result is the result of @scheme[expr].
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.
The following options are supported:
@specsubform[(code:line #:context context-expr)
#:contracts ([context-expr syntax?])]{
When present, @scheme[context-expr] is used in reporting parse
failures; otherwise @scheme[stx-expr] is used.
@(myexamples
(syntax-parse #'(a b 3)
[(x:id ...) 'ok])
(syntax-parse #'(a b 3)
#:context #'(lambda (a b 3) (+ a b))
[(x:id ...) 'ok]))
}
@specsubform/subs[(code:line #:literals (literal ...))
([literal literal-id
(pattern-id literal-id)
(pattern-id literal-id #:phase phase-expr)])
#:contracts ([phase-expr (or/c exact-integer? #f)])]{
@margin-note*{
Unlike @scheme[syntax-case], @scheme[syntax-parse] requires all
literals to have a binding. To match identifiers by their symbolic
names, use the @scheme[~datum] pattern form instead.
}
@;
The @scheme[#:literals] option specifies identifiers that should be
treated as @tech{literals} rather than @tech{pattern variables}. An
entry in the literals list has two components: the identifier used
within the pattern to signify the positions to be matched
(@scheme[pattern-id]), and the identifier expected to occur in those
positions (@scheme[literal-id]). If the entry is a single identifier,
that identifier is used for both purposes.
If the @scheme[#:phase] option is given, then the literal is compared
at phase @scheme[phase-expr]. Specifically, the binding of the
@scheme[literal-id] at phase @scheme[phase-expr] must match the
input's binding at phase @scheme[phase-expr].
}
@specsubform/subs[(code:line #:literal-sets (literal-set ...))
([literal-set literal-set-id
(literal-set-id literal-set-option ...)]
[literal-set-option (code:line #:at context-id)
(code:line #:phase phase-expr)])
#:contracts ([phase-expr (or/c exact-integer? #f)])]{
Many literals can be declared at once via one or more @tech{literal
sets}, imported with the @scheme[#:literal-sets] option. See
@tech{literal sets} for more information.
}
@specsubform[(code:line #:conventions (conventions-id ...))]{
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. See the section on @tech{conventions} for examples.
}
Each clause consists of a @tech{syntax pattern}, an optional sequence
of @tech{pattern directives}, and a non-empty sequence of body
expressions.
}
@defform[(syntax-parser parse-option ... clause ...+)]{
Like @scheme[syntax-parse], but produces a matching procedure. The
procedure accepts a single argument, which should be a syntax object.
}
@;{----------}
@section{Classifying syntax}
Syntax classes provide an abstraction mechanism for @tech{syntax
patterns}. Built-in syntax classes are supplied that recognize basic
classes such as @scheme[identifier] and @scheme[keyword]. Programmers
can compose basic syntax classes to build specifications of more
complex syntax, such as lists of distinct identifiers and formal
arguments with keywords. Macros that manipulate the same syntactic
structures can share syntax class definitions.
@defform*/subs[#:literals (pattern)
[(define-syntax-class name-id stxclass-option ...
stxclass-variant ...+)
(define-syntax-class (name-id . kw-formals) stxclass-option ...
stxclass-variant ...+)]
([stxclass-option
(code:line #:attributes (attr-arity-decl ...))
(code:line #:description description-expr)
(code:line #:opaque)
(code:line #:commit)
(code:line #:no-delimit-cut)
(code:line #:literals (literal-entry ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[attr-arity-decl
attr-name-id
(attr-name-id depth)]
[stxclass-variant
(pattern syntax-pattern pattern-directive ...)])
#:contracts ([description-expr (or/c string? #f)])]{
Defines @scheme[name-id] as a @deftech{syntax class}, which
encapsulates one or more @tech{single-term patterns}.
A syntax class may have formal parameters, in which case they are
bound as variables in the body. Syntax classes support optional
arguments and keyword arguments using the same syntax as
@scheme[lambda]. The body of the syntax-class definition contains a
non-empty sequence of @scheme[pattern] variants.
The following options are supported:
@specsubform/subs[(code:line #:attributes (attr-arity-decl ...))
([attr-arity-decl attr-id
(attr-id depth)])]{
Declares the attributes of the syntax class. An attribute arity
declaration consists of the attribute name and optionally its ellipsis
depth (zero if not explicitly specified).
If the attributes are not explicitly listed, they are inferred as the
set of all @tech{pattern variables} occurring in every variant of the
syntax class. Pattern variables that occur at different ellipsis
depths are not included, nor are nested attributes from
@tech{annotated pattern variables}.
}
@specsubform[(code:line #:description description-expr)
#:contracts ([description-expr (or/c string? #f)])]{
The @scheme[description] argument is evaluated in a scope containing
the syntax class's parameters. If the result is a string, it is used
in error messages involving the syntax class. For example, if a term
is rejected by the syntax class, an error of the form
@schemevalfont{"expected @scheme[description]"} may be synthesized. If
the result is @scheme[#f], the syntax class is skipped in the search
for a description to report.
If the option is not given absent, the name of the syntax class is
used instead.
}
@specsubform[#:opaque]{
Indicates that errors should not be reported with respect to the
internal structure of the syntax class.
}
@specsubform[#:commit]{
Directs the syntax class to ``commit'' to the first successful
match. When a variant succeeds, all choice points within the syntax
class are discarded. See also @scheme[~commit].
}
@specsubform[#:no-delimit-cut]{
By default, a cut (@scheme[~!]) within a syntax class only discards
choice points within the syntax class. That is, the body of the syntax
class acts as though it is wrapped in a @scheme[~delimit-cut] form. If
@scheme[#:no-delimit-cut] is specified, a cut may affect choice points
of the syntax class's calling context (another syntax class's patterns
or a @scheme[syntax-parse] form).
It is an error to use both @scheme[#:commit] and
@scheme[#:no-delimit-cut].
}
@specsubform[(code:line #:literals (literal-entry))]
@specsubform[(code:line #:literal-sets (literal-set ...))]
@specsubform[(code:line #:conventions (convention-id ...))]{
Declares the literals and conventions that apply to the syntax class's
variant patterns and their immediate @scheme[#:with] clauses. Patterns
occuring within subexpressions of the syntax class (for example, on
the right-hand side of a @scheme[#:fail-when] clause) are not
affected.
These options have the same meaning as in @scheme[syntax-parse].
}
Each variant of a syntax class is specified as a separate
@scheme[pattern]-form whose syntax pattern is a @tech{single-term
pattern}.
}
@defform*[#:literals (pattern)
[(define-splicing-syntax-class name-id stxclass-option ...
stxclass-variant ...+)
(define-splicing-syntax-class (name-id kw-formals) stxclass-option ...
stxclass-variant ...+)]]{
Defines @scheme[name-id] as a @deftech{splicing syntax class},
analogous to a @tech{syntax class} but encapsulating @tech{head
patterns} rather than @tech{single-term patterns}.
The options are the same as for @scheme[define-syntax-class].
Each variant of a splicing syntax class is specified as a separate
@scheme[pattern]-form whose syntax pattern is a @tech{head pattern}.
}
@defform[#:literals (pattern)
(pattern syntax-pattern pattern-directive ...)]{
Used to indicate a variant of a syntax class or splicing syntax
class. The variant accepts syntax matching the given syntax pattern
with the accompanying @tech{pattern directives}.
When used within @scheme[define-syntax-class], @scheme[syntax-pattern]
should be a @tech{single-term pattern}; within
@scheme[define-splicing-syntax-class], it should be a @tech{head
pattern}.
The attributes of the variant are the attributes of the pattern
together with all attributes bound by @scheme[#:with] clauses,
including nested attributes produced by syntax classes associated with
the pattern variables.
}
@;{--------}
@subsection{Pattern directives}
Both the parsing forms and syntax class definition forms support
@deftech{pattern directives} for annotating syntax patterns and
specifying side conditions. The grammar for pattern directives
follows:
@schemegrammar[pattern-directive
(code:line #:declare pattern-id syntax-class-id)
(code:line #:declare pattern-id (syntax-class-id arg ...))
(code:line #:with syntax-pattern expr)
(code:line #:attr attr-id expr)
(code:line #:fail-when condition-expr message-expr)
(code:line #:fail-unless condition-expr message-expr)
(code:line #:when condition-expr)
(code:line #:do [def-or-expr ...])]
@specsubform[(code:line #:declare pvar-id syntax-class-id)]
@specsubform[(code:line #:declare pvar-id (syntax-class-id arg ...))]{
The first form is equivalent to using the
@svar[pvar-id:syntax-class-id] form in the pattern (but it is illegal
to use both for the same pattern variable).
The second form allows the use of parameterized syntax classes, which
cannot be expressed using the ``colon'' notation. The @scheme[arg]s
are evaluated outside the scope of any of the attribute bindings from
pattern that the @scheme[#:declare] directive applies to. Keyword
arguments are supported, using the same syntax as in @scheme[#%app].
}
@specsubform[(code:line #:with syntax-pattern stx-expr)]{
Evaluates the @scheme[stx-expr] in the context of all previous
attribute bindings and matches it against the pattern. If the match
succeeds, the pattern's attributes are added to environment for the
evaluation of subsequent side conditions. If the @scheme[#:with] match
fails, the matching process backtracks. Since a syntax object may
match a pattern in several ways, backtracking may cause the same
clause to be tried multiple times before the next clause is reached.
}
@specsubform[(code:line #:attr attr-id expr)]{
Evaluates the @scheme[expr] in the context of all previous attribute
bindings and binds it to the attribute named by @scheme[attr-id]. The
value of @scheme[expr] need not be syntax.
}
@specsubform[(code:line #:fail-when condition-expr message-expr)
#:contracts ([message-expr (or/c string? #f)])]{
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is any true value (not @scheme[#f]),
the matching process backtracks (with the given message); otherwise,
it continues. If the value of the condition expression is a syntax
object, it is indicated as the cause of the error.
If the @scheme[message-expr] produces a string it is used as the
failure message; otherwise the failure is reported in terms of the
enclosing descriptions.
}
@specsubform[(code:line #:fail-unless condition-expr message-expr)
#:contracts ([message-expr (or/c string? #f)])]{
Like @scheme[#:fail-when] with the condition negated.
}
@specsubform[(code:line #:when condition-expr)]{
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is @scheme[#f], the matching process
backtracks. In other words, @scheme[#:when] is like
@scheme[#:fail-unless] without the message argument.
}
@specsubform[(code:line #:do [def-or-expr ...])]{
Takes a sequence of definitions and expressions, which may be
intermixed, and evaluates them in the scope of all previous attribute
bindings. The names bound by the definitions are in scope in
the expressions of subsequent patterns and clauses.
There is currently no way to bind attributes using a @scheme[#:do]
block. It is an error to shadow an attribute binding with a definition
in a @scheme[#:do] block.
}
@;{----------}
@section{Pattern variables and attributes}
An @deftech{attribute} is a name bound by a syntax pattern. An
attribute can be a @tech{pattern variable} itself, or it can be a
@tech{nested attribute} bound by an @tech{annotated pattern
variable}. The name of a nested attribute is computed by concatenating
the pattern variable name with the syntax class's exported attribute's
name, separated by a dot (see the example below).
Attribute names cannot be used directly as expressions; that is,
attributes are not variables. Instead, an attribute's value can be
gotten using the @scheme[attribute] special form.
@defform[(attribute attr-id)]{
Returns the value associated with the attribute named
@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an
error is raised.
}
The value of an attribute need not be syntax. Non-syntax-valued
attributes can be used to return a parsed representation of a subterm
or the results of an analysis on the subterm. A non-syntax-valued
attribute should be bound using the @scheme[#:attr] directive or a
@scheme[~bind] pattern.
@myexamples[
(define-syntax-class table
(pattern ((key value) ...)
#:attr hash
(for/hash ([k (syntax->datum #'(key ...))]
[v (syntax->datum #'(value ...))])
(values k v))))
(syntax-parse #'((a 1) (b 2) (c 3))
[t:table
(attribute t.hash)])
]
A syntax-valued attribute is an attribute whose value is a syntax
object or a syntax list of the appropriate @tech{ellipsis
depth}. Syntax-valued attributes can be used within @scheme[syntax],
@scheme[quasisyntax], etc as part of a syntax template. If a
non-syntax-valued attribute is used in a syntax template, a runtime
error is signalled.
@myexamples[
(syntax-parse #'((a 1) (b 2) (c 3))
[t:table
#'(t.key ...)])
(syntax-parse #'((a 1) (b 2) (c 3))
[t:table
#'t.hash])
]
Every attribute has an associated @deftech{ellipsis depth} that
determines how it can be used in a syntax template (see the discussion
of ellipses in @scheme[syntax]). For a pattern variable, the ellipsis
depth is the number of ellipses the pattern variable ``occurs under''
in the pattern. For a nested attribute the depth is the sum of the
pattern variable's depth and the depth of the attribute in the syntax
class. Consider the following code:
@schemeblock[
(define-syntax-class quark
(pattern (a b ...)))
(syntax-parse some-term
[(x (y:quark ...) ... z:quark)
some-code])
]
The syntax class @scheme[quark] exports two attributes: @scheme[a] at
depth 0 and @scheme[b] at depth 1. The @scheme[syntax-parse] pattern
has three pattern variables: @scheme[x] at depth 0, @scheme[y] at
depth 2, and @scheme[z] at depth 0. Since @scheme[x] and @scheme[y]
are annotated with the @scheme[quark] syntax class, the pattern also
binds the following nested attributes: @scheme[y.a] at depth 2,
@scheme[y.b] at depth 3, @scheme[z.a] at depth 0, and @scheme[z.b] at
depth 1.
An attribute's ellipsis nesting depth is @emph{not} a guarantee that
its value has that level of list nesting. In particular, @scheme[~or]
and @scheme[~optional] patterns may result in attributes with fewer
than expected levels of list nesting.
@(myexamples
(syntax-parse #'(1 2 3)
[(~or (x:id ...) _)
(attribute x)]))

291
collects/syntax/scribblings/parse-patterns.scrbl → collects/syntax/scribblings/parse/patterns.scrbl
View File

@ -3,12 +3,7 @@
scribble/struct
scribble/decode
scribble/eval
scheme/sandbox
(for-syntax scheme/base)
(for-label scheme/base
scheme/contract
(rename-in syntax/parse [...+ DOTSPLUS])
syntax/kerncase))
"parse-common.rkt")
@(define-syntax-rule (define-dotsplus-names dotsplus def-dotsplus)
(begin (require (for-label (only-in syntax/parse ...+)))
@ -16,63 +11,7 @@
(define def-dotsplus (defhere ...+))))
@(define-dotsplus-names dotsplus def-dotsplus)
@(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t))
@(define ellipses @scheme[...])
@(define Spattern "single-term pattern")
@(define Lpattern "list pattern")
@(define Hpattern "head pattern")
@(define EHpattern "ellipsis-head pattern")
@(define Apattern "action pattern")
@(define Spatterns "single-term patterns")
@(define Lpatterns "list patterns")
@(define Hpatterns "head patterns")
@(define EHpatterns "ellipsis-head patterns")
@(define Apatterns "action patterns")
@(begin
(define-syntax ref
(syntax-rules ()
[(ref id suffix ...)
(elemref (list 'pattern-link (list 'id 'suffix ...))
(schemekeywordfont (symbol->string 'id))
(superscript (symbol->string 'suffix)) ...
#:underline? #f)]))
(define-syntax def
(syntax-rules ()
[(def id suffix ...)
(elemtag (list 'pattern-link (list 'id 'suffix ...))
(scheme id)
#|(superscript (symbol->string 'suffix)) ...|# )])))
@(begin
(define (fixup exn)
(let ([src (ormap values (exn:fail:syntax-exprs exn))])
(if src
(make-exn:fail:syntax
(format "~a at: ~a" (exn-message exn) (syntax->datum src))
(exn-continuation-marks exn)
(exn:fail:syntax-exprs exn))
exn)))
(define the-eval
(parameterize ((sandbox-output 'string)
(sandbox-error-output 'string)
(sandbox-make-code-inspector current-code-inspector)
(sandbox-eval-handlers
(list #f
(lambda (thunk)
(with-handlers ([exn:fail:syntax?
(lambda (e) (raise (fixup e)))])
(thunk))))))
(make-evaluator 'scheme/base
#:requires '(syntax/parse (for-syntax scheme/base)))))
(the-eval '(error-print-source-location #f))
(define-syntax-rule (myexamples e ...)
(examples #:eval the-eval e ...)))
@title[#:tag "syntax-patterns"]{Syntax patterns}
@title[#:tag "stxparse-patterns"]{Syntax patterns}
The grammar of @deftech{syntax patterns} used by
@schememodname[syntax/parse] facilities is given in the following
@ -99,7 +38,8 @@ means specifically @tech{@Spattern}.
pvar-id:syntax-class-id
literal-id
(@#,ref[~var s-] id)
(@#,ref[~var s+] id syntax-class)
(@#,ref[~var s+] id syntax-class-id)
(@#,ref[~var s+] id (syntax-class-id arg ...))
(~literal literal-id)
atomic-datum
(~datum datum)
@ -114,7 +54,9 @@ means specifically @tech{@Spattern}.
#s(prefab-struct-key (unsyntax @svar[pattern-part]) ...)
#&@#,svar[S-pattern]
(~rest S-pattern)
(@#,ref[~describe s] expr S-pattern)
(@#,ref[~describe s] maybe-opaque expr S-pattern)
(@#,ref[~commit s] S-pattern)
(@#,ref[~delimit-cut s] S-pattern)
A-pattern]
[L-pattern
()
@ -125,12 +67,15 @@ means specifically @tech{@Spattern}.
(~rest L-pattern)]
[H-pattern
pvar-id:splicing-syntax-class-id
(@#,ref[~var h] id splicing-syntax-class)
(@#,ref[~var h] id splicing-syntax-class-id)
(@#,ref[~var h] id (splicing-syntax-class-id arg ...))
(~seq . L-pattern)
(@#,ref[~and h] proper-H/A-pattern ...+)
(@#,ref[~or h] H-pattern ...+)
(@#,ref[~optional h] H-pattern maybe-optional-option)
(@#,ref[~describe h] expr H-pattern)
(@#,ref[~describe h] maybe-opaque expr H-pattern)
(@#,ref[~commit h] H-pattern)
(@#,ref[~delimit-cut h] H-pattern)
proper-S-pattern]
[EH-pattern
(@#,ref[~or eh] EH-pattern ...)
@ -141,7 +86,7 @@ means specifically @tech{@Spattern}.
[A-pattern
~!
(~bind [attr-id expr] ...)
(~fail maybe-fail-condition message-expr)
(~fail maybe-fail-condition maybe-message-expr)
(~parse S-pattern stx-expr)
(@#,ref[~and a] A-pattern ...+)]
[proper-S-pattern
@ -188,6 +133,24 @@ One of @ref[~describe s] or @ref[~describe h]:
]
}
@defidform[~commit]{
One of @ref[~commit s] or @ref[~commit h]:
@itemize[
@item{@ref[~commit h] if the subpattern is a @tech{proper @Hpattern}}
@item{@ref[~commit s] otherwise}
]
}
@defidform[~delimit-cut]{
One of @ref[~delimit-cut s] or @ref[~describe h]:
@itemize[
@item{@ref[~delimit-cut h] if the subpattern is a @tech{proper @Hpattern}}
@item{@ref[~delimit-cut s] otherwise}
]
}
@defidform[~optional]{
One of @ref[~optional h] or @ref[~optional eh]:
@ -289,9 +252,9 @@ like an @tech{annotated pattern variable} with the implicit syntax
class inserted.
}
@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class)
([syntax-class syntax-class-id
(syntax-class-id arg-expr ...)])]{
@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class-use)
([syntax-class-use syntax-class-id
(syntax-class-id arg ...)])]{
An @deftech{annotated pattern variable}. The pattern matches only
terms accepted by @svar[syntax-class-id] (parameterized by the
@ -489,9 +452,11 @@ to have a value if the whole pattern matches.
@myexamples[
(syntax-parse #'a
[(~or x:id (~and x #f)) (syntax->datum #'x)])
(syntax-parse #'#f
[(~or x:id (~and x #f)) (syntax->datum #'x)])
[(~or x:id y:nat) (values (attribute x) (attribute y))])
(syntax-parse #'(a 1)
[(~or (x:id y:nat) (x:id)) (values #'x (attribute y))])
(syntax-parse #'(b)
[(~or (x:id y:nat) (x:id)) (values #'x (attribute y))])
]
}
@ -567,25 +532,49 @@ above).
]
}
@specsubform[(@#,def[~describe s] expr S-pattern)]{
@specsubform/subs[(@#,def[~describe s] maybe-opaque expr S-pattern)
([maybe-opaque (code:line)
(code:line #:opaque)])
#:contracts ([expr (or/c string? #f)])]{
The @scheme[~describe] pattern form annotates a pattern with a
description, a string expression that is evaluated in the scope of all
prior attribute bindings. If parsing the inner pattern fails, then the
description is used to synthesize the error message.
A describe-pattern also affects backtracking in two ways:
@itemize{
@item{A cut (@scheme[~!]) within a describe-pattern only
eliminates choice-points created within the describe-pattern.}
@item{If a describe-pattern succeeds, then all choice points
created within the describe-pattern are discarded, and a failure
@emph{after} the describe-pattern backtracks to a choice point
@emph{before} the describe-pattern, never one @emph{within} it.}
A @scheme[~describe] pattern has no effect on backtracking.
}
@specsubform[(@#,def[~commit s] S-pattern)]{
The @scheme[~commit] pattern form affects backtracking in two ways:
@itemize[
@item{If the pattern succeeds, then all choice points created within
the subpattern are discarded, and a failure @emph{after} the
@scheme[~commit] pattern backtracks only to choice points
@emph{before} the @scheme[~commit] pattern, never one @emph{within}
it.}
@item{A cut (@scheme[~!]) within a @scheme[~commit] pattern only
eliminates choice-points created within the @scheme[~commit]
pattern. In this sense, it acts just like @scheme[~delimit-cut].}
]
}
@specsubform[(@#,def[~delimit-cut s] S-pattern)]{
The @scheme[~delimit-cut] pattern form affects backtracking in the
following way:
@itemize[
@item{A cut (@scheme[~!]) within a @scheme[~delimit-cut] pattern only
eliminates choice-points created within the @scheme[~delimit-cut]
pattern.}
]
}
@specsubform[A-pattern]{
@ -613,9 +602,9 @@ Equivalent to @scheme[(~var pvar-id splicing-syntax-class-id)].
}
@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class)
([splicing-syntax-class splicing-syntax-class-id
(splicing-syntax-class-id arg-expr ...)])]{
@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class-use)
([splicing-syntax-class-use splicing-syntax-class-id
(splicing-syntax-class-id arg ...)])]{
Pattern variable annotated with a @tech{splicing syntax
class}. Similar to a normal @tech{annotated pattern variable}, except
@ -624,8 +613,8 @@ matches a head pattern.
@specsubform[(@#,defhere[~seq] . L-pattern)]{
Matches a head whose elements, if put in a list, would match
@scheme[L-pattern].
Matches a sequence of terms whose elements, if put in a list, would
match @scheme[L-pattern].
@myexamples[
(syntax-parse #'(1 2 3 4)
@ -638,8 +627,8 @@ examples of @scheme[~seq].
@specsubform[(@#,def[~and h] H-pattern ...)]{
Like the @Spattern version of @scheme[~and], but matches a term head
instead.
Like the @Spattern version, @ref[~and s], but matches a sequence of
terms instead.
@myexamples[
(syntax-parse #'(#:a 1 #:b 2 3 4 5)
@ -671,8 +660,8 @@ example with the second @scheme[~seq] omitted:
@specsubform[(@#,def[~or h] H-pattern ...)]{
Like the @Spattern version of @scheme[~or], but matches a term head
instead.
Like the @Spattern version, @ref[~or s], but matches a sequence of
terms instead.
@myexamples[
(syntax-parse #'(m #:foo 2 a b c)
@ -689,10 +678,10 @@ instead.
(code:line)
(code:line #:defaults ([attr-id expr] ...))])]{
Matches either the given head subpattern or an empty head. If the
@scheme[#:defaults] option is given, the subsequent attribute bindings
are used if the subpattern does not match. The default attributes must
be a subset of the subpattern's attributes.
Matches either the given head subpattern or an empty sequence of
terms. If the @scheme[#:defaults] option is given, the subsequent
attribute bindings are used if the subpattern does not match. The
default attributes must be a subset of the subpattern's attributes.
@myexamples[
(syntax-parse #'(m #:foo 2 a b c)
@ -710,13 +699,25 @@ be a subset of the subpattern's attributes.
@specsubform[(@#,def[~describe h] expr H-pattern)]{
Like the @Spattern version of @scheme[~describe], but matches a head
Like the @Spattern version, @ref[~describe s], but matches a head
pattern instead.
}
@specsubform[(@#,def[~commit h] H-pattern)]{
Like the @Spattern version, @ref[~commit s], but matches a head
pattern instead.
}
@specsubform[(@#,def[~delimit-cut h] H-pattern)]{
Like the @Spattern version, @ref[~delimit-cut s], but matches a head
pattern instead.
}
@specsubform[S-pattern]{
Matches a head of one element, which must be a term matching
Matches a sequence of one element, which must be a term matching
@scheme[S-pattern].
}
@ -726,11 +727,11 @@ Matches a head of one element, which must be a term matching
@section{Ellipsis-head patterns}
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. Multiple alternatives can be grouped
together via @ref[~or eh].
that describes some number of terms, like a @tech{@Hpattern}, but also
places contraints on the number of times it occurs in a
repetition. They are useful for matching, for example, keyword
arguments where the keywords may come in any order. Multiple
alternatives are grouped together via @ref[~or eh].
@myexamples[
(define parser1
@ -754,23 +755,26 @@ 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)
(code:line #:too-many too-many-message-expr)])]{
(code:line #:too-many too-many-message-expr)])
#:contracts ([name-expr (or/c string? #f)]
[too-few-message-expr (or/c string? #f)]
[too-many-message-expr (or/c string? #f)])]{
Matches if the inner @scheme[H-pattern] matches. This pattern must be
selected exactly once in the match of the entire repetition sequence.
matched 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 the message either @scheme[too-few-message-expr] or
@schemevalfont{"missing required occurrence of @scheme[name-expr]"}.
If the pattern is not matched in the repetition sequence, then the
ellipsis pattern fails 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 the message either
then the ellipsis pattern fails with the message either
@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences
of @scheme[name-expr]"}.
}
@ -778,13 +782,15 @@ of @scheme[name-expr]"}.
@specsubform/subs[(@#,def[~optional eh] H-pattern optional-option ...)
([optional-option (code:line #:name name-expr)
(code:line #:too-many too-many-message-expr)
(code:line #:defaults ([attr-id expr] ...))])]{
(code:line #:defaults ([attr-id expr] ...))])
#:contracts ([name-expr (or/c string? #f)]
[too-many-message-expr (or/c string? #f)])]{
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 the message either
If the pattern is matched more than once in the repetition sequence,
then the ellipsis pattern fails with the message either
@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences
of @scheme[name-expr]"}.
@ -797,18 +803,20 @@ 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)])]{
(code:line #:too-many too-many-message-expr)])
#:contracts ([name-expr (or/c syntax? #f)]
[too-few-message-expr (or/c syntax? #f)])]{
Matches if the inner @scheme[H-pattern] matches. This pattern must be
selected at least @scheme[min-number] and at most @scheme[max-number]
matched 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 matched too few times, then the ellipsis pattern
fails with the 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
If the pattern is chosen too many times, then the ellipsis pattern
fails with the message either @scheme[too-many-message-expr] or
@schemevalfont{"too few occurrences of @scheme[name-expr]"}.
}
@ -822,11 +830,6 @@ An @deftech{@Apattern} (abbreviated @svar[A-pattern]) does not
describe any syntax; rather, it has an effect such as the binding of
attributes or the modification of the matching process.
The grammar describing where an @Apattern may occur may look
complicated, but the essence is this: ``@Apatterns don't take up
space.'' They can be freely added to a list pattern or inserted into
an @scheme[~and] pattern.
@specsubform[@#,defhere[~!]]{
The @deftech{cut} operator, written @scheme[~!], eliminates
@ -848,7 +851,7 @@ expression tries the first clause, fails to match @scheme[a] against
the pattern @scheme[(x:id ...)], and then backtracks to the second
clause and ultimately the third clause, producing the value
@scheme['expression]. But the term is not an expression; it is an
ill-formed use of @scheme[define-values]! The proper way to write the
ill-formed use of @scheme[define-values]. The proper way to write the
@scheme[syntax-parse] expression follows:
@interaction[#:eval the-eval
@ -865,10 +868,12 @@ points for the second and third clauses. So when the clause fails to
match, the @scheme[syntax-parse] expression raises an error.
The effect of a @scheme[~!] pattern is delimited by the nearest
enclosing @scheme[~describe] pattern. If there is no enclosing
@scheme[~describe] pattern but the cut occurs within a syntax class
definition, then only choice points within the syntax class definition
are discarded.
enclosing @scheme[~delimit-cut] or @scheme[~commit] pattern. If there
is no enclosing @scheme[~describe] pattern but the cut occurs within a
syntax class definition, then only choice points within the syntax
class definition are discarded. A @scheme[~!] pattern is not allowed
within a @scheme[~not] pattern unless there is an intervening
@scheme[~delimit-cut] or @scheme[~commit] pattern.
}
@specsubform[(@#,defhere[~bind] [attr-id expr] ...)]{
@ -877,19 +882,23 @@ Evaluates the @scheme[expr]s and binds them to the given
@scheme[attr-id]s as attributes.
}
@specsubform/subs[(@#,defhere[~fail] maybe-fail-condition message-expr)
@specsubform/subs[(@#,defhere[~fail] maybe-fail-condition maybe-message-expr)
([maybe-fail-condition (code:line)
(code:line #:when condition-expr)
(code:line #:unless condition-expr)])]{
(code:line #:unless condition-expr)]
[maybe-message-expr (code:line)
(code:line message-expr)])
#:contracts ([message-expr (or/c string? #f)])]{
If the condition is absent, or if the @scheme[#:when]
condition evaluates to a true value, or if the @scheme[#:unless]
condition evaluates to @scheme[#f], then the pattern fails with the
given message.
If the condition is absent, or if the @scheme[#:when] condition
evaluates to a true value, or if the @scheme[#:unless] condition
evaluates to @scheme[#f], then the pattern fails with the given
message. If the message is omitted, the default value @scheme[#f] is
used, representing ``no message.''
Fail patterns can be used together with cut patterns to recognize
specific ill-formed terms and address them with specially-created
failure messages.
specific ill-formed terms and address them with custom failure
messages.
}
@specsubform[(@#,defhere[~parse] S-pattern stx-expr)

21
collects/tests/stxparse/litset-phases.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket/load
(module a racket
(require syntax/parse)
(define-literal-set lits (begin))
(provide lits))
(module b racket
(require (for-syntax 'a syntax/parse))
(require (for-syntax syntax/parse/private/runtime))
(define-syntax (snarf stx)
;;(printf "slpl of snarf: ~s\n" (syntax-local-phase-level))
(syntax-parse stx
#:literal-sets (lits)
[(snarf (begin e)) #'e]))
(provide snarf))
(module c racket
(require (for-syntax 'b racket/base))
(begin-for-syntax
(displayln (snarf (begin 5)))))

26
collects/tests/stxparse/select.rkt
View File

@ -22,14 +22,14 @@
(escape exn))
(lambda ()
(syntax-parse (quote-syntax s)
[p 'ok] ...))))])
[p (void)] ...))))])
(let ([msg (exn-message exn)]
[stxs (and (exn:fail:syntax? exn)
(exn:fail:syntax-exprs exn))])
(when 'term
(check-equal? (and (pair? stxs) (syntax->datum (car stxs))) 'term))
(erx rx (exn-message exn)) ... #t))
'ok)]))
(void))]))
(define-syntax erx
(syntax-rules (not)
@ -40,6 +40,12 @@
;; ----
(terx (a b c 7) (x:id ...)
#:term 7
#rx"expected identifier")
;; ----
(terx* (1 2) [x:nat (y:id z:id)]
#:term 1
#rx"expected identifier")
@ -86,3 +92,19 @@
(~optional b:B #:name "B clause"))
...)
#rx"unexpected term")
;; Ellipses
(terx (a b c 4)
(x:id ...)
#rx"expected identifier")
;; Repetition constraints
(terx (1 2)
((~or (~once x:id #:name "identifier") n:nat) ...)
#rx"missing required occurrence of identifier")
(terx (1 a 2 b)
((~or (~once x:id #:name "identifier") n:nat) ...)
#rx"too many occurrences of identifier")

131
collects/tests/stxparse/setup.rkt Normal file
View File

@ -0,0 +1,131 @@
#lang racket/base
(require rackunit
syntax/parse
syntax/parse/private/rep-attrs
(only-in syntax/parse/private/runtime attribute-binding)
(for-syntax racket/base))
(provide tok
terx
terx*
tcerr
bound
s=
a=
convert-syntax-error)
#|
Testing forms
-------------
(tok stx-template pattern [#:pre pre-pattern ...] [#:post post-pattern ...])
-- pattern should succeed parsing stx (pre and post patterns should fail)
(terx stx-template pattern ErrorPattern ...)
(terx* stx-template (pattern ...) ErrorPattern ...)
where ErrorPattern is regexp | (not regexp)
-- pattern should fail with exn message matching every ErrorPattern
(tcerr tc-name-expr expr ErrorPattern ...)
-- delays syntax errors in expr until runtime, error msg must every pattern
Auxiliaries
-----------
(bound (name depth [syntax?]) ...)
-- checks that name is an attr w/ proper depth and syntax?
(s= stx-template sexpr)
-- checks that stx-template produces stx w/ datum equivalent to sexpr
(a= attr expr)
-- checks that attr has value equal to expr
|#
;; tok = test pattern ok
(define-syntax tok
(syntax-rules ()
[(tok s p expr #:pre [pre-p ...] #:post [post-p ...])
(test-case (format "line ~s: ~s match ~s"
(syntax-line (quote-syntax s))
's 'p)
(syntax-parse (quote-syntax s)
[pre-p (error 'wrong-pattern "~s" 'pre-p)] ...
[p expr]
[post-p (error 'wrong-pattern "~s" 'post-p)] ...)
(void))]
[(tok s p expr)
(tok s p expr #:pre () #:post ())]
[(tok s p)
(tok s p 'ok)]))
(define-syntax-rule (bound b ...)
(begin (bound1 b) ...))
(define-syntax bound1
(syntax-rules ()
[(bound1 (name depth))
(let ([a (attribute-binding name)])
(check-pred attr? a)
(when (attr? a)
(check-equal? (attr-depth a) 'depth)))]
[(bound1 (name depth syntax?))
(let ([a (attribute-binding name)])
(check-pred attr? a)
(when (attr? a)
(check-equal? (attr-depth a) 'depth)
(check-equal? (attr-syntax? a) 'syntax?)))]))
(define-syntax-rule (s= t v)
(check-equal? (syntax->datum #'t) v))
(define-syntax-rule (a= a v)
(check-equal? (attribute a) v))
(define-syntax-rule (terx s p rx ...)
(terx* s [p] rx ...))
(define-syntax terx*
(syntax-rules ()
[(terx s [p ...] rx ...)
(test-case (format "line ~s: ~a match ~s for error"
(syntax-line (quote-syntax s))
's '(p ...))
(check-exn (lambda (exn)
(erx rx (exn-message exn)) ... #t)
(lambda ()
(syntax-parse (quote-syntax s)
[p 'ok] ...)))
(void))]))
(define-syntax erx
(syntax-rules (not)
[(erx (not rx) msg)
(check (compose not regexp-match?) rx msg)]
[(erx rx msg)
(check regexp-match? rx msg)]))
;; ====
(define-syntax-rule (tcerr name expr rx ...)
(test-case name
(check-exn (lambda (exn)
(define msg (exn-message exn))
(erx rx msg) ...
#t)
(lambda ()
(parameterize ((error-print-source-location #f))
(convert-syntax-error expr))))
(void)))
(define-syntax (convert-syntax-error stx)
(syntax-case stx ()
[(_ expr)
(with-handlers ([exn:fail:syntax?
(lambda (e)
#`(error '#,(exn-message e)))])
(parameterize ((error-print-source-location #f))
(local-expand #'expr 'expression null)))]))

248
collects/tests/stxparse/stress.rkt Normal file
View File

@ -0,0 +1,248 @@
(begin
(require syntax/parse)
(define (mkstx n) (datum->syntax #f (for/list ([i (in-range n)]) #'hello)))
(define stx1 (mkstx 10))
(define stx2 (mkstx 100))
(define stx3 (mkstx 1000))
(define stx4 (mkstx 10000))
(define bad-stx (datum->syntax #f (append (for/list ([i (in-range 10000)]) #'hello) (list #'#f))))
(define-syntax-class plain-id
#:attributes ()
(pattern x #:when (identifier? #'x)))
(define-syntax-class commit-id #:commit
#:attributes ()
(pattern x #:when (identifier? #'x)))
(define (parse/id x n)
(for ([i (in-range n)])
(syntax-parse x [(z:id ...) 'ok] [_ 'bad!])))
(define (parse/plain-id x n)
(for ([i (in-range n)])
(syntax-parse x [(z:plain-id ...) 'ok] [_ 'bad!])))
(define (parse/commit-id x n)
(for ([i (in-range n)])
(syntax-parse x [(z:commit-id ...) 'ok] [_ 'bad!])))
(define (parse/listpred x n)
(for ([i (in-range n)])
(syntax-case x ()
[(x ...) (andmap identifier? (syntax->list #'(x ...))) 'ok]
[_ 'bad!])))
(define (parse/pred x n)
(for ([i (in-range n)])
(let loop ([x x])
(syntax-case x ()
[(x . y) (identifier? #'x) (loop #'y)]
[() 'ok])))))
(begin
(define (stx->list1 x)
(cond [(syntax? x)
(stx->list1 (syntax-e x))]
[(pair? x)
(cons (car x) (stx->list1 (cdr x)))]
[(null? x)
null]))
(define (stx->list2 x)
(let ([d (syntax-e x)])
(cond [(pair? d)
(cons (car d) (stx->list2 (datum->syntax x (cdr d) x)))]
[(null? d)
null])))
(define (stx->list3 x)
(cond [(syntax? x)
(stx->list3 (syntax-e x))]
[(box? x)
(stx->list3 (unbox x))]
[(pair? x)
(cons (car x) (stx->list3 (box (cdr x))))]
[(null? x)
null])))
#|
> (time (parse/id stx 10))
cpu time: 2829 real time: 2826 gc time: 20
> (time (parse/plain-id stx 10))
cpu time: 3072 real time: 3090 gc time: 40
> (time (parse/commit-id stx 10))
cpu time: 3076 real time: 3125 gc time: 24
> (time (parse/listpred stx 10))
cpu time: 4 real time: 7 gc time: 0
> (time (parse/pred stx 10))
cpu time: 2760 real time: 2757 gc time: 8
> (collect-garbage)
> (collect-garbage)
> (time (parse/pred stx 10))
cpu time: 2808 real time: 2813 gc time: 64
> (collect-garbage)
> (collect-garbage)
> (time (parse/id stx 10))
cpu time: 2880 real time: 2876 gc time: 84
> (time (parse/id stx 10))
cpu time: 2821 real time: 2810 gc time: 8
> (time (parse/id stx 10))
cpu time: 2816 real time: 2812 gc time: 16
> (time (parse/plain-id stx 10))
cpu time: 2912 real time: 2906 gc time: 24
> (time (parse/plain-id stx 10))
cpu time: 2908 real time: 2910 gc time: 24
> (time (parse/plain-id stx 10))
cpu time: 3128 real time: 3144 gc time: 32
> (time (parse/plain-id stx 10))
cpu time: 2925 real time: 2922 gc time: 36
> (time (parse/plain-id stx 10))
cpu time: 2908 real time: 2901 gc time: 12
|#
given pattern (E ...) where E = A _ | A
the sequence (A A B A A B A A B ...)
causes each E to backtrack
(begin
(define-syntax-class id/nat
#:attributes ()
(pattern x:id)
(pattern n:nat))
(define-splicing-syntax-class trip
#:attributes ()
(pattern (~seq #:a _))
(pattern (~seq #:a)))
(define (mktripstx n)
(apply append (for/list ([i (in-range n)]) (list #'#:a #'#:a #'#:b))))
(define tripstx3 (mktripstx 1000))
(define tripstx4 (mktripstx 10000))
(define (parse/trip x n)
(for ([i (in-range n)])
(syntax-parse x
[(t:trip ...) 'ok])))
(define (mknatstx n)
(datum->syntax #f (for/list ([i (in-range n)]) (add1 i))))
(define (solve n rep)
(let ([stx (mknatstx n)])
(for ([i (in-range rep)])
(syntax-parse stx
[((~or x:nat y:nat) ...)
#:when (= (apply + (syntax->datum #'(x ...)))
(apply + (syntax->datum #'(y ...))))
(syntax->datum #'(y ...))])))))
;; (solve 35 _) and (solve 36 _) seem manageable
#| before markparams |#
> (time (parse/trip tripstx3 100))
cpu time: 812 real time: 817 gc time: 92
> (time (parse/trip tripstx3 100))
cpu time: 788 real time: 791 gc time: 76
> (time (parse/trip tripstx3 100))
cpu time: 772 real time: 774 gc time: 52
> (time (parse/trip tripstx4 10))
cpu time: 1148 real time: 1147 gc time: 436
> (time (parse/trip tripstx4 10))
cpu time: 1368 real time: 1385 gc time: 520
> (time (parse/trip tripstx4 10))
cpu time: 1240 real time: 1240 gc time: 516
> (time (solve 35 20))
cpu time: 1572 real time: 1568 gc time: 332
> (time (solve 35 20))
cpu time: 1548 real time: 1551 gc time: 304
> (time (solve 35 20))
cpu time: 1548 real time: 1548 gc time: 304
> (time (solve 36 20))
cpu time: 716 real time: 714 gc time: 80
> (time (solve 36 20))
cpu time: 704 real time: 703 gc time: 64
> (time (solve 36 20))
cpu time: 700 real time: 701 gc time: 72
#| with partial defunctionalization (failures-so-far) |#
> (time (parse/trip tripstx3 100))
cpu time: 1932 real time: 1933 gc time: 88
> (time (parse/trip tripstx3 100))
cpu time: 1900 real time: 1903 gc time: 76
> (time (parse/trip tripstx3 100))
cpu time: 2052 real time: 2052 gc time: 224
> (time (parse/trip tripstx4 10))
cpu time: 2536 real time: 2535 gc time: 708
> (time (parse/trip tripstx4 10))
cpu time: 2620 real time: 2622 gc time: 756
> (time (parse/trip tripstx4 10))
cpu time: 2372 real time: 2372 gc time: 556
> (time (solve 35 20))
cpu time: 3409 real time: 3404 gc time: 340
> (time (solve 35 20))
cpu time: 3244 real time: 3244 gc time: 312
> (time (solve 35 20))
cpu time: 3240 real time: 3242 gc time: 312
> (time (solve 36 20))
cpu time: 1588 real time: 1589 gc time: 76
> (time (solve 36 20))
cpu time: 1576 real time: 1579 gc time: 64
> (time (solve 36 20))
cpu time: 1580 real time: 1575 gc time: 52
#| with failure function as markparam |#
> (time (parse/trip tripstx3 100))
cpu time: 1840 real time: 1843 gc time: 116
> (time (parse/trip tripstx3 100))
cpu time: 1792 real time: 1789 gc time: 48
> (time (parse/trip tripstx3 100))
cpu time: 1956 real time: 1960 gc time: 228
> (time (parse/trip tripstx4 10))
cpu time: 2352 real time: 2353 gc time: 608
> (time (parse/trip tripstx4 10))
cpu time: 2488 real time: 2495 gc time: 748
> (time (parse/trip tripstx4 10))
cpu time: 2416 real time: 2415 gc time: 684
> (time (solve 35 20))
cpu time: 3205 real time: 3201 gc time: 324
> (time (solve 35 20))
cpu time: 3208 real time: 3203 gc time: 316
> (time (solve 35 20))
cpu time: 3048 real time: 3050 gc time: 184
> (time (solve 36 20))
cpu time: 1692 real time: 1695 gc time: 208
> (time (solve 36 20))
cpu time: 1564 real time: 1566 gc time: 84
> (time (solve 36 20))
cpu time: 1540 real time: 1542 gc time: 64
#| with fail & cut-prompt as stxparams |#
> (time (parse/trip tripstx3 100))
cpu time: 532 real time: 534 gc time: 68
> (time (parse/trip tripstx3 100))
cpu time: 524 real time: 524 gc time: 48
> (time (parse/trip tripstx3 100))
cpu time: 656 real time: 657 gc time: 168
> (time (parse/trip tripstx4 10))
cpu time: 992 real time: 993 gc time: 512
> (time (parse/trip tripstx4 10))
cpu time: 860 real time: 861 gc time: 380
> (time (parse/trip tripstx4 10))
cpu time: 1004 real time: 999 gc time: 516
> (time (solve 35 20))
cpu time: 1132 real time: 1129 gc time: 140
> (time (solve 35 20))
cpu time: 1320 real time: 1316 gc time: 340
> (time (solve 35 20))
cpu time: 1300 real time: 1299 gc time: 296
> (time (solve 36 20))
cpu time: 588 real time: 588 gc time: 76
> (time (solve 36 20))
cpu time: 580 real time: 584 gc time: 68
> (time (solve 36 20))
cpu time: 580 real time: 586 gc time: 56

71
collects/tests/stxparse/stxclass.rkt
View File

@ -1,15 +1,11 @@
#lang scheme/base
(require rackunit
syntax/parse
syntax/parse/debug
(for-syntax scheme/base syntax/parse))
;; Testing stuff
(define-namespace-anchor anchor)
(define tns (namespace-anchor->namespace anchor))
(define (teval expr) (eval expr tns))
(define-syntax-rule (stx-like? expr template)
(equal? (stx->datum expr) 'template))
@ -88,9 +84,9 @@
(check-equal? (vector-ref rec 1) (cadr ex))
(check-equal? (stx->datum (vector-ref rec 2)) (caddr ex)))))))
(define-syntax-rule (test-patterns pattern stx . body)
(define-syntax-rule (test-patterns pattern stx body ...)
(test-case (format "~s" 'pattern)
(syntax-parse stx [pattern . body])))
(syntax-parse stx [pattern body ... (void)])))
;; Tests
@ -127,11 +123,12 @@
(~once 2)
(~once 3)} ...)
#'(1 2 3)
'ok)
(void))
(test-patterns ({~or a:id b:nat c:str} ...) #'("one" 2 three)
(check-equal? (stx->datum #'(a ...)) '(three))
(check-equal? (stx->datum #'(b ...)) '(2))
(check-equal? (stx->datum #'(c ...)) '("one")))
(check-equal? (stx->datum #'(c ...)) '("one"))
(void))
(test-patterns ({~or (~once 1)
(~once 2)
(~once 3)
@ -143,13 +140,15 @@
(check-equal? (sort
(map symbol->string (stx->datum #'(x y w)))
string<?)
'("x" "y" "z")))
'("x" "y" "z"))
(void))
(test-patterns ({~or x
(~once 1)
(~once 2)
(~once 3)} ...)
#'(1 2 3 x y z)
(check-equal? (stx->datum #'(x ...)) '(x y z)))
(check-equal? (stx->datum #'(x ...)) '(x y z))
(void))
)))
(define-syntax-class bindings
@ -169,19 +168,22 @@
(loop ns -inf.0))
(define-syntax-class Opaque
#:opaque
(pattern (a:id n:nat)))
(define-syntax-class Transparent
#:transparent
(pattern (a:id n:nat)))
#|
(with-handlers ([exn? exn-message])
(syntax-parse #'(0 1) [_:Opaque 'ok]))
(syntax-parse #'(0 1) [_:Opaque (void)]))
(with-handlers ([exn? exn-message])
(syntax-parse #'(0 1) [_:Transparent 'ok]))
(syntax-parse #'(0 1) [_:Transparent (void)]))
|#
(syntax-parse #'(+) #:literals ([plus +])
[(plus) (void)])
(define-syntax-class (Nat> n)
#:description (format "Nat > ~s" n)
(pattern x:nat #:fail-unless (> (syntax-e #'x) n) #f))
@ -192,44 +194,3 @@
#:with c #'c0
#:declare c (Nat> (syntax-e #'b0))
(void)])
(define-syntax-class (nat> bound)
#:opaque
#:description (format "natural number greater than ~s" bound)
(pattern n:nat
#:when (> (syntax-e #'n) bound)))
(define-conventions nat-convs
[N (nat> 0)])
(syntax-parse #'(5 4) #:conventions (nat-convs)
[(N ...) (void)])
(let/ec escape
(with-handlers ([exn? (compose escape void)])
(syntax-parse #'(4 -1) #:conventions (nat-convs)
[(N ...) (void)]))
(error 'test-conv1 "didn't work"))
;; Local conventions
(define-syntax-class (nats> bound)
#:local-conventions ([N (nat> bound)])
(pattern (N ...)))
(define (p1 bound x)
(syntax-parse x
#:local-conventions ([ns (nats> bound)])
[ns 'yes]
[_ 'no]))
(eq? (p1 0 #'(1 2 3)) 'yes)
(eq? (p1 2 #'(1 2 3)) 'no)
;; Regression (2/2/2010)
(define-splicing-syntax-class twoseq
(pattern (~seq a b)))
(syntax-parse #'(1 2 3 4)
[(x:twoseq ...) 'ok])

79
collects/tests/stxparse/more-tests.rkt → collects/tests/stxparse/test-errors.rkt
View File

@ -1,67 +1,16 @@
#lang scheme
(require syntax/parse
rackunit)
syntax/parse/debug
rackunit
"setup.rkt")
(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))]))
(define-syntax-rule (tcerr name expr erx ...)
(test-case name
(check-exn (lambda (exn)
(define msg (exn-message exn))
(check regexp-match? erx msg) ...
#t)
(lambda () (convert-syntax-error expr)))))
;; 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 number? "identifier bound to number")
#`(quote #,(attribute x.value))]))
(tcerr "static: right error"
(m twelve)
#rx"identifier bound to number")
(test-case "static: works"
(check-equal? (convert-syntax-error (m zero))
0))
;; Error message tests
(tcerr "define-conventions non id"
(let () (define-conventions "foo") 0)
#rx"^define-conventions: "
#rx"expected identifier")
#rx"expected name or name with formal parameters")
(tcerr "define-literal-set non id"
(let () (define-literal-set "foo" (+ -)) 0)
@ -78,6 +27,16 @@
#rx"^define-splicing-syntax-class: "
#rx"expected at least one variant")
(tcerr "parse-rhs: commit and not delimit-cut"
(let ()
(define-syntax-class foo
#:commit
#:no-delimit-cut
(pattern x))
0)
#rx"^define-syntax-class: "
#rx"not allowed after")
(tcerr "parse-rhs: incompatible attrs flags"
(let ()
(define-syntax-class foo
@ -101,12 +60,12 @@
(tcerr "check-literals-bound: unbound literal"
(let () (define-literal-set x (foo)) 0)
#rx"^define-literal-set: "
#rx"unbound identifier not allowed as literal")
#rx"literal is unbound in phase 0")
(tcerr "check-literals-bound: unbound literal"
(syntax-parse #'x #:literals (define defunky) [_ 'ok])
#rx"^syntax-parse: "
#rx"unbound identifier not allowed as literal")
#rx"literal is unbound in phase 0")
(tcerr "append-lits+litsets: duplicate"
(let ()
@ -178,12 +137,6 @@
#rx"^syntax-parser: "
#rx"expected at least one pattern")
(tcerr "parse-pat:fail: missing message"
(syntax-parser
[(~fail) 'ok])
#rx"^syntax-parser: "
#rx"missing message expression")
(tcerr "parse-pat:fail: bad"
(syntax-parser
[(~fail . x) 'ok])

79
collects/tests/stxparse/test-exp.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang racket
(require rackunit
syntax/parse
syntax/parse/debug
syntax/parse/experimental/reflect
syntax/parse/experimental/splicing
syntax/parse/experimental/eh
"setup.rkt"
(for-syntax syntax/parse))
;; Reflection
(define-syntax-class (nat> x)
#:description (format "natural number greater than ~s" x)
(pattern n:nat
#:when (> (syntax-e #'n) x)
#:with diff (- (syntax-e #'n) x)))
(define r-nat> (reify-syntax-class nat>))
(tok (1 2 -3 -4 5) ((~or (~reflect yes (r-nat> 1) #:attributes (diff)) no) ...)
(and (s= (yes ...) '(2 5))
(s= (yes.diff ...) '(1 4))
(s= (no ...) '(1 -3 -4))))
(terx 3 (~reflect pos (r-nat> 5))
#rx"expected natural number greater than 5")
(terx whatever (~reflect x (r-nat> 0) #:attributes (wrong nope)))
(define-splicing-syntax-class opt
(pattern (~seq #:a a:expr)))
(define r-opt (reify-syntax-class opt))
(tok (#:a 1) ((~splicing-reflect s (r-opt) #:attributes (a)))
(s= s.a '1))
(tok (#:a 1 #:a 2 #:a 3) ((~splicing-reflect s (r-opt) #:attributes (a)) ...)
(s= (s.a ...) '(1 2 3)))
;; EH-alternative-sets
(define-eh-alternative-set opts
(pattern (~once (~seq #:a a:expr) #:name "A option"))
(pattern (~seq #:b b:expr)))
(tok (#:a 1) ((~eh-var s opts) ...)
(and (s= s.a 1) (s= (s.b ...) '())))
(tok (#:a 1 #:b 2 #:b 3) ((~eh-var s opts) ...)
(and (s= s.a 1) (s= (s.b ...) '(2 3))))
(terx (#:b 2 #:b 3) ((~eh-var s opts) ...)
#rx"missing required occurrence of A option")
(terx (#:a 1 #:a 2) ((~eh-var s opts) ...)
#rx"too many occurrences of A option")
(define-eh-alternative-set extopts
(pattern (~eh-var s opts))
(pattern (~seq #:c c1:expr c2:expr)))
(tok (#:a 1 #:c 2 3 #:c 4 5) ((~eh-var x extopts) ...)
(and (s= x.s.a 1) (s= (x.s.b ...) '())
(s= ((x.c1 x.c2) ...) '((2 3) (4 5)))))
(terx (#:c 1 2) ((~eh-var x extopts) ...)
#rx"missing required occurrence of A option")
;; Splicing
(define-primitive-splicing-syntax-class (foo)
#:attrs (z x y)
#:description "foo"
(lambda (stx fail)
(syntax-case stx ()
[(a b c . rest)
(list #'rest 3 #'a #'b #'c)]
[_ (fail)])))
(tok (1 2 3 4) (f:foo 4)
(and (s= f.z 1) (s= f.x 2) (s= f.y 3)))
(terx (1) (f:foo)
#rx"expected foo")

282
collects/tests/stxparse/test.rkt
View File

@ -1,72 +1,11 @@
#lang scheme
(require syntax/parse
syntax/private/stxparse/rep-attrs
syntax/private/stxparse/runtime)
(require rackunit)
;; tok = test pattern ok
(define-syntax tok
(syntax-rules ()
[(tok s p expr #:pre [pre-p ...] #:post [post-p ...])
(test-case (format "line ~s: ~s match ~s"
(syntax-line (quote-syntax s))
's 'p)
(syntax-parse (quote-syntax s)
[pre-p (error 'wrong-pattern "~s" 'pre-p)] ...
[p expr]
[post-p (error 'wrong-pattern "~s" 'post-p)] ...)
(void))]
[(tok s p expr)
(tok s p expr #:pre () #:post ())]
[(tok s p)
(tok s p 'ok)]))
(define-syntax-rule (bound b ...)
(begin (bound1 b) ...))
(define-syntax bound1
(syntax-rules ()
[(bound1 (name depth))
(let ([a (attribute-binding name)])
(check-pred attr? a)
(when (attr? a)
(check-equal? (attr-depth a) 'depth)))]
[(bound1 (name depth syntax?))
(let ([a (attribute-binding name)])
(check-pred attr? a)
(when (attr? a)
(check-equal? (attr-depth a) 'depth)
(check-equal? (attr-syntax? a) 'syntax?)))]))
(define-syntax-rule (s= t v)
(check-equal? (syntax->datum #'t) v))
(define-syntax-rule (a= a v)
(check-equal? (attribute a) v))
(define-syntax-rule (terx s p rx ...)
(terx* s [p] rx ...))
(define-syntax terx*
(syntax-rules ()
[(terx s [p ...] rx ...)
(test-case (format "line ~s: ~a match ~s for error"
(syntax-line (quote-syntax s))
's '(p ...))
(check-exn (lambda (exn)
(erx rx (exn-message exn)) ... #t)
(lambda ()
(syntax-parse (quote-syntax s)
[p 'ok] ...)))
(void))]))
(define-syntax erx
(syntax-rules (not)
[(erx (not rx) msg)
(check (compose not regexp-match?) rx msg)]
[(erx rx msg)
(check regexp-match? rx msg)]))
#lang racket
(require rackunit
syntax/parse
syntax/parse/debug
"setup.rkt"
(for-syntax syntax/parse))
;; Main syntax class and pattern tests
;; ========
@ -77,9 +16,6 @@
;; ========
;; == Parsing tests
;; -- S patterns
;; name patterns
(tok 1 a
@ -131,14 +67,17 @@
(terx (1 2) (1 1) "literal 1")
;; literal patterns
(syntax-parse #'+ #:literals (+ -)
[+ (void)])
(syntax-parse #'+ #:literals (+ -)
[- (error 'wrong)]
[+ (void)])
(syntax-parse #'+ #:literals (+ -)
[+ (void)]
[_ (error 'wrong)])
(test-case "literals: +"
(syntax-parse #'+ #:literals (+ -)
[+ (void)]))
(test-case "literals: - +"
(syntax-parse #'+ #:literals (+ -)
[- (error 'wrong)]
[+ (void)]))
(test-case "literals: + _"
(syntax-parse #'+ #:literals (+ -)
[+ (void)]
[_ (error 'wrong)]))
;; compound patterns
(tok (a b c) (x y z)
@ -151,9 +90,16 @@
(and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b)))
(tok #(a b c) #(x y z)
(and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b)))
(tok #(1 2 3 4 5) #(a b ~rest c)
(s= c '(3 4 5)))
(tok #&1 #&x
(and (bound (x 0)) (s= x 1)))
(tok #s(foo 1 2) #s(foo a b)
(and (s= a 1) (s= b 2)))
(tok #s(foo 1 2 3 4 5) #s(foo a b ~rest c)
(s= c '(3 4 5)))
;; head patterns
;; See H-patterns
@ -174,6 +120,9 @@
(tok (1 2 3) (~and (x _ _) (_ y _) (_ _ z))
(and (bound (x 0) (y 0) (z 0))))
;; and scoping
(tok 1 (~and a (~fail #:unless (equal? (syntax->datum #'a) 1))))
;; or patterns
(tok 1 (~or 1 2 3)
'ok)
@ -190,6 +139,15 @@
(tok #t (~or (~and #t x) (~and #f x))
(and (bound (x 0 #t))))
;; describe
(tok ((1 2) 3) ((~describe "one-two" (1 2)) 3))
(terx ((1 3) 3) ((~describe #:opaque "one-two" (1 2)) 3)
"one-two")
(terx ((1 3) 3) ((~describe "one-two" (1 2)) 3)
"2")
(terx (1 3) ((~describe "one-two" (1 2)) 3)
"one-two")
;; epsilon-name patterns
(tok (1) :one
(and (bound (a 0)) (s= a 1)))
@ -198,6 +156,48 @@
(tok (1 2) (~and x:two :two)
(and (bound (x 0) (x.a 0) (a 0)) (s= x '(1 2)) (s= x.a 1) (s= a 1)))
;; delimit-cut
(tok (1 (2 3)) (1 (~or (~delimit-cut (2 ~! 4)) (2 3))))
(tok (1 2 3) (1 2 3)
'ok
#:pre [(~delimit-cut (1 2 ~! 4))] #:post [])
(define-syntax-class def
#:no-delimit-cut
#:literals (define-values)
(pattern (define-values ~! (x:id ...) e:expr)))
(tok (define-values (a b c) 1) d:def
'ok)
(terx (define-values (a 2) 3) (~or d:def e:expr)
#rx"expected identifier")
(terx* (define-values (a 2) 3) [d:def e:expr]
#rx"expected identifier")
;; commit
(define-syntax-class xyseq
#:commit
(pattern ((~or x y) ...)))
(tok (1 2 3 4 5 6 7 8)
(~and ((~or s.x s.y) ...)
(~fail #:unless (= (apply + (syntax->datum #'(s.x ...)))
(apply + (syntax->datum #'(s.y ...))))
"nope"))
(equal? (syntax->datum #'(s.x ...)) '(1 2 3 4 8)))
(terx (1 2 3 4 5 6 7 8)
(~and s:xyseq
(~fail #:unless (= (apply + (syntax->datum #'(s.x ...)))
(apply + (syntax->datum #'(s.y ...))))
"nope"))
#rx"nope")
(terx (1 2 3 4 5 6 7 8)
(~and (~commit ((~or s.x s.y) ...))
(~fail #:unless (= (apply + (syntax->datum #'(s.x ...)))
(apply + (syntax->datum #'(s.y ...))))
"nope"))
#rx"nope")
;; -- H patterns
;; seq
@ -214,9 +214,14 @@
;; describe
(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3))
(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3)
(terx (1 3 3) ((~describe #:opaque "one-two" (~seq 1 2)) 3)
"one-two")
;; Regression (2/2/2010)
(define-splicing-syntax-class twoseq
(pattern (~seq a b)))
(tok (1 2 3 4) (x:twoseq ...))
;; -- A patterns
;; cut patterns
@ -227,12 +232,6 @@
(terx* 1 [(~and a:nat ~! 2) b:nat]
"2")
;; cut&describe interaction
(tok (1 (2 3)) (1 (~or (~describe "foo" (2 ~! 4)) (2 3))))
(tok (1 2 3) (1 2 3)
'ok
#:pre [(~describe "foo" (1 2 ~! 4))] #:post [])
;; bind patterns
(tok 1 (~and x (~bind [y #'x]))
(s= y '1))
@ -258,6 +257,115 @@
(terx (1 2 3) (x:nat y:nat (~parse (2 4) #'(x y)))
"expected the literal 2")
;; == syntax-parse: other feature tests
(test-case "syntax-parse: #:context"
(check-exn
(lambda (exn)
(regexp-match #rx"me: expected exact-nonnegative-integer" (exn-message exn)))
(lambda ()
(syntax-parse #'(m x) #:context #'me
[(_ n:nat) 'ok])))
(void))
(test-case "syntax-parse: #:literals"
(syntax-parse #'(0 + 1 * 2)
#:literals (+ [times *])
[(a + b * c) (void)]))
;; == syntax classes: other feature tests
;; #:auto-nested-attributes
(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)))
(void))
(test-case "nested attributes work okay"
(check-equal? (syntax-class-attributes square)
'((x 0) (x.a 0) (x.b 0) (y 0) (y.a 0) (y.b 0)))
(void))
;; conventions
(define-syntax-class (nat> bound)
#:description (format "natural number greater than ~s" bound)
(pattern n:nat #:when (> (syntax-e #'n) bound)))
(define-conventions nat-convs
[N (nat> 0)])
(test-case "syntax-parse: #:conventions"
(syntax-parse #'(5 4)
#:conventions (nat-convs)
[(N ...) (void)]))
(test-case "syntax-parse: #:conventions fail"
(check-exn
(lambda (exn)
(check regexp-match? #rx"expected natural number greater than 0"
(exn-message exn)))
(lambda ()
(syntax-parse #'(4 0)
#:conventions (nat-convs)
[(N ...) (void)])))
(void))
;; local conventions
(define-syntax-class (nats> bound)
#:local-conventions ([N (nat> bound)])
(pattern (N ...)))
(test-case "local conventions 1"
(syntax-parse #'(1 2 3)
#:local-conventions ([ns (nats> 0)])
[ns (void)]))
(test-case "local conventions 2"
(check-exn
(lambda (exn)
(check regexp-match? #rx"expected natural number greater than 2"
(exn-message exn)))
(lambda ()
(syntax-parse #'(1 2 3)
#:local-conventions ([ns (nats> 2)])
[ns (void)])))
(void))
;; == Lib tests
;; == Error tests
;; static
(tcerr "static: correct error"
(let ()
(define-syntax zero 0)
(define-syntax (m stx)
(syntax-parse stx
[(_ x)
#:declare x (static number? "identifier bound to number")
#`(quote #,(attribute x.value))]))
(m twelve))
#rx"identifier bound to number")
(test-case "static: works"
(check-equal?
(convert-syntax-error
(let ()
(define-syntax zero 0)
(define-syntax (m stx)
(syntax-parse stx
[(_ x)
#:declare x (static number? "identifier bound to number")
#`(quote #,(attribute x.value))]))
(m zero)))
0)
(void))

1
collects/unstable/scribblings/unstable.scrbl
View File

@ -110,6 +110,7 @@ Keep documentation and tests up to date.
@include-section["generics.scrbl"]
@include-section["markparam.scrbl"]
@include-section["debug.scrbl"]
@include-section["wrapc.scrbl"]
@;{--------}

124
collects/unstable/scribblings/wrapc.scrbl Normal file
View File

@ -0,0 +1,124 @@
#lang scribble/manual
@(require scribble/struct
scribble/decode
scribble/eval
"utils.rkt"
(for-label racket/base
racket/contract
unstable/wrapc
unstable/syntax))
@(begin
(define the-eval (make-base-eval))
(the-eval '(require racket/contract (for-syntax racket/base unstable/wrapc))))
@title[#:tag "wrapc"]{Contracts for macro subexpressions}
This library provides a procedure @scheme[wrap-expr/c] for applying
contracts to macro subexpressions.
@defmodule[unstable/wrapc]
@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
@defproc[(wrap-expr/c [contract-expr syntax?]
[expr syntax?]
[#:positive pos-blame
(or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
'use-site]
[#:negative neg-blame
(or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
'from-macro]
[#:name expr-name
(or/c identifier? symbol? string? #f) #f]
[#:macro macro-name
(or/c identifier? symbol? string? #f) #f]
[#:context context (or/c syntax? #f) (current-syntax-context)])
syntax?]{
Returns a syntax object representing an expression that applies the
contract represented by @scheme[contract-expr] to the value produced
by @scheme[expr].
The contract's positive blame represents the obligations of the
expression being wrapped. The negative blame represents the
obligations of the macro imposing the contract---the ultimate caller
of @scheme[wrap-expr/c]. By default, the positive blame is taken as
the module currently being expanded, and the negative blame is
inferred from the definition site of the macro (itself inferred from
the @scheme[context] argument). But both blame locations can be
overridden.
Positive and negative blame locations are determined from
@scheme[pos-blame] and @scheme[neg-blame], respectively, as follows:
@itemize[
@item{If the argument is a string, it is used directly as the blame
label.}
@item{If the argument is syntax, its source location is used
to produce the blame label.}
@item{If the argument is a module path index, its resolved module path
is used.}
@item{If the argument is @scheme['from-macro], the macro is inferred
from either the @scheme[macro-name] argument (if @scheme[macro-name]
is an identifier) or the @scheme[context] argument, and the module
where it is @emph{defined} is used as the negative blame location. If
neither an identifier @scheme[macro-name] nor a @scheme[context]
argument is given, the location is @scheme["unknown"].}
@item{If the argument is @scheme['same-as-use-site], the module being
expanded is used.}
@item{If the argument is @scheme['unknown], the blame label is
@scheme["unknown"].}
]
The @scheme[macro-name] argument is used to determine the macro's
binding, if it is an identifier. If @scheme[expr-name] is given,
@scheme[macro-name] is also included in the contract error message. If
@scheme[macro-name] is omitted or @scheme[#f], but @scheme[context] is
a syntax object, then @scheme[macro-name] is determined from
@scheme[context].
If @scheme[expr-name] is not @scheme[#f], it is used in the contract's
error message to describe the expression the contract is applied to.
The @scheme[context] argument is used, when necessary, to infer the
macro name for the negative blame party and the contract error
message. The @scheme[context] should be either an identifier or a
syntax pair with an identifer in operator position; in either case,
that identifier is taken as the macro ultimately requesting the
contract wrapping.
@examples[#:eval the-eval
(define-syntax (myparameterize1 stx)
(syntax-case stx ()
[(_ ((p v)) body)
(with-syntax ([cp (wrap-expr/c
#'parameter? #'p
#:expr-name "the parameter argument"
#:context stx)])
#'(parameterize ((cp v)) body))]))
(myparameterize1 ((current-input-port
(open-input-string "(1 2 3)")))
(read))
(myparameterize1 (('whoops 'something))
'whatever)
(module mod racket
(require (for-syntax unstable/wrapc))
(define-syntax (app stx)
(syntax-case stx ()
[(app f arg)
(with-syntax ([cf (wrap-expr/c
#'(-> number? number?)
#'f
#:expr-name "the function argument"
#:context stx)])
#'(cf arg))]))
(provide app))
(require 'mod)
(app add1 5)
(app add1 'apple)
(app (lambda (x) 'pear) 5)
]
}

9
collects/unstable/syntax.rkt
View File

@ -175,7 +175,14 @@
;; Error reporting
(define current-syntax-context (make-parameter #f))
(define current-syntax-context
(make-parameter #f
(lambda (new-value)
(unless (or (syntax? new-value) (eq? new-value #f))
(raise-type-error 'current-syntax-context
"syntax or #f"
new-value))
new-value)))
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))

95
collects/unstable/wrapc.rkt Normal file
View File

@ -0,0 +1,95 @@
#lang racket/base
(require racket/contract/base
(for-template racket/base
racket/contract/base
unstable/location)
unstable/srcloc
unstable/syntax)
(provide/contract
[wrap-expr/c
(->* (syntax? syntax?)
(#:positive (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
#:negative (or/c syntax? string? module-path-index?
'from-macro 'same-as-use-site 'unknown)
#:name (or/c identifier? symbol? string? #f)
#:macro (or/c identifier? symbol? string? #f)
#:context (or/c syntax? #f))
syntax?)])
(define (wrap-expr/c ctc-expr expr
#:positive [pos-source 'use-site]
#:negative [neg-source 'from-macro]
#:name [expr-name #f]
#:macro [macro-name #f]
#:context [ctx (current-syntax-context)])
(let* ([pos-source-expr
(get-source-expr pos-source
(if (identifier? macro-name) macro-name ctx))]
[neg-source-expr
(get-source-expr neg-source
(if (identifier? macro-name) macro-name ctx))]
[macro-name
(cond [(identifier? macro-name) (syntax-e macro-name)]
[(or (string? macro-name) (symbol? macro-name)) macro-name]
[(syntax? ctx)
(syntax-case ctx ()
[(x . _) (identifier? #'x) (syntax-e #'x)]
[x (identifier? #'#'x)]
[_ #f])]
[else #f])])
(base-wrap-expr/c expr ctc-expr
#:positive #'(quote-module-path)
#:negative neg-source-expr
#:expr-name (cond [(and expr-name macro-name)
(format "~a of ~a" expr-name macro-name)]
[expr-name expr-name]
[else #f])
#:source #`(quote-syntax #,expr))))
(define (base-wrap-expr/c expr ctc-expr
#:positive positive
#:negative negative
#:expr-name [expr-name #f]
#:source [source #f])
(let ([expr-name (or expr-name #'#f)]
[source (or source #'#f)])
#`(contract #,ctc-expr
#,expr
#,positive
#,negative
#,expr-name
#,source)))
(define (get-source-expr source ctx)
(cond [(eq? source 'use-site)
#'(quote-module-path)]
[(eq? source 'unknown)
#'(quote "unknown")]
[(eq? source 'from-macro)
(if (syntax? ctx)
(get-source-expr (extract-source ctx) #f)
(get-source-expr 'unknown #f))]
[else
(let ([source-string
(cond [(string? source) source]
[(syntax? source) (source-location->string source)]
[(module-path-index? source)
;; FIXME: share with unstable/location ??
(let ([name (resolved-module-path-name
(module-path-index-resolve source))])
(cond [(path? name) (format "(file ~s)" (path->string name))]
[(symbol? name) (format "(quote ~s)" name)]))])])
#`(quote #,source-string))]))
(define (extract-source stx)
(let ([id (syntax-case stx ()
[(x . _) (identifier? #'x) #'x]
[x (identifier? #'x) #'x]
[_ #f])])
(if id
(let ([b (identifier-binding id)])
(cond [(list? b) (car b)] ;; module-path-index
[else 'use-site]))
'unknown)))