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

merged changes from /branches/ryanc/sp2:

Browse Source 
added syntax/parse library and documentation
  added syntax/id-table library and documentation

svn: r15376
This commit is contained in:
Ryan Culpepper 2009-07-03 19:47:25 +00:00
parent 6d8c6e4f09
commit 3e63caa887
28 changed files with 5283 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/model/reductions-config.ss
View File

@ -240,7 +240,7 @@
stx
(apply make-prefab-struct
(prefab-struct-key stx)
(vector->list rinner))))]
(cdr (vector->list rinner)))))]
[else stx]))
;; make-renames-mapping : stx stx -> stx kw-args -> stx

72
collects/syntax/id-table.ss Normal file
View File

@ -0,0 +1,72 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/contract
scheme/dict
"private/id-table.ss")
#|
(provide id-table-position?)
(define id-table-position/c
(flat-named-contract "id-table-position or false"
(lambda (x) (or (id-table-position? x)
(eq? x #f)))))
|#
(define-for-syntax (format-id stx fmt . args)
(datum->syntax stx (string->symbol (apply format fmt args))))
(define-syntax (make-code stx)
(syntax-case stx ()
[(_ idtbl)
(with-syntax ([make-idtbl
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))]
[make-immutable-idtbl
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))]
[mutable-idtbl?
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))]
[immutable-idtbl?
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))])
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x))
(with-syntax ([idtbl? (s '?)]
[idtbl-ref (s '-ref)]
[idtbl-set! (s '-set!)]
[idtbl-set (s '-set)]
[idtbl-remove! (s '-remove!)]
[idtbl-remove (s '-remove)]
[idtbl-count (s '-count)]
[idtbl-iterate-first (s '-iterate-first)]
[idtbl-iterate-next (s '-iterate-next)]
[idtbl-iterate-key (s '-iterate-key)]
[idtbl-iterate-value (s '-iterate-value)]
[idtbl-map (s '-map)]
[idtbl-for-each (s '-for-each)])
#'(begin
(provide idtbl?
mutable-idtbl?
immutable-idtbl?)
(provide/contract
[make-idtbl (->* () (dict?) any)]
[make-immutable-idtbl (->* () (dict?) any)]
[idtbl-ref (->* (idtbl? any/c) (any/c)
any)]
[idtbl-set! (-> mutable-idtbl? any/c any/c
any)]
[idtbl-set (-> immutable-idtbl? any/c any/c
immutable-idtbl?)]
[idtbl-remove! (-> mutable-idtbl? any/c
any)]
[idtbl-remove (-> immutable-idtbl? any/c
immutable-idtbl?)]
[idtbl-count (-> idtbl? exact-nonnegative-integer?)]
#|
[idtbl-iterate-first (-> idtbl? id-table-position/c)]
[idtbl-iterate-next (-> idtbl? id-table-position/c id-table-position/c)]
[idtbl-iterate-key (-> idtbl? id-table-position/c identifier?)]
[idtbl-iterate-value (-> idtbl? id-table-position/c any)]
|#
[idtbl-map (-> idtbl? (-> any/c any/c any) any)]
[idtbl-for-each (-> idtbl? (-> any/c any/c any) any)]))))]))
(make-code bound-id-table)
(make-code free-id-table)
(make-code free*-id-table)

6
collects/syntax/parse.ss Normal file
View File

@ -0,0 +1,6 @@
#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"))

302
collects/syntax/private/id-table.ss Normal file
View File

@ -0,0 +1,302 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/dict)
(provide id-table-position?)
(require (rename-in scheme/base [car s:car]))
(define-syntax (car stx)
(syntax-case stx ()
[(car x)
#`(begin (unless (pair? x)
(error 'car (format "~s:~s"
'#,(syntax-line stx)
'#,(syntax-column stx))))
(s:car x))]))
(define-struct id-table-position (a b))
(define empty-immutable-hasheq (make-immutable-hasheq null))
(define (check-id x who)
(unless (identifier? x)
(raise-type-error who "identifier" x)))
(define (check-pos x who)
(unless (id-table-position? x)
(raise-type-error who "id-table-position" x)))
(define (wrap f protectors [arity (length protectors)])
(define name (object-name f))
(procedure-reduce-arity
(procedure-rename
(lambda args
(let loop ([args args] [protectors protectors])
(when (pair? args)
(unless (pair? protectors)
(error name "out of guards"))
((car protectors) (car args) name)
(loop (cdr args) (cdr protectors))))
(apply f args))
name)
arity))
(define-for-syntax (format-id stx fmt . args)
(datum->syntax stx (string->symbol (apply format fmt args))))
(define-syntax (make-code stx)
(syntax-case stx ()
[(_ idtbl
identifier->symbol
identifier=?)
(with-syntax ([mutable-idtbl
(format-id #'idtbl "mutable-~a" (syntax-e #'idtbl))]
[immutable-idtbl
(format-id #'idtbl "immutable-~a" (syntax-e #'idtbl))]
[make-idtbl
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))]
[make-mutable-idtbl
(format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))]
[make-immutable-idtbl
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))]
[mutable-idtbl?
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))]
[immutable-idtbl?
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))])
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x))
(with-syntax ([idtbl? (s '?)]
[idtbl-hash (s '-hash)]
[idtbl-ref (s '-ref)]
[idtbl-set! (s '-set!)]
[idtbl-set (s '-set)]
[idtbl-remove! (s '-remove!)]
[idtbl-remove (s '-remove)]
[idtbl-count (s '-count)]
[idtbl-iterate-first (s '-iterate-first)]
[idtbl-iterate-next (s '-iterate-next)]
[idtbl-iterate-key (s '-iterate-key)]
[idtbl-iterate-value (s '-iterate-value)]
[idtbl-map (s '-map)]
[idtbl-for-each (s '-for-each)])
#'(begin
;; Struct defs at end, so that dict methods can refer to earlier procs
(define mk
(let ([make-idtbl
(case-lambda
[() (mk null)]
[(init-dict)
(let ([t (make-mutable-idtbl (make-hasheq))])
(for ([(k v) (in-dict init-dict)])
(idtbl-set! t k v))
t)])])
make-idtbl))
(define mkimm
(let ([make-immutable-idtbl
(case-lambda
[() (mkimm null)]
[(init-dict)
(for/fold ([t (make-immutable-idtbl empty-immutable-hasheq)])
([(k v) (in-dict init-dict)])
(idtbl-set t k v))])])
make-immutable-idtbl))
(define (idtbl-ref d id [fail (lambda ()
(error 'idtbl-ref
"no mapping for ~e" id))])
(let ([i (ormap (lambda (i) (and (identifier=? (car i) id) i))
(hash-ref (idtbl-hash d)
(identifier->symbol id)
null))])
(if i
(cdr i)
(if (procedure? fail)
(fail)
fail))))
(define (idtbl-set! d id v)
(let ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)])
(hash-set! (idtbl-hash d)
(identifier->symbol id)
(let loop ([l l])
(cond [(null? l) (list (cons id v))]
[(identifier=? (caar l) id)
(cons (cons id v) (cdr l))]
[else (cons (car l) (loop (cdr l)))])))))
(define (idtbl-set d id v)
(let ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)])
(make-immutable-idtbl
(hash-set (idtbl-hash d)
(identifier->symbol id)
(let loop ([l l])
(cond [(null? l) (list (cons id v))]
[(identifier=? (caar l) id)
(cons (cons id v) (cdr l))]
[else (cons (car l) (loop (cdr l)))]))))))
(define (idtbl-remove! d id)
(let* ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)]
[newl (let loop ([l l])
(cond [(null? l) null]
[(identifier=? (caar l) id)
(cdr l)]
[else (cons (car l) (loop (cdr l)))]))])
(if (pair? newl)
(hash-set! (idtbl-hash d)
(identifier->symbol id)
newl)
(hash-remove! (idtbl-hash d)
(identifier->symbol id)))))
(define (idtbl-remove d id)
(let* ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)]
[newl (let loop ([l l])
(cond [(null? l) null]
[(identifier=? (caar l) id)
(cdr l)]
[else (cons (car l) (loop (cdr l)))]))])
(make-immutable-idtbl
(if (pair? newl)
(hash-set (idtbl-hash d)
(identifier->symbol id)
newl)
(hash-remove (idtbl-hash d)
(identifier->symbol id))))))
(define (idtbl-count d)
(apply + (hash-map (idtbl-hash d) (lambda (k v) (length v)))))
(define (idtbl-for-each d p)
(define (pp i) (p (car i) (cdr i)))
(hash-for-each (idtbl-hash d)
(lambda (k v) (for-each pp v))))
(define (idtbl-map d f)
(define (fp i) (f (car i) (cdr i)))
(apply append
(hash-map (idtbl-hash d)
(lambda (k v) (map fp v)))))
(define (idtbl-iterate-first d)
(let ([h (idtbl-hash d)])
(let ([a (dict-iterate-first h)])
(and a
(let ([b (dict-iterate-first (dict-iterate-value h a))])
(and b (make-id-table-position a b)))))))
(define (idtbl-iterate-next d pos)
(let ([h (idtbl-hash d)]
[a (id-table-position-a pos)]
[b (id-table-position-b pos)])
(let ([v (dict-iterate-value h a)])
(let ([b2 (dict-iterate-next v b)])
(if b2
(make-id-table-position a b2)
(let ([a2 (dict-iterate-next h a)])
(and a2
(let ([b2 (dict-iterate-first
(dict-iterate-value h a2))])
(and b2 (make-id-table-position a2 b2))))))))))
(define (idtbl-iterate-key d pos)
(let ([h (idtbl-hash d)]
[a (id-table-position-a pos)]
[b (id-table-position-b pos)])
(dict-iterate-key (dict-iterate-value h a) b)))
(define (idtbl-iterate-value d pos)
(let ([h (idtbl-hash d)]
[a (id-table-position-a pos)]
[b (id-table-position-b pos)])
(dict-iterate-value (dict-iterate-value h a) b)))
(define (check-idtbl x who)
(unless (idtbl? x)
(raise-type-error who (symbol->string 'idtbl) x)))
(define (check-mutable-idtbl x who)
(unless (mutable-idtbl? x)
(raise-type-error who (symbol->string 'mutable-idtbl) x)))
(define (check-immutable-idtbl x who)
(unless (immutable-idtbl? x)
(raise-type-error who (symbol->string 'immutable-idtbl) x)))
(define-struct idtbl (hash))
(define-struct (mutable-idtbl idtbl) ()
#:property prop:dict
(vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3))
(wrap idtbl-set! (list check-mutable-idtbl check-id void))
#f
(wrap idtbl-remove! (list check-mutable-idtbl check-id))
#f
(wrap idtbl-count (list check-idtbl))
(wrap idtbl-iterate-first (list check-idtbl))
(wrap idtbl-iterate-next (list check-idtbl check-pos))
(wrap idtbl-iterate-key (list check-idtbl check-pos))
(wrap idtbl-iterate-value (list check-idtbl check-pos))))
(define-struct (immutable-idtbl idtbl) ()
#:property prop:dict
(vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3))
#f
(wrap idtbl-set (list check-immutable-idtbl check-id void))
#f
(wrap idtbl-remove (list check-immutable-idtbl check-id))
(wrap idtbl-count (list check-idtbl))
(wrap idtbl-iterate-first (list check-idtbl))
(wrap idtbl-iterate-next (list check-idtbl check-pos))
(wrap idtbl-iterate-key (list check-idtbl check-pos))
(wrap idtbl-iterate-value (list check-idtbl check-pos))))
(#%provide (rename mk make-idtbl)
(rename mkimm make-immutable-idtbl)
idtbl?
mutable-idtbl?
immutable-idtbl?
idtbl-ref
idtbl-set!
idtbl-set
idtbl-remove!
idtbl-remove
idtbl-count
idtbl-iterate-first
idtbl-iterate-next
idtbl-iterate-key
idtbl-iterate-value
idtbl-map
idtbl-for-each))))]))
(define (bound-identifier->symbol id) (syntax-e id))
(make-code bound-id-table
bound-identifier->symbol
bound-identifier=?)
(define (free-identifier->symbol id)
(let ([binding (identifier-binding id)])
(if (pair? binding)
(cadr binding)
(syntax-e id))))
(make-code free-id-table
free-identifier->symbol
free-identifier=?)
(define (resolve id)
(if (syntax-transforming?)
(let-values ([(v next)
(syntax-local-value/immediate id (lambda () (values #f #f)))])
(if next
(resolve next)
id))
id))
(define (free*-identifier->symbol id)
(free-identifier->symbol (resolve id)))
(define (free*-identifier=? a b)
(free-identifier=? (resolve a) (resolve b)))
(make-code free*-id-table
free*-identifier->symbol
free*-identifier=?)

111
collects/syntax/private/stxparse/codegen-data.ss Normal file
View File

@ -0,0 +1,111 @@
#lang scheme/base
(require scheme/match
syntax/stx
(for-template scheme/base
syntax/stx
scheme/stxparam
"runtime.ss"))
(provide (all-defined-out))
;; Frontiers
;; A FrontierContextExpr (FCE) is one of
;; - (make-fce Id (listof FrontierIndexExpr))
;; A FrontierIndexExpr is
;; - #'(+ Number expr ...)
(define-struct fce (stx indexes) #:prefab)
(define (empty-frontier x)
(make-fce x (list #'(+ 0))))
(define (done-frontier x)
(make-fce x (list #'(+ +inf.0))))
(define (frontier:add-car fc x)
(make-fce x (cons #'(+ 0) (fce-indexes fc))))
(define (frontier:add-cdr fc)
(define (fi:add1 fi)
(syntax-case fi (+)
[(+ n . rest)
#`(+ #,(add1 (syntax-e #'n)) . rest)]))
(make-fce (fce-stx fc)
(cons (fi:add1 (stx-car (fce-indexes fc)))
(stx-cdr (fce-indexes fc)))))
(define (frontier:add-index fc expr)
(define (fi:add-index fi expr)
(syntax-case fi (+)
[(+ n . rest)
#`(+ n #,expr . rest)]))
(make-fce (fce-stx fc)
(cons (fi:add-index (stx-car (fce-indexes fc)) expr)
(stx-cdr (fce-indexes fc)))))
(define (frontier:add-unvector fc x)
(frontier:add-car fc x))
(define (frontier:add-unbox fc x)
(frontier:add-car fc x))
(define (frontier:add-unpstruct fc x)
(frontier:add-car fc x))
;; A DynamicFrontierContext (DFC) is a list of numbers.
;; More operations on DFCs in runtime.ss
(define (frontier->dfc-expr fc)
(define (fi->qq-part fi)
(syntax-case fi (+)
[(+ n)
#'n]
[expr #`(unquote expr)]))
(let ([fis (reverse (stx->list (fce-indexes fc)))])
(with-syntax ([(part ...) (map fi->qq-part fis)])
#`(quasiquote (part ...)))))
(define (frontier->fstx-expr fc)
(fce-stx fc))
(define (frontier->index-expr fc)
(match fc
[(struct fce (stx indexes))
#`#,(stx-car indexes)]))
;; --------
(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 (cdr (vector->list (struct->vector #,d))) #,s)))
(list (lambda (fc x)
(frontier:add-unpstruct fc x))))]))
;; A Kind is
;; (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE)))
(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 (lambda (fc x) (frontier:add-car fc x))
(lambda (fc x) (frontier:add-cdr fc)))))
(define vectorK
(make-kind #'vector?
(list (lambda (s d)
#`(datum->syntax #,s (vector->list #,d) #,s)))
(list (lambda (fc x) (frontier:add-unvector fc x)))))
(define boxK
(make-kind #'box?
(list (lambda (s d) #`(unbox #,d)))
(list (lambda (fc x) (frontier:add-unbox fc x)))))

87
collects/syntax/private/stxparse/lib.ss Normal file
View File

@ -0,0 +1,87 @@
#lang scheme/base
(require "sc.ss"
"../util.ss"
syntax/stx
syntax/kerncase
scheme/struct-info
scheme/private/contract-helpers
(for-syntax scheme/base
syntax/kerncase
"rep.ss"
(only-in "rep-data.ss" make-literalset))
(for-template scheme/base
scheme/contract))
(provide (all-defined-out))
(define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes ()
(pattern x
#:fail-unless (pred (syntax-e #'x)) #f)))
(define-pred-stxclass identifier symbol?)
(define-pred-stxclass boolean boolean?)
(define-pred-stxclass str string?)
(define-pred-stxclass character char?)
(define-pred-stxclass keyword keyword?)
(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-of pred name)
#:attributes (value)
(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))
(define-syntax-class static #:attributes (value)
(pattern x
#:declare x (static-of (lambda _ #t) "static")
#:attr value (attribute x.value)))
(define-syntax-class struct-name
#:description "struct name"
#:attributes (descriptor
constructor
predicate
[accessor 1]
super
complete?)
(pattern s
#:declare s (static-of "struct name" struct-info?)
#: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 kernel-literals
(make-literalset
(for/list ([id (kernel-form-identifier-list)])
(list (syntax-e id) id))))

565
collects/syntax/private/stxparse/parse.ss Normal file
View File

@ -0,0 +1,565 @@
#lang scheme/base
(require (for-syntax scheme/base
scheme/match
scheme/private/sc
syntax/stx
syntax/id-table
"rep-data.ss"
"rep.ss"
"codegen-data.ss"
"../util.ss")
scheme/stxparam
scheme/list
scheme/match
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))
;; ----
;; (fail expr #:expect expr #:fce FCE) : expr
(define-syntax (fail stx)
(syntax-case stx ()
[(fail x #:expect p #:fce fce)
(let ([fc-expr (frontier->dfc-expr (wash #'fce))]
[fstx-expr (frontier->fstx-expr (wash #'fce))])
#`(enclosing-fail
(make-failure x #,fc-expr #,fstx-expr 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 ...))
relsattrs (arg ...) get-description splicing?)
#`(lambda (x arg ...)
(define (fail-rhs failure)
(expectation-of-thing (get-description arg ...)
transparent?
(if transparent? failure #f)))
def ...
(syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
(with-enclosing-fail* fail-rhs
(parse:variants x relsattrs variants splicing?))))]))
;; (parse:variants id (SAttr ...) (Variant ...) boolean)
;; : expr[SyntaxClassResult]
(define-syntax (parse:variants stx)
(syntax-case stx ()
[(parse:variants x relsattrs (variant ...) splicing?)
#'(try (parse:variant x relsattrs variant splicing?) ...)]))
(define-syntax (parse:variant stx)
(syntax-case stx ()
[(parse:variant x relsattrs variant #f)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant]
[fc (empty-frontier #'x)])
#`(let ()
def ...
(parse:S x fc pattern (variant-success x relsattrs variant ()))))]
[(parse:variant x relsattrs variant #t)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant]
[fc (empty-frontier #'x)])
#`(let ()
def ...
(parse:H x fc pattern rest index
(variant-success x relsattrs variant (rest index)))))]))
;; (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 ...))
#`(convert-sides x sides
(base-success-expr #,(pattern-attrs (wash #'pattern))
relsattrs
(also ...)))]))
;; (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)
#`(if (without-fails condition)
(fail x
#:expect (expectation-of-message message)
#:fce #,(done-frontier #'x))
(convert-sides x sides (k iattrs . kargs)))]
[#s(clause:with pattern expr (def ...))
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
#`(let ([y (without-fails expr)])
def ...
(parse:S y #,(done-frontier #'x) 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 ...))
(let ([reliattrs
(reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
#'(list also ... (attribute name) ...)))]))
;; ----
;; (parse:clauses id (Clause ...))
(define-syntax (parse:clauses stx)
(syntax-case stx ()
[(parse:clauses x clauses)
(let ()
(define-values (chunks clauses-stx)
(chunk-kw-seq/no-dups #'clauses parse-directive-table))
(define-values (decls0 defs) (get-decls+defs chunks))
(define (for-clause clause)
(syntax-case clause ()
[[p . rest]
(let-values ([(rest decls sides)
(parse-pattern-directives #'rest #:decls decls0)])
(with-syntax ([rest rest]
[fc (empty-frontier #'x)]
[pattern (parse-whole-pattern #'p decls)])
#`(parse:S x fc pattern
(convert-sides x #,sides
(clause-success () (let () . rest))))))]))
(unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx))
(wrong-syntax clauses-stx "expected non-empty sequence of clauses"))
(with-syntax ([(def ...) defs]
[(alternative ...)
(map for-clause (stx->list clauses-stx))])
#`(let ()
def ...
(try alternative ...))))]))
(define-for-syntax (wash-literal stx)
(syntax-case stx ()
[(a b) (list #'a #'b)]))
(define-for-syntax (wash-literals stx)
(wash-list wash-literal stx))
#|
;; (parse:clause id ([id id] ...) Clause) : expr
(define-syntax (parse:clause stx)
(syntax-case stx ()
[(parse:clause x literals [p . rest])
(let-values ([(rest decls sides)
(parse-pattern-directives
#'rest #:decls (new-declenv (wash-literals #'literals)))])
(with-syntax ([rest rest]
[fc (empty-frontier #'x)]
[pattern (parse-whole-pattern #'p decls)])
#`(parse:S x fc pattern
(convert-sides x #,sides
(clause-success () (let () . rest))))))]))
|#
;; (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 index index0)
#`(let ([rest x]
[index (- #,(frontier->index-expr (wash #'fc)) index0)])
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:sc (a ...) parser description bind-term? bind-attrs?)
#`(let ([result (parser x)])
(if (ok? result)
(let/unpack ((a ...)
#,(let ([bind-term? (syntax-e #'bind-term?)]
[bind-attrs? (syntax-e #'bind-attrs?)])
(cond [(and bind-term? bind-attrs?)
#'(cons x result)]
[bind-term? ;; not possible, I think
#'(list x)]
[bind-attrs?
#'result]
[else #'null])))
k)
(fail x #:expect result #:fce fc)))]
[#s(pat:datum attrs datum)
#`(let ([d (syntax-e x)])
(if (equal? d (quote datum))
k
(fail x
#:expect (expectation-of-constant datum)
#:fce fc)))]
[#s(pat:literal attrs literal)
#`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal)))
k
(fail x
#:expect (expectation-of-literal literal)
#:fce fc))]
[#s(pat:head attrs head tail)
#`(parse:H x fc head rest index
(parse:S rest #,(frontier:add-index (wash #'fc) #'index) 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: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 ...)
(for/list ([fproc (kind-frontier-procs kind)]
[part-var (syntax->list #'(part ...))])
(fproc (wash #'fc) part-var))]
[(part-expr ...)
(for/list ([selector (kind-selectors kind)])
(selector #'x #'datum))])
#`(let ([datum (syntax-e x)])
(if (predicate datum)
(let ([part part-expr] ...)
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k))
(fail x
#:expect (expectation-of-compound kind0 (part-pattern ...))
#:fce fc))))))]
[#s(pat:cut attrs pattern)
#`(with-enclosing-fail enclosing-cut-fail
(parse:S x fc pattern k))]
[#s(pat:describe attrs description pattern)
#`(let ([previous-fail enclosing-fail]
[previous-cut-fail enclosing-cut-fail])
(define (new-fail failure)
(fail x
#:expect (expectation-of-thing description #f failure)
#:fce fc))
(with-enclosing-fail* new-fail
(parse:S x #,(empty-frontier #'x) pattern
(with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail
k)))))]
[#s(pat:bind _ clauses)
#'(convert-sides x clauses (clause-success () k))]
[#s(pat:fail _ condition message)
#`(if condition
(fail x
#:expect (expectation-of-message message)
#:fce fc)
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 ...))))))]))
(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: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
(define-syntax (parse:H stx)
(syntax-case stx ()
[(parse:H x fc head rest index k)
(syntax-case #'head ()
[#s(hpat:describe _ description pattern)
#`(let ([previous-fail enclosing-fail]
[previous-cut-fail enclosing-cut-fail])
(define (new-fail failure)
(fail x
#:expect (expectation-of-thing description #f failure)
#:fce fc))
(with-enclosing-fail* new-fail
(parse:H x #,(empty-frontier #'x) pattern
rest index
(with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail
k)))))]
[#s(hpat:ssc (a ...) parser description bind-term? bind-attrs?)
#`(let ([result (parser x)])
(if (ok? result)
(let ([rest (car result)]
[index (cadr result)])
(let/unpack ((a ...)
#,(let ([bind-term? (syntax-e #'bind-term?)]
[bind-attrs? (syntax-e #'bind-attrs?)])
(cond [(and bind-term? bind-attrs?)
#`(cons (stx-list-take x index) (cddr result))]
[bind-term?
#'(list (stx-list-take x index))]
[bind-attrs?
#'(cddr result)]
[else
#'null])))
k))
(fail x #:expect result #:fce fc)))]
[#s(hpat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (rest index fail id ...)
(with-enclosing-fail fail
(let-attributes ([a id] ...) k)))])
(try (parse:H x fc subpattern rest index
(disjunct subpattern success
(rest index enclosing-fail) (id ...)))
...)))]
[#s(hpat:seq attrs pattern)
(with-syntax ([index0 (frontier->index-expr (wash #'fc))])
(with-syntax ([pattern
(convert-list-pattern
#'pattern
#'#s(internal-rest-pattern rest index index0))])
#'(parse:S x fc pattern k)))]
[_
(with-syntax ([attrs (pattern-attrs (wash #'head))]
[index0 (frontier->index-expr (wash #'fc))])
#'(parse:S x fc
#s(pat:compound attrs
#:pair
(head #s(internal-rest-pattern
rest index
index0)))
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]
[loop-fc (frontier:add-index (wash #'fc) #'index)])
(define-pattern-variable alt-map #'((id . alt-id) ...))
(define-pattern-variable loop-k
#'(dots-loop dx (+ index index2) enclosing-fail rel-rep ... alt-id ...))
#`(let ()
(define (dots-loop dx index loop-fail rel-rep ... alt-id ...)
(with-enclosing-fail loop-fail
(try (parse:EH dx loop-fc head head-repc index2 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 loop-fc)]
...
[else
(let-attributes ([a (rep:finalize 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 0 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 index 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 index k)]
[_ #`(parse:H x fc head x index
(if (< rep (rep:max-number repc))
(let ([rep (add1 rep)]) k)
(fail x
#:expect (expectation-of-reps/too-many rep repc)
#:fce #,(frontier:add-index (wash #'fc)
#'index))))]))]))
;; (rep:finalize RepConstraint expr) : expr
(define-syntax (rep:finalize stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _) v) #'v]
[(_ #s(rep:optional _ _) v) #'v]
[(_ _ v) #'(reverse v)]))
;; (rep:initial-value RepConstraint) : expr
(define-syntax (rep:initial-value stx)
(syntax-case stx ()
[(_ #s(rep:once _ _ _)) #'#f]
[(_ #s(rep:optional _ _)) #'#f]
[(_ _) #'null]))
;; (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-thing description transparent? chained)
(make-expect:thing description transparent? chained))
(define-syntax-rule (expectation-of-message message)
(let ([msg message])
(if msg (make-expect:message msg) 'ineffable)))
(define-syntax-rule (expectation-of-constant constant)
(make-expect:atom 'constant))
(define-syntax-rule (expectation-of-literal literal)
(make-expect:literal (quote-syntax literal)))
(define-syntax expectation-of-compound
(syntax-rules ()
[(_ #:pair (head-pattern tail-pattern))
(make-expect:pair)]
[(_ _ _) '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-rule (expectation-of-message/too-few msg name)
(expectation-of-message
(or msg
(let ([n name])
(if n
(format "missing required occurrence of ~a" n)
"repetition constraint violated")))))
(define-syntax-rule (expectation-of-message/too-many msg name)
(expectation-of-message
(or msg
(let ([n name])
(if n
(format "too many occurrences of ~a" n)
"repetition constraint violated")))))

170
collects/syntax/private/stxparse/rep-attrs.ss Normal file
View File

@ -0,0 +1,170 @@
#lang scheme/base
(require scheme/contract
scheme/match
syntax/stx
syntax/id-table
"../util.ss"
"rep-patterns.ss")
(provide (struct-out attr))
#|
An IAttr is (make-attr identifier number boolean)
An SAttr is (make-attr symbol number boolean)
The number is the ellipsis nesting depth. The boolean is true iff the
attr is guaranteed to be bound to a value which is a syntax object (or
a list^depth of syntax objects).
|#
(define-struct attr (name depth syntax?) #:prefab)
(define (iattr? a)
(and (attr? a) (identifier? (attr-name a))))
(define (sattr? a)
(and (attr? a) (symbol? (attr-name a))))
;; increase-depth : Attr -> Attr
(define (increase-depth x)
(make attr (attr-name x) (add1 (attr-depth x)) (attr-syntax? x)))
(provide/contract
[iattr? (any/c . -> . boolean?)]
[sattr? (any/c . -> . boolean?)]
[increase-depth
(-> attr? attr?)]
[attr-make-uncertain
(-> attr? attr?)]
;; IAttr operations
[append-iattrs
(-> (listof (listof iattr?))
(listof iattr?))]
[union-iattrs
(-> (listof (listof iattr?))
(listof iattr?))]
[reorder-iattrs
(-> (listof sattr?) (listof iattr?)
(listof iattr?))]
[rename-attr
(-> iattr? identifier?
iattr?)]
;; SAttr operations
[iattr->sattr
(-> iattr?
sattr?)]
[iattrs->sattrs
(-> (listof iattr?)
(listof sattr?))]
[intersect-sattrss
(-> (listof (listof sattr?))
(listof sattr?))])
;; IAttr operations
;; append-iattrs : (listof (listof IAttr)) -> (listof IAttr)
(define (append-iattrs attrss)
(let* ([all (apply append attrss)]
[names (map attr-name all)]
[dup (check-duplicate-identifier names)])
(when dup
(wrong-syntax dup "duplicate attribute"))
all))
;; union-iattrs : (listof (listof IAttr)) -> (listof IAttr)
(define (union-iattrs attrss)
(define count-t (make-bound-id-table))
(define attr-t (make-bound-id-table))
(define list-count (length attrss))
(for* ([attrs attrss] [attr 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))])
(if (= (bound-id-table-ref count-t (attr-name a)) list-count)
a
(attr-make-uncertain a))))
;; join-attrs : Attr Attr/#f -> Attr
;; Works with both IAttrs and SAttrs.
;; Assumes attrs have same name.
(define (join-attrs a b)
(if (and a b)
(proper-join-attrs a b)
(or a b)))
(define (proper-join-attrs a b)
(let ([aname (attr-name a)])
(unless (equal? (attr-depth a) (attr-depth b))
(wrong-syntax (and (syntax? aname) aname)
"attribute '~a' occurs with different nesting depth"
(if (syntax? aname) (syntax-e aname) aname)))
(make attr aname (attr-depth a) (and (attr-syntax? a) (attr-syntax? b)))))
(define (attr-make-uncertain a)
(make attr (attr-name a) (attr-depth a) #f))
(define (iattr->sattr a)
(match a
[(struct attr (name depth syntax?))
(make attr (syntax-e name) depth syntax?)]))
(define (iattrs->sattrs as)
(map iattr->sattr as))
(define (rename-attr a name)
(make attr name (attr-depth a) (attr-syntax? a)))
;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr)
(define (intersect-sattrss attrss)
(cond [(null? attrss) null]
[else
(let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)]
[names (filter (lambda (s)
(andmap (lambda (names) (memq s names))
(cdr namess)))
(car namess))]
[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]
#: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))))))]))
;; 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])
(let ([remap-name (syntax-e (attr-name iattr))])
(hash-set! ht remap-name iattr)))
(let loop ([relsattrs relsattrs])
(match relsattrs
['() null]
[(cons sattr rest)
(let ([iattr (hash-ref ht (attr-name sattr) #f)])
(check-iattr-satisfies-sattr iattr sattr)
(cons iattr (loop rest)))]))))
(define (check-iattr-satisfies-sattr iattr sattr)
(unless iattr
(wrong-syntax #f "required attribute is not defined: ~s" (attr-name sattr)))
(unless (= (attr-depth iattr) (attr-depth sattr))
(wrong-syntax (attr-name iattr)
"attribute has wrong depth (expected ~s, found ~s)"
(attr-depth sattr) (attr-depth iattr)))
(when (and (attr-syntax? sattr) (not (attr-syntax? iattr)))
(wrong-syntax (attr-name iattr)
"attribute may not be bound to syntax: ~s"
(attr-name sattr))))

232
collects/syntax/private/stxparse/rep-data.ss Normal file
View File

@ -0,0 +1,232 @@
#lang scheme/base
(require scheme/contract
scheme/match
scheme/dict
syntax/stx
syntax/id-table
"../util.ss"
"rep-attrs.ss"
"rep-patterns.ss")
(provide (all-from-out "rep-attrs.ss")
(all-from-out "rep-patterns.ss")
(struct-out stxclass)
stxclass/s?
stxclass/h?
(struct-out attr)
(struct-out rhs)
(struct-out variant)
(struct-out clause:fail)
(struct-out clause:with)
(struct-out clause:attr)
(struct-out conventions)
(struct-out literalset))
#|
A stxclass is
(make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean)
|#
(define-struct stxclass (name params attrs parser-name description splicing?)
#:prefab)
(define (stxclass/s? x)
(and (stxclass? x) (not (stxclass-splicing? x))))
(define (stxclass/h? x)
(and (stxclass? x) (stxclass-splicing? x)))
#|
An RHS is
(make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx))
definitions: auxiliary definitions from #:declare
|#
(define-struct rhs (ostx attrs transparent? description variants definitions)
#:prefab)
#|
A Variant is
(make-variant stx (listof SAttr) Pattern (listof SideClause))
|#
(define-struct variant (ostx attrs pattern sides definitions) #:prefab)
#|
A SideClause is one of
(make-clause:fail stx stx)
(make-clause:with pattern stx (listof stx))
(make-clause:attr IAttr stx)
|#
(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
(make-conventions (listof ConventionRule))
A ConventionRule is (list regexp DeclEntry)
|#
(define-struct conventions (rules) #:transparent)
#|
A LiteralSet is
(make-literalset (listof (list symbol id)))
|#
(define-struct literalset (literals) #:transparent)
;; 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))
;; Environments
#|
DeclEnv =
(make-declenv immutable-bound-id-mapping[id => DeclEntry]
(listof ConventionRule))
DeclEntry =
(list 'literal id id)
(list 'stxclass id id (listof stx))
(list 'parser id id (listof IAttr))
#f
|#
(define-struct declenv (table conventions))
(define (new-declenv literals #:conventions [conventions null])
(for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)])
([literal literals])
(declenv-put-literal decls (car literal) (cadr literal))))
(define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
(or (bound-id-table-ref (declenv-table env) id #f)
(and use-conventions?
(conventions-lookup (declenv-conventions env) id))))
(define (declenv-check-unbound env id [stxclass-name #f]
#:blame-declare? [blame-declare? #f])
;; Order goes: literals, pattern, declares
;; So blame-declare? only applies to stxclass declares
(let ([val (declenv-lookup env id #:use-conventions? #f)])
(when val
(cond [(eq? 'literal (car val))
(wrong-syntax id "identifier previously declared as literal")]
[(and blame-declare? stxclass-name)
(wrong-syntax (cadr val)
"identifier previously declared with syntax class ~a"
stxclass-name)]
[else
(wrong-syntax (if blame-declare? (cadr val) id)
"identifier previously declared")]))))
(define (declenv-put-literal env internal-id lit-id)
(declenv-check-unbound env internal-id)
(make-declenv
(bound-id-table-set (declenv-table env) internal-id
(list 'literal internal-id lit-id))
(declenv-conventions env)))
(define (declenv-put-stxclass env id stxclass-name args)
(declenv-check-unbound env id)
(make-declenv
(bound-id-table-set (declenv-table env) id
(list 'stxclass id stxclass-name args))
(declenv-conventions env)))
(define (declenv-put-parser env id parser get-description attrs splicing?)
;; no unbound check, since replacing 'stxclass entry
(make-declenv
(bound-id-table-set (declenv-table env) id
(list (if splicing? 'splicing-parser 'parser)
parser get-description attrs))
(declenv-conventions env)))
;; returns ids in domain of env but not in given list
(define (declenv-domain-difference env ids)
(define idbm (make-bound-id-table))
(for ([id ids]) (bound-id-table-set! idbm id #t))
(for/list ([(k v) (in-dict (declenv-table env))]
#:when (and (pair? v) (not (eq? (car v) 'literal)))
#:when (not (bound-id-table-ref idbm k #f)))
k))
;; Conventions = (listof (list regexp DeclEntry))
(define (conventions-lookup conventions id)
(let ([sym (symbol->string (syntax-e id))])
(for/or ([c conventions])
(and (regexp-match? (car c) sym) (cadr c)))))
;; Contracts
(define DeclEnv/c
(flat-named-contract 'DeclEnv declenv?))
(define SideClause/c
(or/c clause:fail? clause:with? clause:attr?))
(provide/contract
[DeclEnv/c contract?]
[SideClause/c contract?]
[make-dummy-stxclass (-> identifier? stxclass?)]
[use-dummy-stxclasses? (parameter/c boolean?)]
[new-declenv
(->* [(listof (list/c identifier? identifier?))]
[#:conventions list?]
DeclEnv/c)]
[declenv-lookup
(-> DeclEnv/c identifier? any)]
[declenv-put-stxclass
(-> DeclEnv/c identifier? identifier? (listof syntax?)
DeclEnv/c)]
[declenv-put-parser
(-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean?
DeclEnv/c)]
[declenv-domain-difference
(-> DeclEnv/c (listof identifier?)
(listof identifier?))]
[declenv-table
(-> DeclEnv/c any)]
[get-stxclass
(-> identifier? any)]
[get-stxclass/check-arg-count
(-> identifier? exact-nonnegative-integer? any)]
[split-id/get-stxclass
(-> identifier? DeclEnv/c any)])
(define use-dummy-stxclasses? (make-parameter #f))
(define (get-stxclass id)
(if (use-dummy-stxclasses?)
(make-dummy-stxclass id)
(let* ([no-good
(lambda () (wrong-syntax id "not defined as syntax class"))]
[sc (syntax-local-value/catch id stxclass?)])
(unless (stxclass? sc)
(no-good))
sc)))
(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)
(use-dummy-stxclasses?))
;; (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))
sc))
(define (split-id/get-stxclass id0 decls)
(cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
=> (lambda (m)
(define id
(datum->syntax id0 (string->symbol (cadr m)) id0 id0))
(define scname
(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)])
(values id sc)))]
[else (values id0 #f)]))

147
collects/syntax/private/stxparse/rep-patterns.ss Normal file
View File

@ -0,0 +1,147 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/stx
"../util.ss"))
(provide (all-defined-out))
#|
A PBase/HPBase/EHPBase 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.
An IdPrefix is an identifier/#f
If #f, it means bind no attributes
If identifier, it already includes the colon part, unless epsilon
|#
#|
A SinglePattern is one of
(make-pat:name SPBase SinglePattern (listof identifier))
(make-pat:any SPBase)
(make-pat:sc SPBase id id boolean boolean)
(make-pat:datum SPBase datum)
(make-pat:literal SPBase identifier)
(make-pat:head SPBase HeadPattern SinglePattern)
(make-pat:dots SPBase (listof EllipsisHeadPattern) SinglePattern)
(make-pat:and SPBase (listof SinglePattern))
(make-pat:or SPBase (listof SinglePattern))
(make-pat:compound SPBase Kind (listof SinglePattern))
(make-pat:cut SPBase SinglePattern)
(make-pat:describe SPBase stx SinglePattern)
(make-pat:bind SPBase (listof clause:attr))
(make-pat:fail SPBase stx stx)
A ListPattern is a subtype of SinglePattern; one of
(make-pat:datum SPBase '())
(make-pat:head SPBase HeadPattern ListPattern)
(make-pat:compound SPBase '#:pair (list SinglePattern ListPattern))
(make-pat:dots SPBase EllipsisHeadPattern SinglePattern)
(make-pat:cut SPBase ListPattern)
|#
(define-struct pat:name (attrs pattern names) #:prefab)
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:sc (attrs parser description bind-term? bind-attrs?) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:literal (attrs id) #: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:compound (attrs kind patterns) #:prefab)
(define-struct pat:cut (attrs pattern) #:prefab)
(define-struct pat:describe (attrs description pattern) #:prefab)
(define-struct pat:bind (attrs clauses) #:prefab)
(define-struct pat:fail (attrs when message) #:prefab)
#|
A HeadPattern is one of
(make-hpat:ssc HPBase id id boolean boolean)
(make-hpat:seq HPBase ListPattern)
(make-hpat:or HPBase (listof HeadPattern))
(make-hpat:describe HPBase stx/#f HeadPattern)
|#
(define-struct hpat:ssc (attrs parser description bind-term? bind-attrs?) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:or (attrs patterns) #:prefab)
(define-struct hpat:describe (attrs description pattern) #:prefab)
#|
An EllipsisHeadPattern is
(make-ehpat EHPBase HeadPattern RepConstraint)
A RepConstraint is one of
(make-rep:once stx stx stx)
(make-rep:optional stx stx)
(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) #: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:name? x)
(pat:any? x)
(pat:sc? x)
(pat:datum? x)
(pat:literal? x)
(pat:head? x)
(pat:dots? x)
(pat:and? x)
(pat:or? x)
(pat:compound? x)
(pat:cut? x)
(pat:describe? x)
(pat:bind? x)
(pat:fail? x)))
(define (head-pattern? x)
(or (hpat:ssc? x)
(hpat:seq? x)
(hpat:or? 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 (datum->syntax
s (format-symbol "~a?" (syntax-e s)))
(datum->syntax
s (format-symbol "~a-attrs" (syntax-e s)))))])
#'(lambda (x)
(cond [(pred x) (accessor x)] ...
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
(mk-get-attrs pat:name pat:any pat:sc pat:datum pat:literal pat:head
pat:dots pat:and pat:or pat:compound pat:cut pat:describe
pat:bind pat:fail
hpat:ssc hpat:seq hpat:or hpat:describe
ehpat)))

815
collects/syntax/private/stxparse/rep.ss Normal file
View File

@ -0,0 +1,815 @@
#lang scheme/base
(require (for-template scheme/base)
(for-template "runtime.ss")
scheme/contract
scheme/match
scheme/dict
syntax/id-table
syntax/stx
"../util.ss"
"rep-data.ss"
"codegen-data.ss")
(provide/contract
[parse-rhs
(-> syntax? boolean? boolean? syntax?
rhs?)]
[parse-whole-pattern
(-> syntax? DeclEnv/c
pattern?)]
[parse-pattern-directives
(->* [stx-list?]
[#:decls DeclEnv/c #:allow-declare? boolean?]
(values stx-list? DeclEnv/c (listof SideClause/c)))]
[parse-directive-table any/c]
[get-decls+defs
(-> list?
(values DeclEnv/c (listof syntax?)))]
[check-literals-list
(-> syntax?
(listof (list/c identifier? identifier?)))]
[check-literal-sets-list
(-> syntax?
(listof (listof (list/c identifier? identifier?))))]
[append-lits+litsets
(-> (listof (list/c identifier? identifier?))
(listof (listof (list/c identifier? identifier?)))
syntax?
(listof (list/c identifier? identifier?)))]
[check-conventions-rules any/c]
[create-aux-def any/c])
(define (atomic-datum? stx)
(let ([datum (syntax-e stx)])
(or (null? datum)
(boolean? datum)
(string? datum)
(number? datum)
(keyword? datum))))
(define (id-predicate kw)
(lambda (stx)
(and (identifier? stx)
(free-identifier=? stx kw))))
(define wildcard? (id-predicate (quote-syntax _)))
(define epsilon? (id-predicate (quote-syntax ||)))
(define dots? (id-predicate (quote-syntax ...)))
(define keywords
(list (quote-syntax _)
(quote-syntax ||)
(quote-syntax ...)
(quote-syntax ~and)
(quote-syntax ~or)
(quote-syntax ~seq)
(quote-syntax ~rep)
(quote-syntax ~once)
(quote-syntax ~optional)
(quote-syntax ~rest)
(quote-syntax ~struct)
(quote-syntax ~!)
(quote-syntax ~describe)
(quote-syntax ~bind)
(quote-syntax ~fail)))
(define (reserved? stx)
(and (identifier? stx)
(for/or ([kw keywords])
(free-identifier=? stx kw))))
;; ---
;; parse-rhs : stx boolean boolean stx -> RHS
;; If allow-unbound? is true, then all stxclasses act as if they have no attrs.
;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
(define (parse-rhs stx allow-unbound? splicing? ctx)
(define-values (rest description transparent? attributes decls defs)
(parse-rhs/part1 stx ctx))
(define patterns (parse-variants rest decls allow-unbound? splicing? ctx))
(when (null? patterns)
(wrong-syntax ctx "expected at least one variant"))
(let ([sattrs
(or attributes
(intersect-sattrss (map variant-attrs patterns)))])
(make rhs stx sattrs transparent? description patterns defs)))
(define (parse-rhs/part1 stx ctx)
(define-values (chunks rest)
(chunk-kw-seq/no-dups stx rhs-directive-table #:context ctx))
(define desc0 (assq '#:description chunks))
(define trans0 (assq '#:transparent chunks))
(define attrs0 (assq '#:attributes chunks))
(define description (and desc0 (caddr desc0)))
(define transparent? (and trans0 #t))
(define attributes (and attrs0 (caddr attrs0)))
(define-values (decls defs) (get-decls+defs chunks))
(values rest description transparent? attributes decls defs))
(define (parse-variants rest decls allow-unbound? splicing? ctx)
(define (gather-patterns stx)
(syntax-case stx (pattern)
[((pattern . _) . rest)
(cons (parse-variant (stx-car stx) allow-unbound? splicing? decls)
(gather-patterns #'rest))]
[(bad-variant . rest)
(raise-syntax-error #f "expected syntax-class variant" ctx #'bad-variant)]
[()
null]))
(gather-patterns rest))
;; get-decls+defs : chunks -> (values DeclEnv (listof syntax))
(define (get-decls+defs chunks)
(decls-create-defs (get-decls chunks)))
;; get-decls : chunks -> DeclEnv
(define (get-decls chunks #:context [ctx #f])
(define lits0 (assq '#:literals chunks))
(define litsets0 (assq '#:literal-sets chunks))
(define convs0 (assq '#:conventions chunks))
(define literals
(append-lits+litsets
(if lits0 (caddr lits0) null)
(if litsets0 (caddr litsets0) null)
ctx))
(define convention-rules (if convs0 (apply append (caddr convs0)) null))
(new-declenv literals #:conventions convention-rules))
;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
(define (decls-create-defs decls0)
(for/fold ([decls decls0] [defs null])
([(k v) (in-dict (declenv-table decls0))]
#:when (memq (car v) '(stxclass splicing-stxclass)))
(let-values ([(parser description attrs new-defs) (create-aux-def v)])
(values (declenv-put-parser decls k parser description attrs
(eq? (car v) 'splicing-stxclass))
(append new-defs defs)))))
;; create-aux-def : DeclEntry -> (values id id (listof SAttr) (listof stx))
(define (create-aux-def entry)
(let ([sc-name (caddr entry)]
[args (cadddr entry)])
(let ([sc (get-stxclass/check-arg-count sc-name (length args))])
(with-syntax ([sc-parser (stxclass-parser-name sc)]
[sc-description (stxclass-description sc)])
(if (pair? args)
(with-syntax ([x (generate-temporary 'x)]
[parser (generate-temporary sc-name)]
[description (generate-temporary sc-name)]
[(arg ...) args])
(values #'parser #'description (stxclass-attrs sc)
(list #'(define (parser x) (sc-parser x arg ...))
#'(define (description) (description arg ...)))))
(values #'sc-parser #'sc-description (stxclass-attrs sc)
null))))))
(define (append-lits+litsets lits litsets ctx)
(define seen (make-bound-id-table lits))
(for ([litset litsets])
(for ([lit litset])
(when (bound-id-table-ref seen (car lit) #f)
(raise-syntax-error #f "duplicate literal declaration" ctx (car lit)))
(bound-id-table-set! seen (car lit) #t)))
(apply append lits litsets))
;; parse-variant : stx boolean boolean boolean DeclEnv -> RHS
(define (parse-variant stx allow-unbound? splicing? decls0)
(syntax-case stx (pattern)
[(pattern p . rest)
(parameterize ((use-dummy-stxclasses? allow-unbound?))
(let-values ([(rest decls1 clauses)
(parse-pattern-directives #'rest
#:decls decls0)])
(define-values (decls defs) (decls-create-defs decls1))
(unless (stx-null? rest)
(wrong-syntax (if (pair? rest) (car rest) rest)
"unexpected terms after pattern directives"))
(let* ([pattern (parse-whole-pattern #'p decls splicing?)]
[attrs
(append-iattrs
(cons (pattern-attrs pattern)
(side-clauses-attrss clauses)))]
[sattrs (iattrs->sattrs attrs)])
(make variant stx sattrs pattern clauses defs))))]))
(define (side-clauses-attrss clauses)
(for/list ([c clauses]
#:when (or (clause:with? c) (clause:attr? c)))
(if (clause:with? c)
(pattern-attrs (clause:with-pattern c))
(list (clause:attr-attr c)))))
;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
(define (parse-whole-pattern stx decls [splicing? #f])
(define pattern
(if splicing?
(parse-head-pattern stx decls)
(parse-single-pattern stx decls)))
(define pvars (map attr-name (pattern-attrs pattern)))
(define excess-domain (declenv-domain-difference decls pvars))
(when (pair? excess-domain)
(wrong-syntax #f "declared pattern variables do not appear in pattern"
#:extra excess-domain))
pattern)
;; ----
;; parse-single-pattern : stx DeclEnv -> SinglePattern
(define (parse-single-pattern stx decls)
(syntax-case stx (~and ~or ~rest ~struct ~! ~describe ~bind ~fail)
[wildcard
(wildcard? #'wildcard)
(make pat:any null)]
[reserved
(reserved? #'reserved)
(wrong-syntax stx "not allowed here")]
[id
(identifier? #'id)
(parse-pat:id stx decls #f)]
[datum
(atomic-datum? #'datum)
(make pat:datum null (syntax->datum #'datum))]
[(~and . rest)
(parse-pat:and stx decls)]
[(~or . rest)
(parse-pat:or stx decls #f)]
[(head dots . tail)
(dots? #'dots)
(parse-pat:dots stx #'head #'tail decls)]
[(~struct key . contents)
(let ([lp (parse-single-pattern (syntax/loc stx contents) decls)]
[key (syntax->datum #'key)])
(make pat:compound (pattern-attrs lp) `(#:pstruct ,key) (list lp)))]
[(~! . rest)
(let ([inner (parse-single-pattern (syntax/loc stx rest) decls)])
(make pat:cut (pattern-attrs inner) inner))]
[(~describe . rest)
(parse-pat:describe stx decls #f)]
[(~bind . rest)
(parse-pat:bind stx decls)]
[(~fail . rest)
(parse-pat:fail stx decls)]
[(~rest . rest)
(parse-pat:rest stx decls)]
[(head . tail)
(parse-pat:pair stx #'head #'tail decls)]
[#(a ...)
(let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
(make pat:compound (pattern-attrs lp) '#:vector (list lp)))]
[b
(box? (syntax-e #'b))
(let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)])
(make pat:compound (pattern-attrs bp) '#:box (list bp)))]
[s
(and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s)))
(let* ([s (syntax-e #'s)]
[key (prefab-struct-key s)]
[contents (cdr (vector->list (struct->vector s)))])
(let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
(make pat:compound (pattern-attrs lp) `(#:pstruct ,key) (list lp))))]))
;; parse-head-pattern : stx DeclEnv -> HeadPattern
(define (parse-head-pattern stx decls)
(syntax-case stx (~or ~seq ~describe)
[id
(and (identifier? #'id) (not (reserved? #'id)))
(parse-pat:id stx decls #t)]
[(~or . rest)
(parse-pat:or stx decls #t)]
[(~seq . rest)
(parse-hpat:seq stx #'rest decls)]
[(~describe . rest)
(parse-pat:describe stx decls #t)]
[_
(parse-single-pattern stx decls)]))
;; parse-ellipsis-head-pattern : stx DeclEnv number -> EllipsisHeadPattern
(define (parse-ellipsis-head-pattern stx decls)
(syntax-case stx (~bounds ~optional ~once)
[(~optional . _)
(parse-ehpat/optional stx decls)]
[(~once . _)
(parse-ehpat/once stx decls)]
[(~bounds . _)
(parse-ehpat/bounds stx decls)]
[_
(let ([head (parse-head-pattern stx decls)])
(make ehpat (map increase-depth (pattern-attrs head))
head
#f))]))
;; ----
(define (parse-pat:id id decls allow-head?)
(define entry (declenv-lookup decls id))
(match entry
[(list 'literal internal-id literal-id)
(make pat:literal null literal-id)]
[(list 'stxclass _ _ _)
(error 'parse-pat:id "decls had leftover 'stxclass entry: ~s" entry)]
[(list 'splicing-stxclass _ _ _)
(error 'parse-pat:id "decls had leftover 'splicing-stxclass entry: ~s" entry)]
[(list 'parser parser description attrs)
(parse-pat:id/s id id parser description attrs)]
[(list 'splicing-parser parser description attrs)
(parse-pat:id/h id id parser description attrs)]
[#f
(let-values ([(name sc) (split-id/get-stxclass id decls)])
(cond [(stxclass/s? sc)
(parse-pat:id/s id name
(stxclass-parser-name sc)
(stxclass-description sc)
(stxclass-attrs sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id name
(stxclass-parser-name sc)
(stxclass-description sc)
(stxclass-attrs sc))]
[else
(wrap/name name (make pat:any null))]))]))
(define (parse-pat:id/s stx name parser description attrs)
(define prefix (name->prefix name))
(define bind (name->bind name))
(make pat:sc (id-pattern-attrs attrs bind prefix)
parser description (and bind #t) (and prefix #t)))
(define (parse-pat:id/h stx name parser description attrs)
(define prefix (name->prefix name))
(define bind (name->bind name))
(make hpat:ssc (id-pattern-attrs attrs bind prefix)
parser description (and bind #t) (and prefix #t)))
(define (name->prefix id)
(cond [(wildcard? id) #f]
[(epsilon? id) id]
[else (datum->syntax id (format-symbol "~a." (syntax-e id)))]))
(define (name->bind id)
(cond [(wildcard? id) #f]
[(epsilon? id) #f]
[else id]))
(define (wrap/name id pattern)
(cond [(wildcard? id) pattern]
[(epsilon? id) pattern]
[else
(let ([a (make attr id 0 #t)])
(make pat:name (cons a (pattern-attrs pattern)) pattern (list id)))]))
;; id-pattern-attrs : (listof SAttr) id/#f IdPrefix -> (listof IAttr)
(define (id-pattern-attrs sattrs bind prefix)
(let ([rest
(if prefix
(for/list ([a sattrs])
(prefix-attr a prefix))
null)])
(if bind
(cons (make attr bind 0 #t) rest)
rest)))
;; prefix-attr : SAttr identifier -> IAttr
(define (prefix-attr a prefix)
(make attr (prefix-attr-name prefix (attr-name a)) (attr-depth a) (attr-syntax? a)))
;; prefix-attr-name : id symbol -> id
(define (prefix-attr-name prefix name)
(datum->syntax prefix (format-symbol "~a~a" (syntax-e prefix) name)))
;; ----
(define (parse-pat:describe stx decls allow-head?)
(syntax-case stx ()
[(_ description pattern)
(let ([p (parse-some-pattern #'pattern decls allow-head?)])
(if (head-pattern? p)
(make hpat:describe (pattern-attrs p) #'description p)
(make pat:describe (pattern-attrs p) #'description p)))]))
(define (parse-pat:or stx decls allow-head?)
(define patterns (parse-cdr-patterns stx decls allow-head? #f))
(cond [(null? (cdr patterns))
(car patterns)]
[else
(let ()
(define attrs (union-iattrs (map pattern-attrs patterns)))
(cond [(ormap head-pattern? patterns)
(make-hpat:or attrs patterns)]
[else
(make-pat:or attrs patterns)]))]))
(define (parse-pat:and stx decls)
(define patterns (parse-cdr-patterns stx decls #f #t))
(make pat:and (append-iattrs (map pattern-attrs patterns)) patterns))
;; FIXME: broken, first off, and second, must not reorder names, preserve original scopes
(define (simplify-and-pattern patterns0)
(define (loop patterns names)
(cond [(pair? patterns)
(match (car patterns)
[(struct pat:any ('()))
(loop (cdr patterns) names)]
[(struct pat:name (_ pattern ns))
(loop (cons pattern (cdr patterns))
(append ns names))])]
[else (values patterns names)]))
(define-values (patterns names)
(loop patterns0 null))
(define base
(if (pair? patterns)
(make pat:and (append-iattrs (map pattern-attrs patterns)) patterns)
(make pat:any '())))
(if (pair? names)
(let ([new-attrs (for/list ([name names]) (make attr name 0 #t))])
(make pat:name (append new-attrs (pattern-attrs base)) base names))
base))
(define (parse-hpat:seq stx list-stx decls)
(define pattern (parse-single-pattern list-stx decls))
(check-list-pattern pattern stx)
(make hpat:seq (pattern-attrs pattern) pattern))
(define (parse-cdr-patterns stx decls allow-head? allow-cut?)
(unless (stx-list? stx)
(wrong-syntax stx "expected sequence of patterns"))
(let ([result
(for/list ([sub (cdr (stx->list stx))])
(if allow-cut?
(or (parse-cut/and sub)
(parse-some-pattern sub decls allow-head?))
(parse-some-pattern sub decls allow-head?)))])
(when (null? result)
(wrong-syntax stx "expected at least one pattern"))
result))
(define (parse-cut/and stx)
(syntax-case stx (~!)
[~! (make pat:cut null (make pat:any null))]
[_ #f]))
(define (parse-some-pattern stx decl allow-head?)
(define p (parse-head-pattern stx decl))
(when (head-pattern? p)
(unless allow-head?
(wrong-syntax stx "head pattern not allowed")))
p)
(define (parse-pat:dots stx head tail decls)
(define headps
(syntax-case head (~or)
[(~or . _)
(begin
(unless (stx-list? head)
(wrong-syntax head "expected sequence of patterns"))
(for/list ([sub (cdr (stx->list head))])
(parse-ellipsis-head-pattern sub decls)))]
[_
(list (parse-ellipsis-head-pattern head decls))]))
(define tailp (parse-single-pattern tail decls))
(define attrs
(append-iattrs (cons (pattern-attrs tailp)
(map pattern-attrs headps))))
(make pat:dots attrs headps tailp))
(define (parse-pat:bind stx decls)
(syntax-case stx ()
[(_ clause ...)
(parameterize ((current-syntax-context stx))
(let ([clauses (map parse-bind-clause (syntax->list #'(clause ...)))])
(make pat:bind
(append-iattrs (side-clauses-attrss clauses))
clauses)))]))
(define (parse-bind-clause clause)
(syntax-case clause ()
[(attr-decl expr)
(make clause:attr (check-attr-arity #'attr-decl) #'expr)]
[_ (wrong-syntax clause "expected bind clause")]))
(define (parse-pat:fail stx decls)
(syntax-case stx ()
[(_ . rest)
(let-values ([(chunks rest)
(chunk-kw-seq/no-dups #'rest
fail-directive-table
#:context stx)])
;; chunks has 0 or 1 of each of #:when, #:unless
;; if has both, second one is bad; report it
(when (> (length chunks) 1)
(wrong-syntax (cadr (cadr chunks))
"cannot use both #:when and #:unless conditions"))
(let ([condition
(if (null? chunks)
#'#t
(let ([chunk (car chunks)])
(if (eq? (car chunk) '#:when)
(caddr chunk)
#`(not #,(caddr chunk)))))])
(syntax-case rest ()
[(message)
(make pat:fail null condition #'message)]
[()
(wrong-syntax stx "missing message expression")]
[_
(wrong-syntax stx "bad fail pattern")])))]))
(define (parse-pat:rest stx decls)
(syntax-case stx ()
[(_ pattern)
(parse-single-pattern #'pattern decls)]))
(define (parse-pat:pair stx head tail decls)
(define headp (parse-head-pattern head decls))
(define tailp (parse-single-pattern tail decls))
(define attrs
(append-iattrs
(list (pattern-attrs headp) (pattern-attrs tailp))))
;; Only make pat:head if head is complicated; otherwise simple compound/pair
;; FIXME: Could also inline ~seq patterns from head...?
(if (head-pattern? headp)
(make pat:head attrs headp tailp)
(make pat:compound attrs '#:pair (list headp tailp))))
(define (check-list-pattern pattern stx)
(match pattern
[(struct pat:datum (_base '()))
#t]
[(struct pat:head (_base _head tail))
(check-list-pattern tail stx)]
[(struct pat:dots (_base _head tail))
(check-list-pattern tail stx)]
[(struct pat:compound (_base '#:pair (list _head tail)))
(check-list-pattern tail stx)]
[(struct pat:name (_ pattern _))
(check-list-pattern pattern stx)]
[else
(wrong-syntax stx "expected proper list pattern")]))
(define (parse-ehpat/optional stx decls)
(syntax-case stx (~optional)
[(~optional p . options)
(let ([head (parse-head-pattern #'p decls)])
(with-syntax ([((too-many-msg) (name))
(parse-kw-options #'options
(list (list '#:too-many values)
(list '#:name values))
(list (list '#:too-many #'#f)
(list '#:name #'#f))
#:context stx)])
(make ehpat (map attr-make-uncertain (pattern-attrs head))
head
(make rep:optional #'name #'too-many-msg))))]))
(define (parse-ehpat/once stx decls)
(syntax-case stx (~once)
[(~once p . options)
(let ([head (parse-head-pattern #'p decls)])
(with-syntax ([((too-few-msg) (too-many-msg) (name))
(parse-kw-options #'options
(list (list '#:too-few values)
(list '#:too-many values)
(list '#:name values))
(list (list '#:too-few #'#f)
(list '#:too-many #'#f)
(list '#:name #'#f))
#:context stx)])
(make ehpat (pattern-attrs head)
head
(make rep:once #'name #'too-few-msg #'too-many-msg))))]))
(define (parse-ehpat/bounds stx decls)
(syntax-case stx (~bounds)
[(~bounds p min max . options)
(let ([head (parse-head-pattern #'p decls)])
(define minN (syntax-e #'min))
(define maxN (syntax-e #'max))
(unless (exact-nonnegative-integer? minN)
(wrong-syntax #'min
"expected exact nonnegative integer"))
(unless (or (exact-nonnegative-integer? maxN) (= +inf.0 maxN))
(wrong-syntax #'max
"expected exact nonnegative integer or +inf.0"))
(when (> minN maxN)
(wrong-syntax stx "minumum larger than maximum repetition constraint"))
(with-syntax ([((too-few-msg) (too-many-msg) (name))
(parse-kw-options #'options
(list (list '#:too-few values)
(list '#:too-many values)
(list '#:name values))
(list (list '#:too-few #'#f)
(list '#:too-many #'#f)
(list '#:name #'#f)))])
(make ehpat (map increase-depth (pattern-attrs head))
head
(make rep:bounds #'min #'max #'name #'too-few #'too-many))))]))
;; -----
;; parse-pattern-directives : stxs(PatternDirective) <kw-args>
;; -> stx DeclEnv (listof SideClause)
(define (parse-pattern-directives stx
#:decls [decls #f]
#:allow-declare? [allow-declare? #t])
(define-values (chunks rest)
(chunk-kw-seq stx pattern-directive-table))
(define-values (decls2 chunks2)
(if allow-declare?
(grab-decls chunks decls)
(values decls chunks)))
(define sides
;; NOTE: use *original* decls
;; because decls2 has #:declares for *above* pattern
(parse-pattern-sides chunks2 decls))
(values rest decls2 (parse-pattern-sides chunks2 decls)))
;; parse-pattern-sides : (listof chunk) DeclEnv
;; -> (listof SideClause/c)
;; Invariant: decls contains only literals bindings
(define (parse-pattern-sides chunks decls)
(match chunks
[(cons (list '#:declare declare-stx _ _) rest)
(wrong-syntax declare-stx
"#:declare can only follow pattern or #:with clause")]
[(cons (list '#:fail-when fw-stx when-condition expr) rest)
(cons (make clause:fail when-condition expr)
(parse-pattern-sides rest decls))]
[(cons (list '#:fail-unless fu-stx unless-condition expr) rest)
(cons (make clause:fail #`(not #,unless-condition) expr)
(parse-pattern-sides rest decls))]
[(cons (list '#:with with-stx pattern expr) rest)
(let-values ([(decls2 rest) (grab-decls rest decls)])
(let-values ([(decls2a defs) (decls-create-defs decls2)])
(cons (make clause:with (parse-whole-pattern pattern decls2a) expr defs)
(parse-pattern-sides rest decls))))]
[(cons (list '#:attr attr-stx a expr) rest)
(cons (make clause:attr a expr)
(parse-pattern-sides rest decls))]
['()
'()]))
;; grab-decls : (listof chunk) DeclEnv
;; -> (values DeclEnv (listof chunk))
(define (grab-decls chunks decls)
(define (add-decl stx decls)
(syntax-case stx ()
[(#:declare name sc)
(identifier? #'sc)
(add-decl* #'name #'sc null)]
[(#:declare name (sc expr ...))
(identifier? #'sc)
(add-decl* #'name #'sc (syntax->list #'(expr ...)))]
[(#:declare name bad-sc)
(wrong-syntax #'bad-sc
"expected syntax class name (possibly with parameters)")]))
(define (add-decl* id sc-name args)
(declenv-put-stxclass decls id sc-name args))
(define (loop chunks decls)
(match chunks
[(cons (cons '#:declare decl-stx) rest)
(loop rest (add-decl decl-stx decls))]
[else (values decls chunks)]))
(loop chunks decls))
;; check-lit-string : stx -> string
(define (check-lit-string stx)
(let ([x (syntax-e stx)])
(unless (string? x)
(wrong-syntax stx "expected string literal"))
x))
;; check-attr-arity-list : stx -> (listof SAttr)
(define (check-attr-arity-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected list of attribute declarations"))
(let ([iattrs (map check-attr-arity (stx->list stx))])
(iattrs->sattrs (append-iattrs (map list iattrs)))))
;; check-attr-arity : stx -> IAttr
(define (check-attr-arity stx)
(syntax-case stx ()
[attr
(identifier? #'attr)
(make-attr #'attr 0 #f)]
[(attr depth)
(begin (unless (identifier? #'attr)
(wrong-syntax #'attr "expected attribute name"))
(unless (exact-nonnegative-integer? (syntax-e #'depth))
(wrong-syntax #'depth "expected depth (nonnegative integer)"))
(make-attr #'attr (syntax-e #'depth) #f))]
[_
(wrong-syntax stx "expected attribute name with optional depth declaration")]))
;; check-literals-list : syntax -> (listof id)
(define (check-literals-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected literals list"))
(let ([lits (map check-literal-entry (stx->list stx))])
(let ([dup (check-duplicate-identifier (map car lits))])
(when dup (wrong-syntax dup "duplicate literal identifier")))
lits))
(define (check-literal-entry stx)
(syntax-case stx ()
[(internal external)
(and (identifier? #'internal) (identifier? #'external))
(list #'internal #'external)]
[id
(identifier? #'id)
(list #'id #'id)]
[_
(wrong-syntax stx
"expected literal (identifier or pair of identifiers)")]))
(define (check-literal-sets-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected literal-set list"))
(map check-literal-set-entry (stx->list stx)))
(define (check-literal-set-entry stx)
(define (elaborate litset-id context)
(let ([litset (syntax-local-value litset-id (lambda () #f))])
(unless (literalset? litset)
(wrong-syntax litset-id "expected identifier defined as a literal-set"))
(elaborate-litset litset context stx)))
(syntax-case stx ()
[(litset #:at context)
(and (identifier? #'litset) (identifier? #'context))
(elaborate #'litset #'context)]
[litset
(identifier? #'litset)
(elaborate #'litset #'litset)]
[_
(wrong-syntax stx "expected literal-set entry")]))
(define (elaborate-litset litset context ctx)
(for/list ([entry (literalset-literals litset)])
(list (datum->syntax context (car entry) ctx)
(cadr entry))))
(define (check-conventions-list stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected conventions list"))
(map check-conventions (stx->list stx)))
(define (check-conventions stx)
(define (elaborate conventions-id)
(let ([cs (syntax-local-value conventions-id (lambda () #f))])
(unless (conventions? cs)
(wrong-syntax conventions-id "expected identifier defined as a conventions"))
(conventions-rules cs)))
(syntax-case stx ()
[conventions
(identifier? #'conventions)
(elaborate #'conventions)]
[_
(wrong-syntax stx "expected conventions entry")]))
(define (check-conventions-rules stx)
(unless (stx-list? stx)
(wrong-syntax stx "expected convention rule list"))
(map check-conventions-rule (stx->list stx)))
(define (check-conventions-rule stx)
(define (check-conventions-pattern x blame)
(cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))]
[(regexp? x) x]
[else (wrong-syntax blame "expected identifier convention pattern")]))
(define (check-sc-expr x)
(syntax-case x ()
[sc (identifier? #'sc) (list #'sc null)]
[(sc arg ...) (identifier? #'sc) (list #'sc #'(arg ...))]
[_ (wrong-syntax x "expected syntax class use")]))
(syntax-case stx ()
[(rx sc)
(list (check-conventions-pattern (syntax-e #'rx) #'rx)
(check-sc-expr #'sc))]))
;; parse-directive-table
(define parse-directive-table
(list (list '#:literals check-literals-list)
(list '#:literal-sets check-literal-sets-list)
(list '#:conventions check-conventions-list)))
;; rhs-directive-table
(define rhs-directive-table
(list* (list '#:description values)
(list '#:transparent)
(list '#:attributes check-attr-arity-list)
parse-directive-table))
;; pattern-directive-table
(define pattern-directive-table
(list (list '#:declare check-id values)
(list '#:fail-when values values)
(list '#:fail-unless values values)
(list '#:with values values)
(list '#:attr check-attr-arity values)))
;; fail-directive-table
(define fail-directive-table
(list (list '#:when values)
(list '#:unless values)))

149
collects/syntax/private/stxparse/runtime-prose.ss Normal file
View File

@ -0,0 +1,149 @@
#lang scheme/base
(require scheme/contract
scheme/list
scheme/match
scheme/stxparam
syntax/stx
(for-syntax scheme/base)
(for-syntax syntax/stx)
(for-syntax scheme/private/sc)
(for-syntax "rep-data.ss")
(for-syntax "../util/error.ss")
"runtime.ss")
(provide default-failure-handler)
(define (default-failure-handler stx0 f)
(match (simplify-failure f)
[(struct failure (x frontier frontier-stx expected))
(report-failure stx0 x (last frontier) frontier-stx expected)]))
;; 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)
(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) ""]
[(= index +inf.0) " after matching main pattern"]
[else (format " after ~s ~a"
index
(if (= 1 index) "term" "terms"))]))
stx0
frontier-stx))]
[else
(err #f stx0 stx0)]))
;; FIXME: try different selection/simplification algorithms/heuristics
(define (simplify-failure f)
(match f
[(struct join-failures (f1 f2))
(choose-error (simplify-failure f1) (simplify-failure f2))]
[(struct failure (x frontier frontier-stx expectation))
(match expectation
[(struct expect:thing (description (and transparent? #t) chained))
(match (simplify-failure (adjust-failure chained frontier frontier-stx))
[(struct failure (_ _ _ (? ineffable?)))
;; If unfolded failure is ineffable, fall back to the one with description
f]
[new-f new-f])]
[_ f])]))
(define (adjust-failure f base-frontier base-frontier-stx)
(match f
[(struct join-failures (f1 f2))
(make-join-failures
(adjust-failure f1 base-frontier base-frontier-stx)
(adjust-failure f2 base-frontier base-frontier-stx))]
[(struct failure (x frontier frontier-stx expectation))
(let-values ([(frontier frontier-stx)
(combine-frontiers base-frontier base-frontier-stx
frontier frontier-stx)])
(make-failure x frontier frontier-stx expectation))]))
(define (combine-frontiers dfc0 stx0 dfc stx)
(cond [(null? (cdr dfc0))
(values (cons (+ (car dfc0) (car dfc))
(cdr dfc))
(if (null? (cdr dfc))
stx0
stx))]
[else
(let-values ([(f s) (combine-frontiers (cdr dfc0) stx0 dfc stx)])
(values (cons (car dfc0) f) s))]))
;; choose-error : Failure Failure -> Result
(define (choose-error f1 f2)
(case (compare-dfcs (failure-frontier f1) (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)
(failure-frontier-stx 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 ([parts
(for/list ([alt (expect->alternatives e)])
(for-alternative alt index stx))])
(join-sep parts ";" "or"))]
[(eq? e 'ineffable)
#f]))
(define (for-alternative e index stx)
(match e
[(struct expect:thing (description transparent? chained))
(format "expected ~a" description)]
[(struct expect:atom (atom))
(format "expected the literal ~s" atom)]
[(struct expect:literal (literal))
(format "expected the literal identifier ~s" (syntax-e literal))]
[(struct expect:message (message))
(format "~a" message)]
[(struct 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))]))

382
collects/syntax/private/stxparse/runtime.ss Normal file
View File

@ -0,0 +1,382 @@
#lang scheme/base
(require scheme/contract
scheme/match
scheme/stxparam
(for-syntax scheme/base
syntax/stx
scheme/private/sc
"rep-data.ss"
"rep-attrs.ss"
"../util.ss"))
(provide pattern
~and
~or
~seq
~bounds
~once
~optional
~rest
~struct
~!
~describe
~bind
~fail
current-expression
current-macro-name
this-syntax
compare-dfcs
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 ~and)
(define-keyword ~or)
(define-keyword ~seq)
(define-keyword ~bounds)
(define-keyword ~once)
(define-keyword ~optional)
(define-keyword ~rest)
(define-keyword ~struct)
(define-keyword ~!)
(define-keyword ~describe)
(define-keyword ~bind)
(define-keyword ~fail)
;; == 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)
;; A DFC is a list of numbers.
;; compare-dfcs : DFC DFC -> (one-of '< '= '>)
;; Note A>B means A is "further along" than B.
(define (compare-dfcs a b)
(cond [(and (null? a) (null? b))
'=]
[(and (pair? a) (null? b))
'>]
[(and (null? a) (pair? b))
'<]
[(and (pair? a) (pair? b))
(cond [(> (car a) (car b)) '>]
[(< (car a) (car b)) '<]
[else (compare-dfcs (cdr a) (cdr 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 stx expectation/c)
;; (make-join-failures Failure Failure)
(define ok? list?)
(define-struct failure (stx frontier frontier-stx expectation) #:transparent)
(define-struct join-failures (f1 f2) #:transparent)
;; (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
#|
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 e)
(cond [(expect:disj? e)
(union (expect->alternatives (expect:disj-a e))
(expect->alternatives (expect:disj-b e)))]
[else (list e)]))
(let ([alts (loop e)])
(if (for/or ([alt alts]) (eq? alt 'ineffable))
#f
alts)))
;; FIXME: n^2 use of union above
(define (union a b)
(append a (for/list ([x b] #:when (not (member x a))) x)))
(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
"attribute is bound to non-syntax value"
(quote-syntax
#,(datum->syntax
stx
(attribute-mapping-name self)
stx)))))))))
;; 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
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(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)

213
collects/syntax/private/stxparse/sc.ss Normal file
View File

@ -0,0 +1,213 @@
#lang scheme/base
(require (for-syntax scheme/base
scheme/match
scheme/private/sc
"rep-data.ss"
"rep.ss"
"../util.ss")
scheme/match
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
debug-rhs
debug-pattern
syntax-parse
syntax-parser
pattern
~and
~or
~seq
~bounds
~once
~optional
~rest
~struct
~!
~describe
~bind
~fail
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 #t splicing? stx))])
(with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))]
[attrs (rhs-attrs the-rhs)])
#`(begin (define-syntax name
(make stxclass 'name '(arg ...)
'attrs
((syntax-local-certifier) (quote-syntax parser))
((syntax-local-certifier) (quote-syntax description))
'#,splicing?))
(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? #'(name arg ...))
(defstxclass stx #'name #'(arg ...) #'rhss #t)]))
(define-syntax (define-conventions stx)
(syntax-case stx ()
[(define-conventions name rule ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(with-syntax ([([entry (def ...)] ...)
(for/list ([line (check-conventions-rules #'(rule ...))])
(let ([rx (car line)]
[sc (car (cadr line))]
[args (cadr (cadr line))])
(let-values ([(parser description attrs defs)
(create-aux-def (list 'stxclass rx sc args))])
(list #`(list (quote #,rx)
(list 'parser
(quote-syntax #,parser)
(quote-syntax #,description)
(quote #,attrs)))
defs))))])
#'(begin
def ... ...
(define-syntax name
(make-conventions
(list entry ...))))))]))
(define-syntax (define-literal-set stx)
(syntax-case stx ()
[(define-literal-set name (lit ...))
(begin
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(let ([lits (check-literals-list #'(lit ...))])
(with-syntax ([((internal external) ...) lits])
#'(define-syntax name
(make-literalset
(list (list 'internal (quote-syntax external)) ...))))))]))
;; ----
(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 #f (syntax-e #'splicing?) #'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 (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p)
(let ([p (parse-whole-pattern #'p (new-declenv null))])
#`(quote #,p))]))
(define-syntax-rule (syntax-parse stx-expr . clauses)
(let ([x stx-expr])
(syntax-parse* syntax-parse x . clauses)))
(define-syntax-rule (syntax-parser . clauses)
(lambda (x) (syntax-parse* syntax-parser x . clauses)))
(define-syntax (syntax-parse* stx)
(syntax-case stx ()
[(syntax-parse report-as expr . clauses)
(with-disappeared-uses
(parameterize ((current-syntax-context
(syntax-property stx
'report-errors-as
(syntax-e #'report-as))))
#`(let ([x expr])
(let ([fail (syntax-patterns-fail x)])
(with-enclosing-fail* fail
(parameterize ((current-expression (or (current-expression) x)))
(parse:clauses x clauses)))))))]))
(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)])]))
;; Failure reporting parameter & default
(define current-failure-handler
(make-parameter default-failure-handler))
(define ((syntax-patterns-fail stx0) f)
(let ([value ((current-failure-handler) stx0 f)])
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e" value)))

9
collects/syntax/private/util.ss Normal file
View File

@ -0,0 +1,9 @@
#lang scheme/base
(require "util/error.ss"
"util/expand.ss"
"util/misc.ss"
"util/struct.ss")
(provide (all-from-out "util/error.ss")
(all-from-out "util/expand.ss")
(all-from-out "util/misc.ss")
(all-from-out "util/struct.ss"))

16
collects/syntax/private/util/error.ss Normal file
View File

@ -0,0 +1,16 @@
#lang scheme/base
(provide wrong-syntax
current-syntax-context)
(define current-syntax-context (make-parameter #f))
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))
(raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)]
[blame (and (syntax? ctx) (syntax-property ctx 'report-errors-as))])
(raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args)
ctx
(or stx ctx)
extras)))

88
collects/syntax/private/util/expand.ss Normal file
View File

@ -0,0 +1,88 @@
#lang scheme/base
(require syntax/kerncase
syntax/stx)
(provide head-local-expand-and-categorize-syntaxes
categorize-expanded-syntaxes
head-local-expand-syntaxes)
;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6
;; Setting allow-def-after-expr? allows def/expr interleaving.
(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?)
(define estxs (head-local-expand-syntaxes x allow-def-after-expr?))
(define-values (defs vdefs sdefs exprs)
(categorize-expanded-syntaxes estxs))
(values estxs estxs defs vdefs sdefs exprs))
;; categorize-expanded-syntaxes : (listof stx) -> stxs ^ 4
;; Split head-expanded stxs into
;; definitions, values-definitions, syntaxes-definitions, exprs
;; (definitions include both values-definitions and syntaxes-definitions.)
(define (categorize-expanded-syntaxes estxs0)
(let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null])
(cond [(pair? estxs)
(let ([ee (car estxs)])
(syntax-case ee (begin define-values define-syntaxes)
[(define-values . _)
(loop (cdr estxs)
(cons ee defs)
(cons ee vdefs)
sdefs
exprs)]
[(define-syntaxes (var ...) rhs)
(loop (cdr estxs)
(cons ee defs)
vdefs
(cons ee sdefs)
exprs)]
[_
(loop (cdr estxs)
defs
vdefs
sdefs
(cons ee exprs))]))]
[(null? estxs)
(values (reverse defs)
(reverse vdefs)
(reverse sdefs)
(reverse exprs))])))
;; head-local-expand-syntaxes : syntax boolean -> (listof syntax)
(define (head-local-expand-syntaxes x allow-def-after-expr?)
(let ([intdef (syntax-local-make-definition-context)]
[ctx '(block)])
(let loop ([x x] [ex null] [expr? #f])
(cond [(stx-pair? x)
(let ([ee (local-expand (stx-car x)
ctx
(kernel-form-identifier-list)
intdef)])
(syntax-case ee (begin define-values define-syntaxes)
[(begin e ...)
(loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)]
[(begin . _)
(raise-syntax-error #f "bad begin form" ee)]
[(define-values (var ...) rhs)
(andmap identifier? (syntax->list #'(var ...)))
(begin
(when (and expr? (not allow-def-after-expr?))
(raise-syntax-error #f "definition after expression" ee))
(syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef)
(loop (stx-cdr x) (cons ee ex) expr?))]
[(define-values . _)
(raise-syntax-error #f "bad define-values form" ee)]
[(define-syntaxes (var ...) rhs)
(andmap identifier? (syntax->list #'(var ...)))
(begin
(when (and expr? (not allow-def-after-expr?))
(raise-syntax-error #f "definition after expression" ee))
(syntax-local-bind-syntaxes (syntax->list #'(var ...))
#'rhs
intdef)
(loop (stx-cdr x) (cons ee ex) expr?))]
[(define-syntaxes . _)
(raise-syntax-error #f "bad define-syntaxes form" ee)]
[_
(loop (stx-cdr x) (cons ee ex) #t)]))]
[(stx-null? x)
(internal-definition-context-seal intdef)
(reverse ex)]))))

239
collects/syntax/private/util/misc.ss Normal file
View File

@ -0,0 +1,239 @@
#lang scheme/base
(require syntax/kerncase
syntax/stx
(for-syntax scheme/base
scheme/private/sc))
(provide unwrap-syntax
define-pattern-variable
with-temporaries
generate-temporary
generate-n-temporaries
current-caught-disappeared-uses
with-catching-disappeared-uses
with-disappeared-uses
syntax-local-value/catch
record-disappeared-uses
format-symbol
in-stx-list
in-stx-list/unwrap
parse-kw-options
extract-kw-option
chunk-kw-seq/no-dups
chunk-kw-seq/no-dups/eol
chunk-kw-seq
reject-duplicate-chunks
check-id
check-nat/f
check-string
check-idlist)
;; Unwrapping syntax
;; unwrap-syntax : any #:stop-at (any -> boolean) -> any
(define (unwrap-syntax stx #:stop-at [stop-at (lambda (x) #f)])
(let loop ([x stx])
(cond [(stop-at x) x]
[(syntax? x) (loop (syntax-e x))]
[(pair? x) (cons (loop (car x)) (loop (cdr x)))]
[(vector? x) (apply vector-immutable (loop (vector->list x)))]
[(box? x) (box-immutable (loop (unbox x)))]
[(prefab-struct-key x)
=> (lambda (key)
(apply make-prefab-struct key
(loop (cdr (vector->list (struct->vector x))))))]
[else x])))
;; Defining pattern variables
(define-syntax-rule (define-pattern-variable name expr)
(begin (define var expr)
(define-syntax name (make-syntax-mapping '0 (quote-syntax var)))))
;; Statics and disappeared uses
(define current-caught-disappeared-uses (make-parameter #f))
(define-syntax-rule (with-catching-disappeared-uses . body)
(parameterize ((current-caught-disappeared-uses null))
(let ([result (let () . body)])
(values result (current-caught-disappeared-uses)))))
(define-syntax-rule (with-disappeared-uses stx-expr)
(let-values ([(stx disappeared-uses)
(with-catching-disappeared-uses stx-expr)])
(syntax-property stx
'disappeared-use
(append (or (syntax-property stx 'disappeared-use) null)
disappeared-uses))))
(define (syntax-local-value/catch id pred)
(let ([value (syntax-local-value id (lambda () #f))])
(and (pred value)
(begin (record-disappeared-uses (list id))
value))))
(define (record-disappeared-uses ids)
(let ([uses (current-caught-disappeared-uses)])
(when uses
(current-caught-disappeared-uses (append ids uses)))))
;; Generating temporaries
;; with-temporaries
(define-syntax-rule (with-temporaries (temp-name ...) . body)
(with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))])
. body))
;; generate-temporary : any -> identifier
(define (generate-temporary [stx 'g])
(car (generate-temporaries (list stx))))
;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier)
(define (generate-n-temporaries n)
(generate-temporaries
(for/list ([i (in-range n)])
(string->symbol (format "g~sx" i)))))
;; Symbol Formatting
(define (format-symbol fmt . args)
(let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))])
(string->symbol (apply format fmt args))))
;; Syntax list sequence
(define (in-stx-list x)
(let ([l (stx->list x)])
(unless l
(raise-type-error 'in-stx-list "syntax list" x))
(in-list l)))
(define (in-stx-list/unwrap x)
(let ([l (stx->list x)])
(unless l
(raise-type-error 'in-stx-list "syntax list" x))
(in-list (map syntax-e l))))
;; Parsing keyword arguments
;; parse-kw-options : ...
(define (parse-kw-options stx table extractions #:context [ctx #f])
(let ([chunks (chunk-kw-seq/no-dups/eol stx table #:context ctx)])
(for/list ([ex extractions])
(extract-kw-option chunks ex))))
;; extract-kw-option : ...
(define (extract-kw-option chunks ex)
(let ([entry (assq (car ex) chunks)])
(if entry
(cddr entry)
(cdr ex))))
;; chunk-kw-seq/no-dups/eol : ...
(define (chunk-kw-seq/no-dups/eol stx kws #:context [ctx #f] #:only [only #f])
(let-values ([(chunks rest) (chunk-kw-seq/no-dups stx kws #:context ctx #:only only)])
(unless (stx-null? rest)
(raise-syntax-error #f "unexpected terms after keyword arguments" ctx stx))
chunks))
;; chunk-kw-seq/no-dups : syntax
;; alist[keyword => (listof (stx -> any))]
;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx)
(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f] #:only [only #f])
(let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)])
(reject-duplicate-chunks chunks #:context ctx #:only only)
(values chunks rest)))
;; chunk-kw-seq : stx
;; alist[keyword => (listof (stx -> any))
;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx)
(define (chunk-kw-seq stx kws #:context [ctx #f])
(define (loop stx rchunks)
(syntax-case stx ()
[(kw . more)
(and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws))
(let* ([kw-value (syntax-e #'kw)]
[arity (cdr (assq kw-value kws))]
[args+rest (stx-split #'more arity)])
(if args+rest
(loop (cdr args+rest)
(cons (list* kw-value #'kw (car args+rest)) rchunks))
(raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
[(kw . more)
(keyword? (syntax-e #'kw))
(raise-syntax-error #f
(format "unexpected keyword, expected one of ~s" (map car kws))
ctx
#'kw)]
[_
(values (reverse rchunks) stx)]))
(loop stx null))
;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void
(define (reject-duplicate-chunks chunks
#:context [ctx #f]
#:only [only #f])
(define kws (make-hasheq))
(define (loop chunks)
(when (pair? chunks)
(let ([kw (caar chunks)])
(when (or (not only) (memq kw only))
(when (hash-ref kws kw #f)
(raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx))
(hash-set! kws kw #t)))
(loop (cdr chunks))))
(loop chunks))
;; alist-select : (listof (cons A B)) A -> (listof B)
(define (alist-select alist key)
(cond [(pair? alist)
(if (eq? (caar alist) key)
(cons (cdar alist) (alist-select (cdr alist) key))
(alist-select (cdr alist) key))]
[else null]))
;; stx-split : stx nat -> (cons (listof stx) stx)
(define (stx-split stx procs)
(define (loop stx procs acc)
(cond [(null? procs)
(cons (reverse acc) stx)]
[(stx-pair? stx)
(loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))]
[else #f]))
(loop stx procs null))
;; check-id : stx -> identifier
(define (check-id stx)
(unless (identifier? stx)
(raise-syntax-error 'pattern "expected identifier" stx))
stx)
;; check-string : stx -> stx
(define (check-string stx)
(unless (string? (syntax-e stx))
(raise-syntax-error #f "expected string" stx))
stx)
;; nat/f : any -> boolean
(define (nat/f x)
(or (not x) (exact-nonnegative-integer? x)))
;; check-nat/f : stx -> stx
(define (check-nat/f stx)
(let ([d (syntax-e stx)])
(unless (nat/f d)
(raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
stx))
;; check-idlist : stx -> (listof identifier)
(define (check-idlist stx)
(unless (and (stx-list? stx) (andmap identifier? (stx->list stx)))
(raise-syntax-error #f "expected list of identifiers" stx))
(stx->list stx))

39
collects/syntax/private/util/struct.ss Normal file
View File

@ -0,0 +1,39 @@
#lang scheme/base
(require (for-syntax scheme/base
scheme/struct-info))
(provide make)
;; (make struct-name field-expr ...)
;; Checks that correct number of fields given.
(define-syntax (make stx)
(define (bad-struct-name x)
(raise-syntax-error #f "expected struct name" stx x))
(define (get-struct-info id)
(unless (identifier? id)
(bad-struct-name id))
(let ([value (syntax-local-value id (lambda () #f))])
(unless (struct-info? value)
(bad-struct-name id))
(extract-struct-info value)))
(syntax-case stx ()
[(make S expr ...)
(let ()
(define info (get-struct-info #'S))
(define constructor (list-ref info 1))
(define accessors (list-ref info 3))
(unless (identifier? #'constructor)
(raise-syntax-error #f "constructor not available for struct" stx #'S))
(unless (andmap identifier? accessors)
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
(let ([num-slots (length accessors)]
[num-provided (length (syntax->list #'(expr ...)))])
(unless (= num-provided num-slots)
(raise-syntax-error
#f
(format "wrong number of arguments for struct ~s (expected ~s)"
(syntax-e #'S)
num-slots)
stx)))
(with-syntax ([constructor constructor])
#'(constructor expr ...)))]))

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

@ -4,6 +4,10 @@
@title[#:tag "boundmap"]{Hashing on @scheme[bound-identifier=?] and @scheme[free-identifier=?]}
See also @schememodname[syntax/id-table] for an implementation of
identifier mappings using the @schememodname[scheme/dict] dictionary
interface.
@defmodule[syntax/boundmap]
@defproc[(make-bound-identifier-mapping) bound-identifier-mapping?]{
@ -120,4 +124,4 @@ Like @scheme[hash-table-map].}
(listof any?)]
)]{
The same as @scheme[make-module-identifier-mapping], etc.}
The same as @scheme[make-free-identifier-mapping], etc.}

202
collects/syntax/scribblings/id-table.scrbl Normal file
View File

@ -0,0 +1,202 @@
#lang scribble/doc
@(require "common.ss"
(for-label syntax/id-table)
(for-label scheme/dict))
@title[#:tag "idtable"]{Identifier dictionaries}
@defmodule[syntax/id-table]
This module provides functionality like that of
@schememodname[syntax/boundmap] but with more operations, standard
names, implementation of the @schememodname[scheme/dict] interface,
and immutable (functionally-updating) variants.
@section{Dictionaries for @scheme[bound-identifier=?]}
Bound-identifier tables implement the dictionary interface of
@scheme[scheme/dict]. Consequently, all of the appropriate generic
functions (@scheme[dict-ref], @scheme[dict-map], etc) can be used on
free-identifier tables.
@deftogether[[
@defproc[(make-bound-id-table [init-dict dict? null])
mutable-bound-id-table?]
@defproc[(make-immutable-bound-id-table [init-dict dict? null])
immutable-bound-id-table?]]]{
Produces a dictionary mapping syntax identifiers to arbitrary
values. The mapping uses @scheme[bound-identifier=?] to compare keys,
but also uses a hash table based on symbol equality to make the
mapping efficient in the common case. The two procedures produce
mutable and immutable dictionaries, respectively.
The optional @scheme[init-dict] argument provides the initial
mappings. It must be a dictionary, and its keys must all be
identifiers. If the @scheme[init-dict] dictionary has multiple
distinct entries whose keys are @scheme[bound-identifier=?], only one
of the entries appears in the new id-table, and it is not specified
which entry is picked.
}
@defproc[(bound-id-table? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] was produced by
@scheme[make-bound-id-table] or
@scheme[make-immutable-bound-id-table], @scheme[#f] otherwise.
}
@deftogether[[
@defproc[(mutable-bound-id-table? [v any/c]) boolean?]
@defproc[(immutable-bound-id-table? [v any/c]) boolean?]
]]{
Predicate for the mutable and immutable variants of bound-identifier
tables, respectively.
}
@defproc[(bound-id-table-ref [table bound-id-table?]
[id identifier?]
[failure any/c
(lambda () (raise (make-exn:fail .....)))])
any]{
Like @scheme[hash-ref] for bound identifier tables. In particular, if
@scheme[id] is not found, the @scheme[failure] argument is applied if
it is a procedure, or simply returned otherwise.
}
@defproc[(bound-id-table-set! [table mutable-bound-id-table?]
[id identifier?]
[v any/c])
void?]{
Like @scheme[hash-set!] for mutable bound-identifier tables.
}
@defproc[(bound-id-table-set [table immutable-bound-id-table?]
[id identifier?]
[v any/c])
immutable-bound-id-table?]{
Like @scheme[hash-set] for immutable bound-identifier tables.
}
@defproc[(bound-id-table-remove! [table mutable-bound-id-table?]
[id identifier?])
void?]{
Like @scheme[hash-remove!] for mutable bound-identifier tables.
}
@defproc[(bound-id-table-remove [table immutable-bound-id-table?]
[id identifier?]
[v any/c])
immutable-bound-id-table?]{
Like @scheme[hash-remove] for immutable bound-identifier tables.
}
@defproc[(bound-id-table-map [table bound-id-table?]
[proc (-> identifier? any/c any)])
list?]{
Like @scheme[hash-map] for bound-identifier tables.
}
@defproc[(bound-id-table-for-each [table bound-id-table?]
[proc (-> identifier? any/c any)])
void?]{
Like @scheme[hash-for-each] for bound-identifier tables.
}
@defproc[(bound-id-table-count [table bound-id-table?])
exact-nonnegative-integer?]{
Like @scheme[hash-count] for bound-identifier tables.
}
@;{
@deftogether[[
@defproc[(bound-id-table-iterate-first [table bound-id-table?])
id-table-position?]
@defproc[(bound-id-table-iterate-next [table bound-id-table?]
[position id-table-position?])
id-table-position?]
@defproc[(bound-id-table-iterate-key [table bound-id-table?]
[position id-table-position?])
identifier?]
@defproc[(bound-id-table-iterate-value [table bound-it-table?]
[position id-table-position?])
identifier?]]]{
Like the corresponding dictionary procedures from
@schememodname[scheme/dict] for for bound-identifier tables.
}
}
@;{----------}
@section{Dictionaries for @scheme[free-identifier=?]}
Free-identifier tables implement the dictionary interface of
@scheme[scheme/dict]. Consequently, all of the appropriate generic
functions (@scheme[dict-ref], @scheme[dict-map], etc) can be used on
free-identifier tables.
@deftogether[[
@defproc[(make-free-id-table [init-dict dict? null])
mutable-free-id-table?]
@defproc[(make-immutable-free-id-table [init-dict dict? null])
immutable-free-id-table?]
@defproc[(free-id-table? [v any/c]) boolean?]
@defproc[(mutable-free-id-table? [v any/c]) boolean?]
@defproc[(immutable-free-id-table? [v any/c]) boolean?]
@defproc[(free-id-table-ref [table free-id-table?]
[id identifier?]
[failure any/c
(lambda () (raise (make-exn:fail .....)))])
any]
@defproc[(free-id-table-set! [table mutable-free-id-table?]
[id identifier?]
[v any/c])
void?]
@defproc[(free-id-table-set [table immutable-free-id-table?]
[id identifier?]
[v any/c])
immutable-free-id-table?]
@defproc[(free-id-table-remove! [table mutable-free-id-table?]
[id identifier?])
void?]
@defproc[(free-id-table-remove [table immutable-free-id-table?]
[id identifier?]
[v any/c])
immutable-free-id-table?]
@defproc[(free-id-table-map [table free-id-table?]
[proc (-> identifier? any/c any)])
list?]
@defproc[(free-id-table-for-each [table free-id-table?]
[proc (-> identifier? any/c any)])
void?]
@defproc[(free-id-table-count [table free-id-table?])
exact-nonnegative-integer?]
@;{
@defproc[(free-id-table-iterate-first [table free-id-table?])
id-table-position?]
@defproc[(free-id-table-iterate-next [table free-id-table?]
[position id-table-position?])
id-table-position?]
@defproc[(free-id-table-iterate-key [table free-id-table?]
[position id-table-position?])
identifier?]
@defproc[(free-id-table-iterate-value [table free-it-table?]
[position id-table-position?])
identifier?]
}]]{
Like the procedures for bound-identifier tables
(@scheme[make-bound-id-table], @scheme[bound-id-table-ref], etc), but
for free-identifier tables, which use @scheme[free-identifier=?] to
compare keys.
}

926
collects/syntax/scribblings/parse.scrbl Normal file
View File

@ -0,0 +1,926 @@
#lang scribble/doc
@(require scribble/manual
scribble/struct
scribble/decode
scribble/eval
scheme/sandbox
(for-label scheme/base
scheme/contract
syntax/parse
syntax/kerncase))
@(define ellipses @scheme[...])
@(begin
(define the-eval
(parameterize ((sandbox-output 'string)
(sandbox-error-output 'string))
(make-evaluator 'scheme/base #:requires '(syntax/parse))))
(define-syntax-rule (myexamples e ...)
(parameterize ((error-print-source-location #f))
(examples #:eval the-eval e ...))))
@title[#:tag "stxparse"]{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].
@defmodule[syntax/parse]
@;{----------}
@section{Parsing syntax}
This section describes the @scheme[syntax-parse] pattern matching
form, syntax patterns, and attributes.
@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+)
([parse-option (code:line #:literals (literal ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))]
[literal literal-id
(pattern-id literal-id)]
[literal-set literal-set-id
[literal-set-id #:at context-id]]
[clause (syntax-pattern pattern-directive ... expr)])]{
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 @scheme[#:literals] option specifies identifiers that should match
as literals, rather than simply being pattern variables. A literal 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 single-identifier form is used, the same
identifier is used for both purposes.
Many literals can be declared at once via one or more @tech{literal sets},
imported with the @scheme[#:literal-sets] option. The literal-set
definition determines the literal identifiers to recognize and the
names used in the patterns to recognize those literals.
The @scheme[#:conventions] option imports @tech{convention}s that give
default syntax classes to pattern variables that do not explicitly
specify a syntax class.
}
@defform[(syntax-parser maybe-literals clause ...)]{
Like @scheme[syntax-parse], but produces a matching procedure. The
procedure accepts a single argument, which should be a syntax object.
}
The grammar of @deftech{syntax patterns} accepted by
@scheme[syntax-parse] and @scheme[syntax-parser] is given in the
following table:
@schemegrammar*[#:literals (_ ~or ~and ~seq ~rep ~once ~optional
~rest ~struct ~! ~describe ~bind ~fail)
[S-pattern
pvar-id
pvar-id:syntax-class-id
literal-id
atomic-datum
(H-pattern . S-pattern)
((~or EH-pattern ...+) #,ellipses . S-pattern)
(EH-pattern #,ellipses . S-pattern)
(~and S-pattern ...+)
(~or S-pattern ...+)
#((unsyntax @svar[pattern-part]) ...)
#s(prefab-struct-key (unsyntax @svar[pattern-part]) ...)
(~rest S-pattern)
(~describe expr S-pattern)
(~! . S-pattern)
(~bind [attr-id expr] ...)
(~fail maybe-fail-condition message-expr)]
[L-pattern
()
(H-pattern . L-pattern)
((~or EH-pattern ...+) #,ellipses . L-pattern)
(EH-pattern #,ellipses . L-pattern)
(~rest L-pattern)
(~! . L-pattern)]
[H-pattern
(~or H-pattern ...+)
(~seq . L-pattern)
(~describe expr H-pattern)
S-pattern]
[EH-pattern
(~once H-pattern once-option ...)
(~optional H-pattern optional-option ...)
H-pattern]]
There are three main kinds of syntax pattern: @tech{S-patterns} (for
``single patterns''), @tech{H-patterns} (for ``head patterns''), and
@tech{EH-patterns} (for ``ellipsis head patterns''). A fourth kind,
@tech{L-patterns} (for ``list patterns''), is a restricted subset of
@tech{S-patterns}. When a special form in this manual refers to
@svar[syntax-pattern] (eg, the description of the
@scheme[syntax-parse] special form), it means specifically
@tech{S-pattern}.
@subsection{S-pattern variants}
An @deftech{S-pattern} (for ``single pattern'') is a pattern that
describes a single term. The pattern may, of course, consist of other
parts. For example, @scheme[(17 ...)] is an @tech{S-pattern}
that matches any term that is a proper list of repeated
@schemeresult[17] numerals. The @deftech{L-pattern}s (for ``list
pattern'') are @tech{S-pattern} having a restricted structure that
constrains it to match only terms that are proper lists.
Here are the variants of @tech{S-pattern}:
@specsubform[pvar-id]{
If @scheme[pvar-id] has no syntax class (by @scheme[#:declare] or
@scheme[#:convention]), the pattern matches anything. The pattern
variable is bound to the matched subterm, unless the pattern variable
is the wildcard (@scheme[_]), in which case no binding occurs.
If @scheme[pvar-id] does have an associated syntax class, it behaves
like the following form.
}
@specsubform[pvar-id:syntax-class-id]{
Matches only subterms specified by the @svar[syntax-class-id]. The
syntax class's attributes are computed for the subterm and bound to
the pattern variables formed by prefixing @svar[pvar-id.] to the
name of the attribute. @svar[pvar-id] is bound to the matched
subterm.
If @svar[pvar-id] is @scheme[_], no attributes are bound.
If @svar[pvar-id] is empty (that is, if the pattern is of the form
@svar[:syntax-class-id]), then the syntax class's attributes are
bound, but their names are not prefixed first.
@myexamples[
(syntax-parse #'x
[var:id (syntax-e #'var)])
(syntax-parse #'12
[var:id (syntax-e #'var)])
(syntax-parse #'(x y z)
[var:id (syntax-e #'var)])]
}
@specsubform[literal-id]{
An identifier that appears in the literals list is not a pattern
variable; instead, it is a literal that matches any identifier
@scheme[free-identifier=?] to it.
Specifically, if @scheme[literal-id] is the ``pattern'' name of an
entry in the literals list, then it represents a pattern that matches
only identifiers @scheme[free-identifier=?] to the ``literal''
name. These identifiers are often the same.
@myexamples[
(syntax-parse #'(define x 12)
#:literals (define)
[(define var:id body:expr) 'ok])
(syntax-parse #'(lambda x 12)
#:literals (define)
[(define var:id body:expr) 'ok])
(syntax-parse #'(define x 12)
#:literals ([def define])
[(def var:id body:expr) 'ok])
(syntax-parse #'(lambda x 12)
#:literals ([def define])
[(def var:id body:expr) 'ok])
]
}
@specsubform[atomic-datum]{
Numbers, strings, booleans, keywords, and the empty list match as
literals.
@myexamples[
(syntax-parse #'(a #:foo bar)
[(x #:foo y) (syntax->datum #'y)])
(syntax-parse #'(a foo bar)
[(x #:foo y) (syntax->datum #'y)])
]
}
@specsubform[(H-pattern . S-pattern)]{
Matches any term that can be decomposed into a list prefix matching
the @tech{H-pattern} and a suffix matching the S-pattern.
Note that the pattern may match terms that are not even improper
lists; if the head pattern can match a zero-length head, then the
whole pattern matches whatever the tail pattern accepts.
The first pattern can be an @tech{S-pattern}, in which case the whole
pattern matches any pair whose first element matches the first pattern
and whose rest matches the second.
See @tech{H-patterns} for more information.
}
@specsubform[#:literals (~or) ((~or EH-pattern ...+) #,ellipses . S-pattern)]
@specsubform[(EH-pattern #,ellipses . S-pattern)]{
Matches any term that can be decomposed into a list head matching some
number of repetitions of the @tech{EH-pattern} alternatives (subject
to its repetition constraints) followed by a list tail matching the
S-pattern.
In other words, the whole pattern matches either the second pattern
(which need not be a list) or a term whose head matches one of the
alternatives of the first pattern and whose tail recursively matches
the whole sequence pattern.
The @scheme[~or]-free variant is shorthand for the @scheme[~or]
variant with just one alternative.
See @tech{EH-patterns} for more information.
}
@specsubform[#:literals (~and) (~and S-pattern ...)]{
Matches any syntax that matches all of the included patterns.
Attributes bound in subpatterns are available to subsequent
subpatterns. The whole pattern binds all of the subpatterns'
attributes.
One use for @scheme[~and]-patterns is preserving a whole
term (including its lexical context, source location, etc) while also
examining its structure. Syntax classes are useful for the same
purpose, but @scheme[~and] can be lighter weight.
@(interaction-eval #:eval the-eval
(begin (define (check-imports . _) #f)))
@myexamples[
(syntax-parse #'(m (import one two))
#:literals (import)
[(_ (~and import-clause (import i ...)))
(let ([bad (check-imports
(syntax->list #'(i ...)))])
(when bad
(raise-syntax-error
#f "bad import" #'import-clause bad))
'ok)])
]
}
@specsubform[#:literals (~or) (~or S-pattern ...)]{
Matches any term that matches one of the included patterns.
The whole pattern binds @emph{all} of the subpatterns' attributes. An
attribute that is not bound by the ``chosen'' subpattern has a value
of @scheme[#f]. The same attribute may be bound by multiple
subpatterns, and if it is bound by all of the subpatterns, it is sure
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)])
]
}
@specsubform[#(#, @svar[pattern-part] ...)]{
Matches a term that is a vector whose elements, when considered as a
list, match the @tech{S-pattern} corresponding to
@scheme[(pattern-part ...)].
@myexamples[
(syntax-parse #'#(1 2 3)
[#(x y z) (syntax->datum #'z)])
(syntax-parse #'#(1 2 3)
[#(x y ...) (syntax->datum #'(y ...))])
(syntax-parse #'#(1 2 3)
[#(x ~rest y) (syntax->datum #'y)])
]
}
@specsubform[#s(prefab-struct-key #, @svar[pattern-part] ...)]{
Matches a term that is a prefab struct whose key is exactly the given
key and whose sequence of fields, when considered as a list, match the
@tech{S-pattern} corresponding to @scheme[(pattern-part ...)].
@myexamples[
(syntax-parse #'#s(point 1 2 3)
[#s(point x y z) 'ok])
(syntax-parse #'#s(point 1 2 3)
[#s(point x y ...) (syntax->datum #'(y ...))])
(syntax-parse #'#s(point 1 2 3)
[#s(point x ~rest y) (syntax->datum #'y)])
]
}
@specsubform[#:literals (~rest) (~rest S-pattern)]{
Matches just like the inner @scheme[S-pattern]. The @scheme[~rest]
pattern form is useful in positions where improper lists (``dots'')
are not allowed by the reader, such as vector and structure patterns
(see above).
@myexamples[
(syntax-parse #'(1 2 3)
[(x ~rest y) (syntax->datum #'y)])
(syntax-parse #'#(1 2 3)
[#(x ~rest y) (syntax->datum #'y)])
]
}
@specsubform[#:literals (~describe) (~describe expr S-pattern)]{
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-pattern (@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.}}}
@specsubform[#:literals (~!) (~! . S-pattern)]{
The @scheme[~!] operator, pronounced ``cut'', eliminates backtracking
choice points and commits parsing to the current branch of the pattern
it is exploring.
Common opportunities for cut-patterns come from recognizing special
forms based on keywords. Consider the following expression:
@interaction[#:eval the-eval
(syntax-parse #'(define-values a 123)
#:literals (define-values define-syntaxes)
[(define-values (x:id ...) e) 'define-values]
[(define-syntaxes (x:id ...) e) 'define-syntaxes]
[e 'expression])]
Given the ill-formed term @scheme[(define-values a 123)], the
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
@scheme[syntax-parse] expression follows:
@interaction[#:eval the-eval
(syntax-parse #'(define-values a 123)
#:literals (define-values define-syntaxes)
[(define-values ~! (x:id ...) e) 'define-values]
[(define-syntaxes ~! (x:id ...) e) 'define-syntaxes]
[e 'expression])]
Now, given the same term, @scheme[syntax-parse] tries the first
clause, and since the keyword @scheme[define-values] matches, the
cut-pattern commits to the current pattern, eliminating the choice
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.
}
@specsubform[#:literals (~bind) (~bind [attr-id expr] ...)]{
This pattern matches any term. Its effect is to evaluate the
@scheme[expr]s and bind them to the given @scheme[attr-id]s as
attributes.
}
@specsubform/subs[#:literals (~fail) (~fail maybe-fail-condition message-expr)
([maybe-fail-condition (code:line)
(code:line #:when condition-expr)
(code:line #:unless condition-expr)])]{
This pattern succeeds or fails independent of the term being matched
against. 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. Otherwise the pattern succeeds.
Fail patterns can be used together with cut patterns to recognize
specific ill-formed terms and address them with specially-created
failure messages.
}
@subsection{H-pattern variants}
An @deftech{H-pattern} (for ``head pattern'') is a pattern that
describes some number of terms that occur at the head of some list
(possibly an improper list). An H-pattern's usefulness comes from
being able to match heads of different lengths. H-patterns are useful
for specifying optional forms such as keyword arguments.
Here are the variants of @tech{H-pattern}:
@specsubform[#:literals (~seq) (~seq . L-pattern)]{
Matches a head whose elements, if put in a list, would match the given
@tech{L-pattern}.
@myexamples[
(syntax-parse #'(1 2 3 4)
[((~seq 1 2 3) 4) 'ok])
]
}
@specsubform[#:literals (~or) (~or H-pattern ...)]{
Like the S-pattern version of @scheme[~or], but matches a term head
instead.
@myexamples[
(syntax-parse #'(#:foo 2 a b c)
[((~or (~seq #:foo x) (~seq)) y:id ...)
(attribute x)])
]
}
@specsubform[#:literals (~describe) (~describe expr H-pattern)]{
Like the S-pattern version of @scheme[~describe], but matches a head
pattern instead.
}
@specsubform[S-pattern]{
Matches a head of one element, which must be a term matching the given
@tech{S-pattern}.
}
@subsection{EH-pattern forms}
An @deftech{EH-pattern} (for ``ellipsis-head pattern'') is pattern
that describes some number of terms, like an @tech{H-pattern}, but may
also place contraints on the number of times it occurs in a
repetition. EH-patterns (and ellipses) are useful for matching keyword
arguments where the keywords may come in any order.
@myexamples[
(define parser1
(syntax-parser
[((~or (~once (~seq #:a x) #:name "#:a keyword")
(~optional (~seq #:b y) #:name "#:b keyword")
(~seq #:c z)) ...)
'ok]))
(parser1 #'(#:a 1))
(parser1 #'(#:b 2 #:c 3 #:c 25 #:a 'hi))
(parser1 #'(#:a 1 #:a 2))
]
The pattern requires exactly one occurrence of the @scheme[#:a]
keyword and argument, at most one occurrence of the @scheme[#:b]
keyword and argument, and any number of @scheme[#:c] keywords and
arguments. The ``pieces'' can occur in any order.
Here are the variants of @tech{EH-pattern}:
@specsubform/subs[#:literals (~once) (~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)])]{
Matches if the inner H-pattern matches. This pattern must be selected
exactly once in the match of the entire repetition sequence.
If the pattern is not chosen in the repetition sequence, then an error
is raised with a message, either @scheme[too-few-message-expr] or
@schemevalfont{"missing required occurrence of @scheme[name-expr]"}.
If the pattern is chosen more than once in the repetition sequence,
then an error is raised with a message, either
@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences
of @scheme[name-expr]"}.
}
@specsubform/subs[#:literals (~optional) (~optional H-pattern optional-option ...)
([optional-option (code:line #:name name-expr)
(code:line #:too-many too-many-message-expr)])]{
Matches if the inner H-pattern matches. This pattern may be used at
most once in the match of the entire repetition.
If the pattern is chosen more than once in the repetition sequence,
then an error is raised with a message, either
@scheme[too-many-message-expr] or @schemevalfont{"too many occurrences
of @scheme[name-expr]"}.
}
@subsection{Pattern directives}
Both @scheme[syntax-parse] and @scheme[syntax-parser] support
directives for annotating the pattern 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 #:fail-when condition-expr message-expr)
(code:line #:fail-unless condition-expr message-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 a single pattern variable). The
@scheme[#:declare] form may be preferred when writing macro-defining
macros or to avoid dealing with structured identifiers.
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 expr)]{
Evaluates the @scheme[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 #:fail-when condition-expr message-expr)]
@specsubform[(code:line #:fail-unless condition-expr message-expr)]{
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is any non-false value for
@scheme[#:fail-when] or if the value is @scheme[#f] for
@scheme[#:fail-unless], the matching process backtracks (with the
given message); otherwise, it continues.
}
@deftogether[[
@defidform[~or]
@defidform[~and]
@defidform[~seq]
@defidform[~once]
@defidform[~optional]
@defidform[~rest]
@;{@defidform[~struct]}
@defidform[~describe]
@defidform[~!]
@defidform[~bind]
@defidform[~fail]]]{
Syntax pattern keywords, recognized by @scheme[syntax-parse].
}
@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. If @scheme[attr-id] is an attribute with a nonzero
ellipsis depth, then the result has the corresponding level of list
nesting.
The values returned by @scheme[attribute] never undergo additional
wrapping as syntax objects, unlike values produced by some uses of
@scheme[syntax], @scheme[quasisyntax], etc. Consequently, the
@scheme[attribute] form is preferred when the attribute value is used
as data, not placed in a syntax object.
}
@;{----------}
@section{Syntax Classes}
Syntax classes provide an abstraction mechanism for the specification
of syntax. Built-in syntax classes are supplied that recognize basic
classes such as @scheme[identifier]s and @scheme[keyword]s.
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. The structure
of syntax classes and patterns also allows @scheme[syntax-parse] to
automatically generate error messages for syntax errors.
When a syntax class accepts (matches) a syntax object, it computes and
provides attributes based on the contents of the matched syntax. While
the values of the attributes depend on the matched syntax, the set of
attributes and each attribute's ellipsis nesting depth is fixed for
each syntax class.
@defform*/subs[#:literals (pattern basic-syntax-class)
[(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)
(code:line #:transparent)
(code:line #:literals (literal-entry ...))
(code:line #:literal-sets (literal-set ...))
(code:line #:conventions (convention-id ...))]
[attr-arity-decl
attr-name-id
(attr-name-id depth)]
[stxclass-variant
(pattern syntax-pattern stxclass-pattern-directive ...)])]{
Defines @scheme[name-id] as a syntax class. When the @scheme[arg-id]s
are present, they are bound as variables (not pattern variables) in
the body. The body of the syntax-class definition contains a non-empty
sequence of @scheme[pattern] variants.
@specsubform[(code:line #:attributes (attr-arity-decl ...))]{
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 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.
}
@specsubform[(code:line #:description description)]{
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[#:transparent]{
Indicates that errors may 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 under @scheme[syntax-parse].
}
@specsubform/subs[#:literals (pattern)
(pattern syntax-pattern stxclass-pattern-directive ...)
([stxclass-pattern-directive
pattern-directive
(code:line #:rename internal-id external-id)])]{
Accepts syntax matching the given syntax pattern with the accompanying
pattern directives as in @scheme[syntax-parse].
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.
}
}
@defform*/subs[#: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 splicing syntax class. A splicing syntax
class encapsulates @tech{H-patterns} as an ordinary syntax class
encapsulates @tech{S-patterns}.
}
@defidform[pattern]{
Keyword recognized by @scheme[define-syntax-class]. It may not be
used as an expression.
}
@subsection{Attributes}
A syntax class has a set of @deftech{attribute}s. Each attribute has a
name, an ellipsis depth, and a set of nested attributes. When an
instance of the syntax class is parsed and bound to a pattern
variable, additional pattern variables are bound for each of the
syntax class's attributes. The name of these additional pattern
variables is the dotted concatenation of the primary pattern
variable with the name of the attribute.
For example, if pattern variable @scheme[p] is bound to an instance of
a syntax class with attribute @scheme[a], then the pattern variable
@scheme[p.a] is bound to the value of that attribute. The ellipsis
depth of @scheme[p.a] is the sum of the depths of @scheme[p] and
attribute @scheme[a].
The attributes of a syntax class are either given explicitly with an
@scheme[#:attributes] option or inferred from the pattern variables of
the syntax class's variants.
@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 in flattened
form. 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.
}
@;{----------}
@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
set}s. 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])
]
}
@defform/subs[(define-conventions name-id (id-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 ...)))])
]
}
@;{----------}
@section{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-of 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 extend of a macro transformer (see
@scheme[syntax-transforming?]), matching fails.
The attribute @var[value] contains the value the name is bound to.
}
@defstxclass[static]{
Like @scheme[static-of], but matches any identifier bound to static
information (see @scheme[syntax-local-value]).
The attribute @var[value] contains the value the name is bound to.
}
@subsection{Literal sets}
@defidform[kernel-literals]{
Literal set containing the identifiers for fully-expanded expression
and definition forms (the same as provided by
@scheme[kernel-form-identifier-list]).
}

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

@ -6,6 +6,7 @@
@include-section["stx.scrbl"]
@include-section["kerncase.scrbl"]
@include-section["boundmap.scrbl"]
@include-section["id-table.scrbl"]
@include-section["to-string.scrbl"]
@include-section["free-vars.scrbl"]
@include-section["strip-context.scrbl"]

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

@ -20,5 +20,6 @@
@include-section["docprovide.scrbl"]
@include-section["parse.scrbl"]
@index-section[]

214
collects/tests/mzscheme/id-table-test.ss Normal file
View File

@ -0,0 +1,214 @@
(load-relative "loadtest.ss")
(require syntax/id-table
scheme/dict)
(Section 'id-table)
(test #t bound-id-table? (make-bound-id-table))
(test #t bound-id-table? (make-immutable-bound-id-table))
(test #t mutable-bound-id-table? (make-bound-id-table))
(test #t immutable-bound-id-table? (make-immutable-bound-id-table))
(let ()
;; contains-same? : (listof x) (listof x) -> boolean
(define (contains-same? l1 l2)
(and (andmap (lambda (x) (member x l2)) l1)
(andmap (lambda (x) (member x l1)) l2)
#t))
(let-values ([(x1 x2 x3 x4)
(syntax-case (expand #'((lambda (x) x) (lambda (x) x))) ()
[(x (a (x1) x2) (c (x3) x4))
(values (syntax x1)
(syntax x2)
(syntax x3)
(syntax x4))])])
(let ([check (lambda (=?)
(test #t =? x1 x2)
(test #t =? x3 x4)
(when (=? x1 x3)
((current-print) "huh!?"))
(test #f =? x1 x3)
(test #f =? x1 x4)
(test #f =? x2 x3)
(test #f =? x2 x4))])
(check bound-identifier=?)
(check free-identifier=?))
(let ([table (make-bound-id-table)])
(bound-id-table-set! table x1 #f)
(test #f bound-id-table-ref table x1)
(bound-id-table-set! table x1 1)
(bound-id-table-set! table x2 2)
(bound-id-table-set! table x3 3)
(bound-id-table-set! table x4 4)
(test 2 bound-id-table-ref table x1)
(test 2 bound-id-table-ref table x2)
(test 4 bound-id-table-ref table x3)
(test 4 bound-id-table-ref table x4)
(test #t
contains-same?
(list 2 4)
(bound-id-table-map table (lambda (x y) y)))
(test #t
contains-same?
(list 2 4)
(dict-map table (lambda (x y) y)))
(test 2 bound-id-table-count table)
(test #t
contains-same?
(list 2 4)
(let ([l '()])
(bound-id-table-for-each
table
(lambda (x y)
(set! l (cons y l))))
l))
(test #t
contains-same?
(list 2 4)
(let ([l '()])
(dict-for-each
table
(lambda (x y)
(set! l (cons y l))))
l)))
(let ([table (make-free-id-table)])
(free-id-table-set! table x1 1)
(free-id-table-set! table x2 2)
(free-id-table-set! table x3 3)
(free-id-table-set! table x4 4)
(test 2 free-id-table-ref table x1)
(test 2 free-id-table-ref table x2)
(test 4 free-id-table-ref table x3)
(test 4 free-id-table-ref table x4)
(test #t
contains-same?
(list 2 4)
(free-id-table-map table (lambda (x y) y)))
(test #t
contains-same?
(list 2 4)
(dict-map table (lambda (x y) y)))
(test 2 free-id-table-count table)
(test #t
contains-same?
(list 2 4)
(let ([l '()])
(free-id-table-for-each
table
(lambda (x y)
(set! l (cons y l))))
l))
(test #t
contains-same?
(list 2 4)
(let ([l '()])
(dict-for-each
table
(lambda (x y)
(set! l (cons y l))))
l))))
(let-values ([(y1 y2 y3 y4)
(syntax-case (expand #'(module m mzscheme (require (prefix x: mzscheme)) + x:+ - x:-)) ()
[(a b c (d e f y1 y2 y3 y4))
(values (syntax y1)
(syntax y2)
(syntax y3)
(syntax y4))])])
(let ([table (make-bound-id-table)])
(bound-id-table-set! table y1 1)
(bound-id-table-set! table y2 2)
(bound-id-table-set! table y3 3)
(bound-id-table-set! table y4 4)
(test 1 bound-id-table-ref table y1)
(test 2 bound-id-table-ref table y2)
(test 3 bound-id-table-ref table y3)
(test 4 bound-id-table-ref table y4)
(test #t
contains-same?
(list 1 2 3 4)
(bound-id-table-map table (lambda (x y) y)))
(test #t
contains-same?
(list 1 2 3 4)
(dict-map table (lambda (x y) y)))
(test 4 bound-id-table-count table)
(test #t
contains-same?
(list 1 2 3 4)
(let ([l '()])
(bound-id-table-for-each
table
(lambda (x y)
(set! l (cons y l))))
l))
(test #t
contains-same?
(list 1 2 3 4)
(let ([l '()])
(dict-for-each
table
(lambda (x y)
(set! l (cons y l))))
l)))
(let ([table (make-free-id-table)])
(free-id-table-set! table y1 #f)
(test #f free-id-table-ref table y1)
(free-id-table-set! table y1 1)
(free-id-table-set! table y2 2)
(free-id-table-set! table y3 3)
(free-id-table-set! table y4 4)
(test 2 free-id-table-ref table y1)
(test 2 free-id-table-ref table y2)
(test 4 free-id-table-ref table y3)
(test 4 free-id-table-ref table y4)
(test #t
contains-same?
(list 2 4)
(free-id-table-map table (lambda (x y) y)))
(test #t
contains-same?
(list 2 4)
(dict-map table (lambda (x y) y)))
(test 2 free-id-table-count table)
(test #t
contains-same?
(list 2 4)
(let ([l '()])
(free-id-table-for-each
table
(lambda (x y)
(set! l (cons y l))))
l))
(test #t
contains-same?
(list 2 4)
(let ([l '()])
(dict-for-each
table
(lambda (x y)
(set! l (cons y l))))
l))
)))
(report-errs)

1
collects/tests/mzscheme/syntax-tests.ss
View File

@ -2,6 +2,7 @@
(load-in-sandbox "moddep.ss")
(load-in-sandbox "boundmap-test.ss")
(load-in-sandbox "id-table-test.ss")
(load-in-sandbox "cm.ss")
(load-in-sandbox "module-reader.ss")

189
collects/tests/stxclass/stxclass.ss
View File

@ -1,10 +1,9 @@
#lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 9))
(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 9))
stxclass
stxclass/private/sc
(for-syntax scheme/base stxclass))
(require (planet schematics/schemeunit:2:9/test)
(planet schematics/schemeunit:2:9/graphical-ui)
syntax/parse
(for-syntax scheme/base syntax/parse))
;; Testing stuff
@ -34,10 +33,12 @@
(pattern (a b c)))
(define-syntax-class two-or-three/tag
#:attributes (a a.a a.b)
(pattern a:two)
(pattern a:three))
(define-syntax-class two-to-four/untagged
#:attributes (a b)
(pattern :two)
(pattern :three)
(pattern (a b c d)))
@ -60,7 +61,7 @@
(define-syntax-rule (test-sc-attrs name ([attr depth] ...))
(test-case (format "~s" 'name)
(let* ([r-attrs (attrs-of name)]
(let* ([r-attrs (syntax-class-attributes name)]
[r-names (map car r-attrs)]
[expected '((attr depth) ...)])
(for ([ra r-names])
@ -76,7 +77,7 @@
(define-syntax-rule (test-parse-sc sc stx ([attr depth form] ...))
(test-case (format "~s" 'sc)
(let* ([r (parse-sc sc stx)]
(let* ([r (syntax-class-parse sc stx)]
[r-attrs (for/list ([record r]) (vector-ref record 0))]
[expected '([attr depth form] ...)])
(for ([ra r-attrs])
@ -90,7 +91,7 @@
(define-syntax-rule (test-patterns pattern stx . body)
(test-case (format "~s" 'pattern)
(with-patterns ([pattern stx]) . body)))
(syntax-parse stx [pattern . body])))
;; Tests
@ -101,7 +102,7 @@
(test-sc-attrs two ([a 0] [b 0]))
(test-sc-attrs three ([a 0] [b 0] [c 0]))
(test-sc-attrs two-or-three/tag ([a 0] [a.a 0] [a.b 0]))
(test-sc-attrs id-num ([x 0] [x.datum 0] [n 0] [n.datum 0])))
(test-sc-attrs id-num ([x 0] [n 0])))
(test-suite "parse-sc"
(test-parse-sc one #'1 ([a 0 1]))
(test-parse-sc two #'(1 2) ([a 0 1] [b 0 2]))
@ -109,113 +110,56 @@
(test-parse-sc two-or-three/tag #'(1 2 3)
([a 0 (1 2 3)] [a.a 0 1] [a.b 0 2]))
(test-parse-sc id-num #'(this 12)
([x 0 this] [x.datum 0 this] [n 0 12] [n.datum 0 12]))
([x 0 this] [n 0 12]))
(test-parse-sc id-string #'(that "here")
([x 0 that] [x.datum 0 that]
[label 0 "here"] [label.datum 0 "here"])))
([x 0 that] [label 0 "here"])))
(test-suite "with-patterns"
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
(check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
(check-equal? (syntax->datum #'(t.b ...)) '(2 5 7)))
(test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
(test-patterns ({~or {~seq x:id v:nat} s:str} ...) #'(x 1 y 2 "whee" x 3)
(check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
(check-equal? (stx->datum #'(s ...)) '("whee")))
(test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
(test-patterns ({~or {~seq x:id v:nat} s:str} ...) #'(x 1 y 2 "whee" x 3)
(check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
(check-equal? (stx->datum #'(s ...)) '("whee")))
(test-patterns ({~or {1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...)
(test-patterns ({~or (~once 1)
(~once 2)
(~once 3)} ...)
#'(1 2 3)
'ok)
(test-patterns ({~or {a:id} {b:nat} {c:str}} ...) #'("one" 2 three)
(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")))
(test-patterns ({~or {1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1
{x} #:min 1 #:max 1
{y} #:min 1 #:max 1
{w} #:min 1 #:max 1} ...)
(test-patterns ({~or (~once 1)
(~once 2)
(~once 3)
(~once x)
(~once y)
(~once w)} ...)
#'(1 2 3 x y z)
(for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s))
(for ([s (syntax->list #'(x y w))]) (check-pred identifier? s))
(check-equal? (sort
(map symbol->string (stx->datum #'(x ... y ... w ...)))
(map symbol->string (stx->datum #'(x y w)))
string<?)
'("x" "y" "z")))
(test-patterns ({~or {x}
{1} #:min 1 #:max 1
{2} #:min 1 #:max 1
{3} #:min 1 #:max 1} ...)
(test-patterns ({~or x
(~once 1)
(~once 2)
(~once 3)} ...)
#'(1 2 3 x y z)
(check-equal? (stx->datum #'(x ...)) '(x y z)))
)))
(define-syntax (test-expr stx)
(with-patterns ([(_ e:expr/local-expand) stx])
#'(quote e.expanded)))
(define-syntax (convert-block stx)
(with-patterns ([(_ . b:block/head-local-expand) stx])
(with-patterns ([((_ svars srhs) ...) #'(b.sdef ...)]
[((_ vvars vrhs) ...) #'(b.vdef ...)])
;;(printf "here's the expanded block:\n~s\n" #'b.expanded-block)
#'(letrec-syntaxes+values ((svars srhs) ...) ((vvars vrhs) ...)
(begin b.expr ...)))))
(define-syntax (begin/defs stx)
(with-patterns
([(_ . b:internal-definitions) stx]
[((_ svars srhs) ...) #'(b.sdef ...)]
[((_ (vvar ...) bleh) ...) #'(b.vdef ...)]
[(expr ...)
(for/list ([form (syntax->list #'(b.expanded ...))])
(syntax-parse form
[dv:define-values-form
#'(set!-values (dv.var ...) dv.rhs)]
[ds:define-syntaxes-form
#'(void)]
[e
#'e]))])
#'(letrec-syntaxes+values
((svars srhs) ...)
(((vvar ...) (let ((vvar #f) ...) (values vvar ...))) ...)
(begin expr ...))))
(define-syntax (begin/defs* stx)
(with-patterns
([(_ . b:internal-definitions) stx]
[((_ svars srhs) ...) #'(b.sdef ...)]
[(head ... last) #'(b.expanded ...)]
[((preclause ...) ...)
(for/list ([form (syntax->list #'(head ...))])
(syntax-parse form
[dv:define-values-form
#'([(dv.var ...) dv.rhs])]
[_:define-syntaxes-form
#'()]
[e
#'([() (begin e (values))])]))]
[(clause ...) #'(preclause ... ...)])
#'(letrec-syntaxes+values
((svars srhs) ...)
(clause ...)
(begin tail))))
(convert-block
(define x 1)
(define y 2)
(+ x y))
(define-syntax-class bindings
(pattern ((var:id e) ...)
#:with vars #'(var ...)))
(define-syntax-class sorted
(pattern (n:nat ...)
#:when (sorted? (syntax->datum #'(n ...)))))
#:fail-unless (sorted? (syntax->datum #'(n ...))) "not sorted"))
(define (sorted? ns)
(define (loop ns min)
@ -225,61 +169,6 @@
[(null? ns) #t]))
(loop ns -inf.0))
(define-syntax madd1
(syntax-parser
[(_ e:expr/num)
#'(+ 1 e)]))
(define-syntax mapp-to-1
(syntax-parser
[(_ e)
#:declare e expr/num->num
#'(e 1)]))
(define-syntax bad-mapp-to-1
(syntax-parser
[(_ e:expr/num->num)
#'(e 'whoa)]))
#;
(define-syntax (madd2 stx)
(syntax-parse stx
[(_ e:expr/nat)
#'(+ 2 e)]))
(define-syntax-class expr/nat
(pattern e
#:declare e (expr/c #'number?)))
(define-syntax-class cond-clauses
(pattern ([#:else answer])
#:with tests (list #'#t)
#:with answers (list #'answer))
(pattern ([test answer] . more:cond-clauses)
#:with tests (cons #'test #'more.tests)
#:with answers (cons #'answer #'more.answers))
(pattern ([test #:=> answer] . more:cond-clauses)
#:with tests (cons #'test #'more.tests)
#:with answers (cons #'answer #'more.answers))
(pattern ()
#:with tests null
#:with answers null))
(define-syntax-class zork
(pattern f:frob))
(define-syntax-class frob
(pattern x:id))
(syntax-parse #'1
[x:nat
(define (check d)
(unless (positive? d)
(error "not positive")))
(check #'x.datum)
'ok])
(define-syntax-class Opaque
(pattern (a:id n:nat)))
(define-syntax-class Transparent
@ -295,12 +184,12 @@
[(plus) (void)])
(define-syntax-class (nat> n)
#:description (format "nat > ~s" n)
(pattern x:nat #:when (> (syntax-e #'x) n)))
#:description (format "nat > ~s" n)
(pattern x:nat #:fail-unless (> (syntax-e #'x) n) #f))
(syntax-parse #'(1 2 3)
[(a:nat b0:nat c0:nat)
#:with b #'b0
#:declare b (nat> (attribute a.datum))
#:with c #'c0
#:declare c (nat> (attribute b0.datum))
(void)])
[(a:nat b0:nat c0:nat)
#:with b #'b0
#:declare b (nat> (syntax-e #'a))
#:with c #'c0
#:declare c (nat> (syntax-e #'b0))
(void)])

251
collects/tests/stxclass/test.ss Normal file
View File

@ -0,0 +1,251 @@
#lang scheme
(require syntax/parse
syntax/private/stxparse/rep-attrs
syntax/private/stxparse/runtime)
(require schemeunit)
;; 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)) ...)
(lambda ()
(syntax-parse (quote-syntax s)
[p 'ok] ...)))
(void))]))
(define-syntax erx
(syntax-rules (not)
[(erx (not rx) msg)
(check-false (regexp-match? rx msg))]
[(erx rx msg)
(check regexp-match? rx msg)]))
;; ========
(define-syntax-class one
(pattern (a)))
(define-syntax-class two
(pattern (a b)))
;; ========
;; == Parsing tests
;; -- S patterns
;; name patterns
(tok 1 a
(and (bound (a 0)) (s= a 1)))
(tok (a b c) a
(and (bound (a 0)) (s= a '(a b c))))
(tok 1 a
'ok
#:pre [] #:post [1])
;; wildcard patterns
(tok 1 _)
(tok (a b c) _)
(tok (a b) (_ _)) ;; multiple _'s allowed
;; sc tests -> lib tests
(tok (1) x:one
(and (bound (x 0) (x.a 0)) (s= x '(1)) (s= x.a 1)))
(tok (1 2) x:two
(and (bound (x 0) (x.a 0) (x.b 0)) (s= x '(1 2)) (s= x.a 1) (s= x.b 2)))
(tok (1 2) x:two
'ok
#:pre [x:one] #:post [])
(tok (1) x:one
'ok
#:pre [()] #:post [x:two])
;; check if wildcard, no attr bound
(terx (1) _:two "expected two")
(terx (1 2) _:one "expected one")
(terx (1 (2 3)) (_:one _:two) "expected one")
(terx ((1) 2) (_:one _:two) "expected two")
;; datum patterns
(tok 1 1
'ok)
(tok 1 _
#t
#:pre [2] #:post [])
(tok "here" "here"
'ok
#:pre ["there"] #:post [])
(tok #f #f
'ok
#:pre [#t 0] #:post [_])
(terx 1 2 "literal 2")
(terx (1 2) 1 "literal 1")
(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)])
;; compound patterns
(tok (a b c) (x y z)
(and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b))
#:pre [(x y)] #:post [])
(tok (a . b) (x . y)
(and (bound (x 0) (y 0)) (s= x 'a) (s= y 'b))
#:pre [(x y)] #:post [])
(tok #(a b c) #(x y z)
(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 #&x
(and (bound (x 0)) (s= x 1)))
;; head patterns
;; See H-patterns
;; dots patterns
;; See EH-patterns
;; and patterns
(tok 1 (~and a 1)
(and (bound (a 0)) (s= a 1)))
(tok 1 (~and 1 1)
'ok
#:pre [(~and 1 2)] #:post [(~and 2 2)])
(tok (1 2 3) (~and w (x y z))
(and (bound (w 0) (x 0) (y 0) (z 0))
(s= w '(1 2 3)) (s= x 1)))
(tok (1 2 3) (~and (1 _ _) (_ 2 _) (_ _ 3))
'ok)
(tok (1 2 3) (~and (x _ _) (_ y _) (_ _ z))
(and (bound (x 0) (y 0) (z 0))))
;; or patterns
(tok 1 (~or 1 2 3)
'ok)
(tok 3 (~or 1 2 3)
'ok)
(tok (1) (~or (a) (a b) (a b c))
(and (bound (a 0 #t) (b 0 #f) (c 0 #f)) (s= a 1) (a= b #f) (a= c #f)))
(tok (1 2 3) (~or (a) (a b) (a b c))
(and (bound (a 0 #t) (b 0 #f) (c 0 #f)) (s= a 1) (s= b 2) (s= c 3)))
(tok 1 (~or 5 _)
'ok)
(tok #t (~or #t #f)
'ok)
(tok #t (~or (~and #t x) (~and #f x))
(and (bound (x 0 #t))))
;; epsilon-name patterns
(tok (1) :one
(and (bound (a 0)) (s= a 1)))
(tok (1 2) :two
(and (bound (a 0) (b 0)) (s= a 1) (s= b 2)))
(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)))
;; cut patterns
(terx* (1 2 3) [(1 ~! 4) (1 2 3)]
"4" (not "2"))
;; cut-in-and
(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))
(tok 1 (~or x:id (~bind [x #'default]))
(s= x 'default))
;; fail patterns
(tok (1 2 3) _
'ok
#:pre [(~fail "pass") (error 'wrong)] #:post [])
(terx 1 (~fail "wanted 2")
#rx"wanted 2")
(terx 1 (~and n:nat (~fail #:unless (even? (syntax-e #'n)) "wanted even number"))
#rx"wanted even number")
;; -- H patterns
;; seq
(tok (1 2 3) ((~seq 1 2) 3))
(tok (1 2 3) (1 (~seq 2) 3))
(tok (1 2 3) ((~seq) 1 2 3))
;; or
(tok (1 2 3) ((~or (~seq 1 2) 1) 3))
(tok (1 2 3) ((~or 1 (~seq 1 2)) 3))
(tok (1 2 3) ((~or (~seq 1) (~seq 1 2)) 3))
(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3))
(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3 (~or (~seq 4) (~seq))))
;; describe
(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3))
(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3)
"one-two")
;; == Lib tests
;; == Error tests