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

Added for and match

Browse Source
This commit is contained in:
Jens Axel Søgaard 2014-08-12 20:39:36 +02:00
parent a896cf4abd
commit a851725892
21 changed files with 20499 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2062
whalesong/lang/for.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

27
whalesong/lang/match.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang whalesong
(require "private/match/match.rkt" "private/match/runtime.rkt"
(for-syntax racket/base))
(provide (except-out (all-from-out "private/match/match.rkt")
define-match-expander)
failure-cont
(rename-out [define-match-expander* define-match-expander]))
(define-for-syntax (no-old-match-form stx)
(raise-syntax-error
#f
"works only for constructor-based `match' form"
stx))
(define-syntax-rule (failure-cont) (fail))
(define-syntax define-match-expander*
(syntax-rules ()
[(_ id expr) (define-match-expander id expr)]
[(_ id expr expr2) (define-match-expander id
expr
no-old-match-form
(#%expression expr2))]))

481
whalesong/lang/private/match/compiler.rkt Normal file
View File

@ -0,0 +1,481 @@
#lang racket/base
(require (for-template whalesong/lang/whalesong
; racket/base
"runtime.rkt"
racket/stxparam
; racket/unsafe/ops
)
syntax/boundmap
syntax/stx
"patterns.rkt"
"split-rows.rkt"
"reorder.rkt"
racket/stxparam
racket/syntax)
(provide compile*)
;; for non-linear patterns
(define vars-seen (make-parameter null))
(define (hash-on f elems #:equal? [eql #t])
(define ht (if eql (make-hash) (make-hasheq)))
;; put all the elements e in the ht, indexed by (f e)
(for ([r
;; they need to be in the original order when they come out
(reverse elems)])
(define k (f r))
(hash-set! ht k (cons r (hash-ref ht k (lambda () null)))))
ht)
;; generate a clause of kind k
;; for rows rows, with matched variable x and rest variable xs
;; escaping to esc
(define (gen-clause k rows x xs esc)
(define-syntax-rule (constant-pat predicate-stx)
(with-syntax ([rhs (compile* (cons x xs)
(map (lambda (row)
(define-values (p ps)
(Row-split-pats row))
(define p* (Atom-p p))
(make-Row (cons p* ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
rows)
esc)])
#`[(#,predicate-stx #,x) rhs]))
(define (compile-con-pat accs pred pat-acc)
(with-syntax* ([(tmps ...) (generate-temporaries accs)]
[(accs ...) accs]
[pred pred]
[body (compile*
(append (syntax->list #'(tmps ...)) xs)
(map (lambda (row)
(define-values (p1 ps) (Row-split-pats row))
(make-Row (append (pat-acc p1) ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
rows)
esc)])
#`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
(cond
[(eq? 'box k)
(compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
[(eq? 'pair k)
(compile-con-pat (list #'car #'cdr) #'pair?
(lambda (p) (list (Pair-a p) (Pair-d p))))]
[(eq? 'mpair k)
; XXX These should be unsafe-mcar* when mpairs have chaperones
(compile-con-pat (list #'mcar #'mcdr) #'mpair?
(lambda (p) (list (MPair-a p) (MPair-d p))))]
[(eq? 'string k) (constant-pat #'string?)]
[(eq? 'number k) (constant-pat #'number?)]
[(eq? 'symbol k) (constant-pat #'symbol?)]
[(eq? 'keyword k) (constant-pat #'keyword?)]
[(eq? 'char k) (constant-pat #'char?)]
[(eq? 'bytes k) (constant-pat #'bytes?)]
[(eq? 'regexp k) (constant-pat #'regexp?)]
[(eq? 'boolean k) (constant-pat #'boolean?)]
[(eq? 'null k) (constant-pat #'null?)]
;; vectors are handled specially
;; because each arity is like a different constructor
[(eq? 'vector k)
(let ([ht (hash-on (lambda (r)
(length (Vector-ps (Row-first-pat r)))) rows)])
(with-syntax ([(clauses ...)
(hash-map
ht
(lambda (arity rows)
(define ns (build-list arity values))
(with-syntax ([(tmps ...) (generate-temporaries ns)])
(with-syntax ([body
(compile*
(append (syntax->list #'(tmps ...)) xs)
(map (lambda (row)
(define-values (p1 ps)
(Row-split-pats row))
(make-Row (append (Vector-ps p1) ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
rows)
esc)]
[(n ...) ns])
#`[(#,arity)
(let ([tmps (vector-ref #,x n)] ...)
body)]))))])
#`[(vector? #,x)
(case (vector-length #,x) ; [Whalesong] unsafe-
clauses ...
[else (#,esc)])]))]
;; it's a structure
[(box? k)
;; all the rows are structures with the same predicate
(let* ([s (Row-first-pat (car rows))]
[accs (Struct-accessors s)]
[accs (if (Struct-complete? s)
(build-list (length accs)
(λ (i) (with-syntax ([a (list-ref accs i)])
#`(λ (x) (a x))))) ; [Whalesong]
accs)]
[pred (Struct-pred s)])
(compile-con-pat accs pred Struct-ps))]
[else (error 'match-compile "bad key: ~a" k)]))
;; produces the syntax for a let clause
(define (compile-one vars block esc)
(define-values (first rest-pats) (Row-split-pats (car block)))
(define x (car vars))
(define xs (cdr vars))
(cond
;; the Exact rule
[(Exact? first)
(let ([ht (hash-on (compose Exact-v Row-first-pat) block #:equal? #t)])
(with-syntax ([(clauses ...)
(hash-map
ht
(lambda (k v)
#`[(equal? #,x '#,k)
#,(compile* xs
(map (lambda (row)
(make-Row (cdr (Row-pats row))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
v)
esc)]))])
#`(cond clauses ... [else (#,esc)])))]
;; the Var rule
[(Var? first)
(let ([transform
(lambda (row)
(define-values (p ps) (Row-split-pats row))
(define v (Var-v p))
(define seen (Row-vars-seen row))
;; a new row with the rest of the patterns
(cond
;; if this was a wild-card variable, don't bind
[(Dummy? p) (make-Row ps
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row))]
;; if we've seen this variable before, check that it's equal to
;; the one we saw
[(for/or ([e seen])
(let ([v* (car e)] [id (cdr e)])
(and (bound-identifier=? v v*) id)))
=>
(lambda (id)
(make-Row ps
#`(if ((match-equality-test) #,x #,id)
#,(Row-rhs row)
(fail))
(Row-unmatch row)
seen))]
;; otherwise, bind the matched variable to x, and add it to the
;; list of vars we've seen
[else (let ([v* (free-identifier-mapping-get
(current-renaming) v (lambda () v))])
(make-Row ps
#`(let ([#,v* #,x]) #,(Row-rhs row))
(Row-unmatch row)
(cons (cons v x) (Row-vars-seen row))))]))])
;; compile the transformed block
(compile* xs (map transform block) esc))]
;; the Constructor rule
[(CPat? first)
(let ;; put all the rows in the hash, indexed by their constructor
([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)])
(with-syntax ([(clauses ...)
(hash-map
ht (lambda (k v) (gen-clause k v x xs esc)))])
#`(cond clauses ... [else (#,esc)])))]
;; the Or rule
[(Or? first)
;; we only handle 1-row Ors atm - this is all the mixture rule should give
;; us
(unless (null? (cdr block))
(error 'compile-one "Or block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
[seen (Row-vars-seen row)]
;; all the pattern alternatives
[qs (Or-ps (car pats))]
;; the variables bound by this pattern - they're the same for the
;; whole list
[vars
(for/list ([bv (bound-vars (car qs))]
#:when (for/and ([seen-var seen])
(not (free-identifier=? bv (car seen-var)))))
bv)])
(with-syntax ([(esc* success? var ...) (append (generate-temporaries '(esc* success?)) vars)])
;; do the or matching, and bind the results to the appropriate
;; variables
#`(let ([esc* (lambda () (values #f #,@(for/list ([v vars]) #'#f)))])
(let-values ([(success? var ...)
#,(compile* (list x)
(map (lambda (q)
(make-Row (list q)
#'(values #t var ...)
#f
seen))
qs)
#'esc*)])
;; then compile the rest of the row
(if success?
#,(compile* xs
(list (make-Row (cdr pats)
(Row-rhs row)
(Row-unmatch row)
(append (map cons vars vars) seen)))
esc)
(#,esc))))))]
;; the App rule
[(App? first)
;; we only handle 1-row Apps atm - this is all the mixture rule should
;; give us
(unless (null? (cdr block))
(error 'compile-one "App block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
[app-pats (App-ps first)])
(with-syntax ([(t ...) (generate-temporaries app-pats)])
#`(let-values ([(t ...) (#,(App-expr first) #,x)])
#,(compile* (append (syntax->list #'(t ...)) xs)
(list (make-Row (append app-pats (cdr pats))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc))))]
;; the And rule
[(And? first)
;; we only handle 1-row Ands
;; this is all the mixture rule should give us
(unless (null? (cdr block))
(error 'compile-one "And block with multiple rows: ~a" block))
(define row (car block))
(define pats (Row-pats row))
;; all the patterns
(define qs (And-ps (car pats)))
(compile* (append (map (lambda _ x) qs) xs)
(list (make-Row (append qs (cdr pats))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc
;; don't re-order OrderedAnd patterns
(not (OrderedAnd? first)))]
;; the Not rule
[(Not? first)
;; we only handle 1-row Nots atm - this is all the mixture rule should
;; give us
(unless (null? (cdr block))
(error 'compile-one "Not block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
;; the single pattern
[q (Not-p (car pats))])
(with-syntax ([(f) (generate-temporaries #'(f))])
#`(let ;; if q fails, we jump to here
([f (lambda ()
#,(compile* xs
(list (make-Row (cdr pats)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc))])
#,(compile* (list x)
;; if q doesn't fail, we jump to esc and fail the not
;; pattern
(list (make-Row (list q)
#`(#,esc)
(Row-unmatch row)
(Row-vars-seen row)))
#'f))))]
[(Pred? first)
;; multiple preds iff they have the identical predicate
(with-syntax ([pred? (Pred-pred first)]
[body (compile* xs
(map (lambda (row)
(define-values (_1 ps)
(Row-split-pats row))
(make-Row ps
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
block)
esc)])
#`(cond [(pred? #,x) body] [else (#,esc)]))]
;; Generalized sequences... slightly tested
[(GSeq? first)
(let* ([headss (GSeq-headss first)]
[mins (GSeq-mins first)]
[maxs (GSeq-maxs first)]
[onces? (GSeq-onces? first)]
[tail (GSeq-tail first)]
[mutable? (GSeq-mutable? first)]
[make-Pair (if mutable? make-MPair make-Pair)]
[k (Row-rhs (car block))]
[xvar (car (generate-temporaries (list #'x)))]
[complete-heads-pattern
(lambda (ps)
(define (loop ps pat)
(if (pair? ps)
(make-Pair (car ps) (loop (cdr ps) pat))
pat))
(loop ps (make-Var xvar)))]
[heads
(for/list ([ps headss])
(complete-heads-pattern ps))]
[head-idss
(for/list ([heads headss])
(apply append (map bound-vars heads)))]
[hid-argss (map generate-temporaries head-idss)]
[head-idss* (map generate-temporaries head-idss)]
[hid-args (apply append hid-argss)]
[reps (generate-temporaries (for/list ([head heads]) 'rep))])
(with-syntax ([x xvar]
[var0 (car vars)]
[((hid ...) ...) head-idss]
[((hid* ...) ...) head-idss*]
[((hid-arg ...) ...) hid-argss]
[(rep ...) reps]
[(maxrepconstraint ...)
;; FIXME: move to side condition to appropriate pattern
(for/list ([repvar reps] [maxrep maxs])
(if maxrep #`(< #,repvar #,maxrep) #`#t))]
[(minrepclause ...)
(for/list ([repvar reps] [minrep mins] #:when minrep)
#`[(< #,repvar #,minrep) (fail)])]
[((hid-rhs ...) ...)
(for/list ([hid-args hid-argss] [once? onces?])
(for/list ([hid-arg hid-args])
(if once?
#`(car (reverse #,hid-arg))
#`(reverse #,hid-arg))))]
[(parse-loop failkv fail-tail)
(generate-temporaries #'(parse-loop failkv fail-tail))])
(with-syntax ([(rhs ...)
#`[(let ([hid-arg (cons hid* hid-arg)] ...)
(if maxrepconstraint
(let ([rep (add1 rep)])
(parse-loop x #,@hid-args #,@reps fail))
(begin (fail))))
...]]
[tail-rhs
#`(cond minrepclause ...
[else
(let ([hid hid-rhs] ... ...
[fail-tail fail])
#,(compile*
(cdr vars)
(list (make-Row rest-pats k
(Row-unmatch (car block))
(Row-vars-seen
(car block))))
#'fail-tail))])])
(parameterize ([current-renaming
(for/fold ([ht (copy-mapping (current-renaming))])
([id (apply append head-idss)]
[id* (apply append head-idss*)])
(free-identifier-mapping-put! ht id id*)
(free-identifier-mapping-for-each
ht
(lambda (k v)
(when (free-identifier=? v id)
(free-identifier-mapping-put! ht k id*))))
ht)])
#`(let parse-loop ([x var0]
[hid-arg null] ... ...
[rep 0] ...
[failkv #,esc])
#,(compile* (list #'x)
(append
(map (lambda (pats rhs)
(make-Row pats
rhs
(Row-unmatch (car block))
(Row-vars-seen
(car block))))
(map list heads)
(syntax->list #'(rhs ...)))
(list (make-Row (list tail)
#`tail-rhs
(Row-unmatch (car block))
(Row-vars-seen
(car block)))))
#'failkv))))))]
[else (error 'compile "unsupported pattern: ~a\n" first)]))
(define (compile* vars rows esc [reorder? #t])
(define (let/wrap clauses body)
(if (stx-null? clauses)
body
(quasisyntax (let* #,clauses #,body))))
(cond
;; if there are no rows, then just call the esc continuation
[(null? rows) #`(#,esc)]
;; if we have no variables, there are no more patterns to match
;; so we just pick the first RHS
[(null? vars)
(let ([fns
(let loop ([blocks (reverse rows)] [esc esc] [acc null])
(if (null? blocks)
;; if we're done, return the blocks
(reverse acc)
(with-syntax
(;; f is the name this block will have
[(f) (generate-temporaries #'(f))]
;; compile the block, with jumps to the previous esc
[c (with-syntax ([rhs #`(syntax-parameterize
([fail (make-rename-transformer
(quote-syntax #,esc))])
#,(Row-rhs (car blocks)))])
(define unmatch (Row-unmatch (car blocks)))
(if unmatch
(quasisyntax/loc unmatch
(call-with-continuation-prompt
(lambda () (let ([#,unmatch
(lambda ()
(abort-current-continuation match-prompt-tag))])
rhs))
match-prompt-tag
(lambda () (#,esc))))
#'rhs))])
;; then compile the rest, with our name as the esc
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))]
;; otherwise, we split the matrix into blocks
;; and compile each block with a reference to its continuation
[else
(let*-values
([(rows vars) (if reorder?
(reorder-columns rows vars)
(values rows vars))]
[(fns)
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
(if (null? blocks)
;; if we're done, return the blocks
(reverse acc)
(with-syntax (;; f is the name this block will have
[(f) (generate-temporaries #'(f))]
;; compile the block, with jumps to the previous
;; esc
[c (compile-one vars (car blocks) esc)])
;; then compile the rest, with our name as the esc
(loop (cdr blocks)
#'f
(cons #`[f #,(syntax-property
#'(lambda () c)
'typechecker:called-in-tail-position #t)]
acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))]))
;; (require mzlib/trace)
;; (trace compile* compile-one)

183
whalesong/lang/private/match/define-forms.rkt Normal file
View File

@ -0,0 +1,183 @@
#lang whalesong
(require (for-syntax racket/base
racket/syntax
(only-in racket/list append* remove-duplicates)
unstable/sequence
syntax/parse
syntax/parse/experimental/template
racket/lazy-require))
(require (for-syntax "patterns.rkt" "gen-match.rkt")) ; [Whalesong]
#;(begin-for-syntax
(lazy-require ["patterns.rkt" (bound-vars)]
["gen-match.rkt" (go parse-id go/one)]))
(provide define-forms)
;; syntax classes for `define/match`
(begin-for-syntax
(define-syntax-class function-header
(pattern ((~or header:function-header name:id) . args:args)
#:attr params
(template ((?@ . (?? header.params ()))
. args.params))))
(define-syntax-class args
(pattern (arg:arg ...)
#:attr params #'(arg.name ...))
(pattern (arg:arg ... . rest:id)
#:attr params #'(arg.name ... rest)))
(define-splicing-syntax-class arg
#:attributes (name)
(pattern name:id)
(pattern [name:id default])
(pattern (~seq kw:keyword name:id))
(pattern (~seq kw:keyword [name:id default]))))
(define-syntax-rule (define-forms parse-id
match match* match-lambda match-lambda*
match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec
match/values match/derived match*/derived
define/match)
(...
(begin
(provide match match* match-lambda match-lambda* match-lambda**
match-let match-let* match-let-values match-let*-values
match-define match-define-values match-letrec
match/values match/derived match*/derived match-define-values
define/match)
(define-syntax (match* stx)
(syntax-parse stx
[(_ es . clauses)
(go parse-id stx #'es #'clauses)]))
(define-syntax (match*/derived stx)
(syntax-parse stx
[(_ es orig-stx . clauses)
(go parse-id #'orig-stx #'es #'clauses)]))
(define-syntax (match stx)
(syntax-parse stx
[(_ arg:expr clauses ...)
(go/one parse-id stx #'arg #'(clauses ...))]))
(define-syntax (match/derived stx)
(syntax-parse stx
[(_ arg:expr orig-stx clauses ...)
(go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
(define-syntax (match/values stx)
(syntax-parse stx
[(_ arg:expr (~and cl0 [(pats ...) rhs ...]) clauses ...)
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
#`(let-values ([(ids ...) arg])
(match*/derived (ids ...) #,stx cl0 clauses ...)))]))
(define-syntax (match-lambda stx)
(syntax-parse stx
[(_ . clauses)
(with-syntax* ([arg (generate-temporary)]
[body #`(match/derived arg #,stx . clauses)])
(syntax/loc stx (lambda (arg) body)))]))
(define-syntax (match-lambda* stx)
(syntax-parse stx
[(_ . clauses)
(with-syntax* ([arg (generate-temporary)]
[body #`(match/derived arg #,stx . clauses)])
(syntax/loc stx (lambda arg body)))]))
(define-syntax (match-lambda** stx)
(syntax-parse stx
[(_ (~and clauses [(pats ...) . rhs]) ...)
(with-syntax* ([vars (generate-temporaries (car (syntax-e #'((pats ...) ...))))]
[body #`(match*/derived vars #,stx clauses ...)])
(syntax/loc stx (lambda vars body)))]))
(define-syntax (match-let-values stx)
(syntax-parse stx
[(_ (~and clauses ([(patss ...) rhss:expr] ...)) body1 body ...)
(define-values (idss let-clauses)
(for/lists (idss let-clauses)
([pats (syntax->list #'((patss ...) ...))]
[rhs (syntax->list #'(rhss ...))])
(define ids (generate-temporaries pats))
(values ids #`[#,ids #,rhs])))
#`(let-values #,let-clauses
(match*/derived #,(append* idss) #,stx
[(patss ... ...) (let () body1 body ...)]))]))
(define-syntax (match-let*-values stx)
(syntax-parse stx
[(_ () body1 body ...)
#'(let () body1 body ...)]
[(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
#`(let-values ([(ids ...) rhs])
(match*/derived (ids ...) #,stx
[(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...)
body1 body ...))])))]))
;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good
(define-syntax (match-let stx)
(syntax-parse stx
[(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
(with-syntax*
([vars (generate-temporaries #'(pat ...))]
[loop-body #`(match*/derived vars #,stx
[(pat ...) (let () body1 body ...)])])
#'(letrec ([nm (lambda vars loop-body)])
(nm init-exp ...)))]
[(_ ([pat init-exp:expr] ...) body1 body ...)
#`(match-let-values ([(pat) init-exp] ...) body1 body ...)]))
(define-syntax-rule (match-let* ([pat exp] ...) body1 body ...)
(match-let*-values ([(pat) exp] ...) body1 body ...))
(define-syntax (match-letrec stx)
(syntax-parse stx
[(_ ((~and cl [pat exp]) ...) body1 body ...)
(quasisyntax/loc stx
(let ()
#,@(for/list ([c (in-syntax #'(cl ...))]
[p (in-syntax #'(pat ...))]
[e (in-syntax #'(exp ...))])
(quasisyntax/loc c (match-define #,p #,e)))
body1 body ...))]))
(define-syntax (match-define stx)
(syntax-parse stx
[(_ pat rhs:expr)
(let ([p (parse-id #'pat)])
(with-syntax ([vars (bound-vars p)])
(quasisyntax/loc stx
(define-values vars (match*/derived (rhs) #,stx
[(pat) (values . vars)])))))]))
(define-syntax (match-define-values stx)
(syntax-parse stx
[(_ (pats ...) rhs:expr)
(define bound-vars-list (remove-duplicates
(foldr (λ (pat vars)
(append (bound-vars (parse-id pat)) vars))
'() (syntax->list #'(pats ...)))
bound-identifier=?))
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
(quasisyntax/loc stx
(define-values #,bound-vars-list
(match/values rhs
[(pats ...) (values . #,bound-vars-list)]))))]))
(define-syntax (define/match stx)
(syntax-parse stx
[(_ ?header:function-header ?clause ...)
(template
(define ?header
(match* (?? ?header.params)
?clause ...)))])))))

88
whalesong/lang/private/match/gen-match.rkt Normal file
View File

@ -0,0 +1,88 @@
#lang racket/base
(require "patterns.rkt" "compiler.rkt"
syntax/stx syntax/parse racket/syntax
(for-template racket/base (only-in "runtime.rkt" match:error fail)))
(provide go go/one)
;; this transforms `match'-style clauses into ones acceptable to `go'
;; go : syntax syntax syntax -> syntax
(define (go/one parse stx expr clauses)
(define-syntax-class cl
#:description "a clause with a pattern and a result"
(pattern [p . rhs]
#:with res (syntax/loc this-syntax [(p) . rhs])))
(syntax-parse clauses
[(c:cl ...)
(go parse stx (quasisyntax/loc expr (#,expr))
#'(c.res ...))]))
;; this parses the clauses using parse, then compiles them
;; go : syntax syntax syntax -> syntax
(define (go parse stx es clauses)
(syntax-parse clauses
[([pats . rhs] ...)
(parameterize ([orig-stx stx])
(unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
(define/with-syntax form-name
(syntax-case stx ()
[(fname . _)
(identifier? #'fname)
(syntax-e #'fname)]
[_ 'match]))
(define len (length (syntax->list es)))
(define srcloc-list (list #`(quote #,(syntax-source stx))
#`(quote #,(syntax-line stx))
#`(quote #,(syntax-column stx))
#`(quote #,(syntax-position stx))
#`(quote #,(syntax-span stx))))
(define/with-syntax (xs ...) (generate-temporaries es))
(define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error
(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
(define parsed-clauses
(for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))]
[rhs (syntax->list #'(rhs ...))])
(unless (syntax->list pats)
(raise-syntax-error 'match* "expected a sequence of patterns" pats))
(define lp (length (syntax->list pats)))
(unless (= len lp)
(raise-syntax-error
'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
(define (mk unm rhs)
(make-Row (for/list ([p (syntax->list pats)]) (parse p))
(syntax-property
(quasisyntax/loc stx
(let () . #,rhs))
'feature-profile:pattern-matching 'antimark)
unm null))
(syntax-parse rhs
[()
(raise-syntax-error
'match
"expected at least one expression on the right-hand side"
clause)]
[(#:when e)
(raise-syntax-error
'match
"expected at least one expression on the right-hand side after #:when clause"
clause)]
[(#:when e rest ...) (mk #f #'((if e (let () rest ...) (fail))))]
[(((~datum =>) unm) . rhs) (mk #'unm #'rhs)]
[_ (mk #f rhs)])))
(define/with-syntax body
(compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
(define/with-syntax (exprs* ...)
(for/list ([e (in-list (syntax->list #'(exprs ...)))])
(syntax-property e 'feature-profile:pattern-matching 'antimark)))
(syntax-property
(quasisyntax/loc stx
(let ([xs exprs*] ...)
(define (outer-fail) raise-error)
body))
'feature-profile:pattern-matching #t)]))

21
whalesong/lang/private/match/legacy-match.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket/base
(require (only-in "runtime.rkt"
match-equality-test
exn:misc:match?)
(only-in "match-expander.rkt"
define-match-expander)
"define-forms.rkt"
(for-syntax "parse-legacy.rkt"
(only-in "patterns.rkt" match-...-nesting)))
(provide (for-syntax match-...-nesting)
match-equality-test
define-match-expander
exn:misc:match?)
(define-forms parse/legacy
match match* match-lambda match-lambda* match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec match/values match/derived match*/derived
define/match)

84
whalesong/lang/private/match/match-expander.rkt Normal file
View File

@ -0,0 +1,84 @@
#lang whalesong
(require (for-syntax racket/base "stxtime.rkt"))
(provide define-match-expander)
(begin-for-syntax
(define make-match-expander
(let ()
(define-struct match-expander (match-xform legacy-xform macro-xform)
#:property prop:set!-transformer
(λ (me stx)
(define xf (match-expander-macro-xform me))
(if (set!-transformer? xf)
((set!-transformer-procedure xf) stx)
(syntax-case stx (set!)
[(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
[_ (xf stx)])))
#:property prop:match-expander (struct-field-index match-xform)
#:property prop:legacy-match-expander (struct-field-index legacy-xform))
(values make-match-expander))))
(define-syntax (define-match-expander stx)
(define (lookup v alist)
(cond [(assoc v alist) => cadr]
[else #f]))
(define (parse args)
(let loop ([args args]
[alist '()])
(if (null? args)
alist
(let* ([stx-v (car args)]
[v (syntax-e stx-v)])
(cond
[(not (keyword? v))
(raise-syntax-error #f "argument must be a keyword" stx stx-v)]
[(not (memq v '(#:expression #:plt-match #:match)))
(raise-syntax-error
#f (format "keyword argument ~a is not a correct keyword" v)
stx stx-v)]
[else
(loop (cddr args) (cons (list v (cadr args)) alist))])))))
(syntax-case stx ()
[(_ id kw . rest)
(keyword? (syntax-e #'kw))
(let* ([args (syntax->list #'(kw . rest))]
[parsed-args (parse args)])
(with-syntax
([legacy-xform (lookup '#:match parsed-args)]
[match-xform (lookup '#:plt-match parsed-args)]
[macro-xform
(or (lookup '#:expression parsed-args)
#'(lambda (stx)
(raise-syntax-error
#f "this match expander must be used inside match"
stx)))])
(if (identifier? #'macro-xform)
(syntax/loc stx
(define-syntax id
(make-match-expander
match-xform
legacy-xform
(lambda (stx)
(syntax-case stx (set!)
[(nm . args) #'(macro-xform . args)]
[nm (identifier? #'nm) #'macro-xform]
[(set! . _)
(raise-syntax-error #f "match expander cannot be target of a set!" stx)])))))
(syntax/loc stx
(define-syntax id
(make-match-expander match-xform legacy-xform macro-xform))))))]
;; implement legacy syntax
[(_ id plt-match-xform match-xform std-xform)
#'(define-match-expander id #:plt-match plt-match-xform
#:match match-xform
#:expression std-xform)]
[(_ id plt-match-xform std-xform)
#'(define-match-expander id #:plt-match plt-match-xform
#:expression std-xform)]
[(_ id plt-match-xform)
#'(define-match-expander id #:plt-match plt-match-xform)]
;; error checking
[_ (raise-syntax-error #f "invalid use of define-match-expander" stx)]))

34
whalesong/lang/private/match/match.rkt Normal file
View File

@ -0,0 +1,34 @@
#lang whalesong
(require (only-in "runtime.rkt"
match-equality-test
exn:misc:match?)
(only-in "match-expander.rkt"
define-match-expander)
"define-forms.rkt"
"struct.rkt"
(for-syntax racket/lazy-require
(only-in "stxtime.rkt"
match-...-nesting
match-expander?
legacy-match-expander?
prop:match-expander
prop:legacy-match-expander)))
(require (for-syntax "parse.rkt")) ; [Whalesong]
#;(begin-for-syntax
(lazy-require ["parse.rkt" (parse)]))
(provide (for-syntax match-...-nesting match-expander? legacy-match-expander?
prop:match-expander prop:legacy-match-expander)
match-equality-test
define-match-expander
struct* ==
exn:misc:match?)
(define-forms parse
match match* match-lambda match-lambda* match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec match/values
match/derived match*/derived
define/match)

74
whalesong/lang/private/match/parameters.rkt Normal file
View File

@ -0,0 +1,74 @@
#lang whalesong
; This module contains a poor man's parameters.
(provide make-parameter parameterize)
(require (for-syntax syntax/parse
(only-in racket/base ...
with-syntax
syntax
generate-temporaries
#%app)))
; Assumptions:
; i) single thread
; ii) no continuation marks available
; The return value of make-parameter is not the parameter structure,
; but the getter/setter. When Whalesong gets support for applicable
; structures, the structure should be returned instead.
(struct param ([value #:mutable] getter guard)
; #:property prop:procedure (struct-field-index getter)
; Nope - whalesong does not support applicable structures
)
(define (make-parameter v [guard #f]) ; -> parameter?
; return new parameter procedure
; the value is initialized to v (in all threads)
; setting a new value will pass the value to a guard,
; the value returned by the guard will be used as the new value
; (the guard can raise an exception)
; the guard is not called for the initial value
(letrec ([getter (λ xs
(if (null? xs)
(param-value p)
(set-param-value! p (car xs))))]
[p (param v getter (and guard (λ(x) x)))])
getter))
(define-syntax (parameterize stx)
(syntax-parse stx
[(_ ([param-expr:expr val-expr:expr] ...) body0 body ...)
(with-syntax ([(param ...) (generate-temporaries #'(param-expr ...))]
[(old-value ...) (generate-temporaries #'(param-expr ...))])
#'(let ([param param-expr] ...)
(let ([old-value (param)] ...)
(param val-expr) ...
(begin0
(let () body0 body ...)
(param old-value) ...))))]))
;;; Tests
#;(begin
(define foo (make-parameter 11))
(list (list (foo) (foo 12) (foo))
(list 11 (void) 12))
(define bar (make-parameter 21))
(list (list (bar) (bar 22) (bar))
(list 21 (void) 22))
(list (parameterize ([foo 13] [bar 23])
(list (foo) (bar)))
(list 13 23))
(list (list (foo) (bar))
(list 12 22))
(list (parameterize ([foo 13] [bar 23])
(list (parameterize ([foo 14] [bar 24])
(list (foo) (bar)))
(foo) (bar)))
(list (list 14 24) 13 23)))

224
whalesong/lang/private/match/parse-helper.rkt Normal file
View File

@ -0,0 +1,224 @@
#lang racket/base
(require (for-template racket/base)
syntax/boundmap
racket/struct-info
;macro-debugger/emit
"patterns.rkt")
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
match-expander-transform trans-match parse-struct
dd-parse parse-quote parse-id in-splicing?)
(define in-splicing? (make-parameter #f))
;; parse x as a match variable
;; x : identifier
(define (parse-id x)
(cond [(eq? '_ (syntax-e x))
(make-Dummy x)]
[(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern"
x)]
[else (make-Var x)]))
;; stx : syntax of pattern, starting with quote
;; parse : the parse function
(define (parse-quote stx parse)
(syntax-case stx (quote)
[(quote ())
(make-Null (make-Dummy stx))]
[(quote (a . b))
(make-Pair (parse (syntax/loc stx (quote a)))
(parse (syntax/loc stx (quote b))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Vector (for/list ([e (syntax-e #'vec)])
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote bx)
(box? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc
stx
(quote #,(unbox (syntax-e #'bx))))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
[_ (raise-syntax-error 'match "syntax error in quote pattern" stx)]))
;; parse : the parse fn
;; p : the repeated pattern
;; dd : the ... stx
;; rest : the syntax for the rest
;; pred? : recognizer for the parsed data structure (such as list?)
;; to-list: function to convert the value to a list
(define (dd-parse parse p dd rest pred? #:to-list [to-list #'values] #:mutable [mutable? #f])
(define count (ddk? dd))
(define min (and (number? count) count))
(define pat (parameterize ([match-...-nesting (add1 (match-...-nesting))])
(parse p)))
(define rest-pat (parse rest))
(cond [(and (not (in-splicing?)) ;; when we're inside splicing, rest-pat isn't the rest
(not min) ;; if we have a count, better generate general code
(Null? rest-pat)
(or (Var? pat) (Dummy? pat)))
(make-And (list (make-Pred pred?) (make-App to-list (list pat))))]
[else (make-GSeq (list (list pat))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
rest-pat
mutable?)]))
;; stx : the syntax object for the whole pattern
;; parse : the pattern parser
;; struct-name : identifier
;; pats : syntax representing the member patterns
;; returns a pattern
(define (parse-struct stx parse struct-name pats)
(let* ([fail (lambda ()
(raise-syntax-error
'match (format "~a does not refer to a structure definition"
(syntax->datum struct-name))
stx struct-name))]
[v (syntax-local-value struct-name fail)])
(unless (struct-info? v) (fail))
(let-values ([(id _1 pred acc _2 super)
(apply values (extract-struct-info v))])
;; this produces a list of all the super-types of this struct
;; ending when it reaches the top of the hierarchy, or a struct that we
;; can't access
(define (get-lineage struct-name)
(let ([super (list-ref (extract-struct-info (syntax-local-value
struct-name))
5)])
(cond [(equal? super #t) (values #t '())] ;; no super type exists
[(equal? super #f) (values #f '())] ;; super type is unknown
[else
(let-values ([(complete? lineage) (get-lineage super)])
(values complete?
(cons super lineage)))])))
(unless pred
(raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
(syntax->datum struct-name))
stx struct-name))
(let-values ([(complete? lineage) (get-lineage struct-name)])
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc]
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
'disappeared-use (list struct-name))
lineage (and (checked-struct-info? v) complete?)
acc
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)])))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer (list pat)))))
;; transform a match-expander application
;; parse : stx -> pattern
;; expander : identifier
;; stx : the syntax of the match-expander application (armed)
;; accessor : match-expander -> syntax transformer/#f
;; error-msg : string
;; produces a parsed pattern
(define (match-expander-transform parse expander stx accessor
error-msg)
(let* ([expander* (syntax-local-value expander)]
[transformer (accessor expander*)]
;; this transformer might have been defined w/ `syntax-id-rules'
[transformer (if (set!-transformer? transformer)
(set!-transformer-procedure transformer)
transformer)])
(unless transformer (raise-syntax-error #f error-msg expander*))
(let* ([introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (if (procedure-arity-includes? transformer 2)
(transformer expander* mstx)
(transformer mstx))]
[result (syntax-local-introduce (introducer mresult))])
;(emit-local-step stx result #:id expander)
(parse result))))
;; raise an error, blaming stx
(define (match:syntax-err stx msg)
(raise-syntax-error #f msg stx))
;; pattern-var? : syntax -> bool
;; is p an identifier representing a pattern variable?
(define (pattern-var? p)
(and (identifier? p) (not (ddk? p))))
;; ddk? : syntax -> number or boolean
;; if #f is returned, was not a ddk identifier
;; if #t is returned, no minimum
;; if a number is returned, that's the minimum
(define (ddk? s*)
(define (./_ c) (or (equal? c #\.) (equal? c #\_)))
(let ([s (syntax->datum s*)])
(and (symbol? s)
(if (memq s '(... ___))
#t
(let* ([m (regexp-match #rx"^(?:\\.\\.|__)([0-9]+)$"
(symbol->string s))]
[n (and m (string->number (cadr m)))])
(cond [(not n) #f]
[(zero? n) #t]
[(exact-nonnegative-integer? n) n]
[else (raise-syntax-error
'match "invalid number for ..k pattern"
s*)]))))))
;; parse-literal : racket-val -> pat option
;; is v is a literal, return a pattern matching it
;; otherwise, return #f
(define (parse-literal v)
(if (or (number? v) (string? v) (keyword? v) (symbol? v) (bytes? v)
(regexp? v) (boolean? v) (char? v))
(make-Exact v)
#f))
;; (listof pat) syntax -> void
;; ps is never null
;; check that all the ps bind the same set of variables
(define (all-vars ps stx)
(let* ([first-vars (bound-vars (car ps))]
[l (length ps)]
[ht (make-free-identifier-mapping)])
(for ([v first-vars]) (free-identifier-mapping-put! ht v 1))
(for* ([p (cdr ps)]
[v (bound-vars p)])
(cond [(free-identifier-mapping-get ht v (lambda () #f))
=> (lambda (n)
(free-identifier-mapping-put! ht v (add1 n)))]
[else (raise-syntax-error 'match
"variable not bound in all or patterns"
stx v)]))
(free-identifier-mapping-for-each
ht
(lambda (v n)
(unless (= n l)
(raise-syntax-error 'match "variable not bound in all or patterns"
stx v))))))

75
whalesong/lang/private/match/parse-legacy.rkt Normal file
View File

@ -0,0 +1,75 @@
#lang racket/base
(require (for-template racket/base)
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt")
(provide parse/legacy)
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (parse/legacy stx)
(define (rearm new-stx) (syntax-rearm new-stx stx))
(define (parse stx) (parse/legacy (rearm stx)))
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case* disarmed-stx (not $ ? and or = quasiquote quote)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
(legacy-match-expander?
(syntax-local-value #'expander (λ () #f))))
(match-expander-transform
parse #'expander disarmed-stx legacy-match-expander-proc
"This expander only works with the standard match syntax")]
[(and p ...)
(make-And (map parse (syntax->list #'(p ...))))]
[(or)
(make-Not (make-Dummy stx))]
[(or p ps ...)
(let ([ps (map parse (syntax->list #'(p ps ...)))])
(all-vars ps stx)
(make-Or ps))]
[(not p ...)
;; nots are conjunctions of negations
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
(make-And ps))]
[bx
(box? (syntax-e #'bx))
(make-Box (parse (unbox (syntax-e #'bx))))]
[#(es ...)
(ormap ddk? (syntax->list #'(es ...)))
(make-And (list (make-Pred #'vector?)
(make-App #'vector->list
(list (parse (syntax/loc stx (es ...)))))))]
[#(es ...)
(make-Vector (map parse (syntax->list #'(es ...))))]
[($ s . pats)
(parse-struct disarmed-stx parse #'s #'pats)]
[(? p q1 qs ...)
(make-And (cons (make-Pred #'p)
(map parse (syntax->list #'(q1 qs ...)))))]
[(? p)
(make-Pred (rearm #'p))]
[(= f p)
(make-App #'f (list (parse #'p)))]
[(quasiquote p)
(parse-quasi #'p parse)]
[(quote . rest)
(parse-quote disarmed-stx parse)]
[() (make-Null (make-Dummy #f))]
[(..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(p .. . rest)
(ddk? #'..)
(dd-parse parse #'p #'.. #'rest #'list?)]
[(e . es)
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
[x
(identifier? #'x)
(parse-id #'x)]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in pattern" stx))]))

87
whalesong/lang/private/match/parse-quasi.rkt Normal file
View File

@ -0,0 +1,87 @@
#lang racket/base
(require (for-template racket/base)
"patterns.rkt"
"parse-helper.rkt")
(provide parse-quasi)
;; is pat a pattern representing a list?
(define (null-terminated? pat)
(cond [(Pair? pat) (null-terminated? (Pair-d pat))]
[(GSeq? pat) (null-terminated? (GSeq-tail pat))]
[(Null? pat) #t]
[else #f]))
;; combine a null-terminated pattern with another pattern to match afterwards
(define (append-pats p1 p2)
(cond [(Pair? p1) (make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))]
[(GSeq? p1) (make-GSeq (GSeq-headss p1)
(GSeq-mins p1)
(GSeq-maxs p1)
(GSeq-onces? p1)
(append-pats (GSeq-tail p1) p2)
(GSeq-mutable? p1))]
[(Null? p1) p2]
[else (error 'match "illegal input to append-pats")]))
;; parse stx as a quasi-pattern
;; parse parses unquote
(define (parse-quasi stx parse)
(define (pq s) (parse-quasi s parse))
(syntax-case stx (quasiquote unquote quote unquote-splicing)
[(unquote p) (parse #'p)]
[((unquote-splicing p) . rest)
(let ([pat (parameterize ([in-splicing? #t]) (parse #'p))]
[rpat (pq #'rest)])
(if (null-terminated? pat)
(append-pats pat rpat)
(raise-syntax-error 'match "non-list pattern inside unquote-splicing"
stx #'p)))]
[(p dd . rest)
(ddk? #'dd)
;; FIXME: parameterize dd-parse so that it can be used here
(let* ([count (ddk? #'dd)]
[min (and (number? count) count)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (pq #'p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(pq #'rest)
#f))]
[(a . b) (make-Pair (pq #'a) (pq #'b))]
;; prefab structs
[struct
(prefab-struct-key (syntax-e #'struct))
(let ([key (prefab-struct-key (syntax-e #'struct))]
[pats (cdr (vector->list (struct->vector (syntax-e #'struct))))])
(make-And (list (make-Pred #`(struct-type-make-predicate (prefab-key->struct-type '#,key #,(length pats))))
(make-App #'struct->vector
(list (make-Vector (cons (make-Dummy #f) (map pq pats)))))))
#;
(make-PrefabStruct key (map pq pats)))]
;; the hard cases
[#(p ...)
(ormap (lambda (p)
(or (ddk? p)
(syntax-case p (unquote-splicing)
[(unquote-splicing . _) #t]
[_ #f])))
(syntax->list #'(p ...)))
(make-And (list (make-Pred #'vector?)
(make-App #'vector->list
(list (pq (quasisyntax/loc stx (p ...)))))))]
[#(p ...)
(make-Vector (map pq (syntax->list #'(p ...))))]
[bx
(box? (syntax-e #'bx))
(make-Box (pq (unbox (syntax-e #'bx))))]
[()
(make-Null (make-Dummy #f))]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in quasipattern" stx))]))

184
whalesong/lang/private/match/parse.rkt Normal file
View File

@ -0,0 +1,184 @@
#lang racket/base
(require racket/struct-info
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt"
(for-template (only-in "runtime.rkt" matchable? mlist? mlist->list)
racket/base))
(provide parse)
(define (ht-pat-transform p)
(syntax-case p ()
[(a b) #'(list a b)]
[x (identifier? #'x) #'x]))
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
;; parse : syntax -> Pat
;; compile stx into a pattern, using the new syntax
(define (parse stx)
(define (rearm new-stx) (syntax-rearm new-stx stx))
(define (rearm+parse new-stx) (parse (rearm new-stx)))
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case* disarmed-stx (not var struct box cons list vector ? and or quote app
regexp pregexp list-rest list-no-order hash-table
quasiquote mcons list* mlist)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value #'expander
(lambda () #f))))
(match-expander-transform
rearm+parse #'expander disarmed-stx match-expander-proc
"This expander only works with the legacy match syntax")]
[(var v)
(identifier? #'v)
(Var (rearm #'v))]
[(and p ...)
(And (map rearm+parse (syntax->list #'(p ...))))]
[(or)
(Not (Dummy stx))]
[(or p ps ...)
(let ([ps (map rearm+parse (syntax->list #'(p ps ...)))])
(all-vars ps stx)
(Or ps))]
[(not p ...)
;; nots are conjunctions of negations
(let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))])
(And ps))]
[(regexp r)
(trans-match #'matchable?
(rearm #'(lambda (e) (regexp-match r e)))
(Pred #'values))]
[(regexp r p)
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
[(pregexp r)
(trans-match #'matchable?
(rearm
#'(lambda (e)
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(Pred #'values))]
[(pregexp r p)
(trans-match #'matchable?
(rearm
#'(lambda (e)
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(rearm+parse #'p))]
[(box e) (Box (parse #'e))]
[(vector es ...)
(ormap ddk? (syntax->list #'(es ...)))
(trans-match #'vector?
#'vector->list
(rearm+parse (syntax/loc stx (list es ...))))]
[(vector es ...)
(Vector (map rearm+parse (syntax->list #'(es ...))))]
[(hash-table p ... dd)
(ddk? #'dd)
(trans-match
#'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...)
(map ht-pat-transform (syntax->list #'(p ...)))])
(rearm+parse (syntax/loc stx (list-no-order elems ... dd)))))]
[(hash-table p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error
'match "dot dot k can only appear at the end of hash-table patterns" stx
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
[(hash-table p ...)
(trans-match #'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...)
(map ht-pat-transform
(syntax->list #'(p ...)))])
(rearm+parse (syntax/loc stx (list-no-order elems ...)))))]
[(hash-table . _)
(raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
[(list-no-order p ... lp dd)
(ddk? #'dd)
(let* ([count (ddk? #'dd)]
[min (if (number? count) count #f)]
[max (if (number? count) count #f)]
[ps (syntax->list #'(p ...))])
(GSeq (cons (list (rearm+parse #'lp))
(for/list ([p ps]) (list (parse p))))
(cons min (map (lambda _ 1) ps))
(cons max (map (lambda _ 1) ps))
;; vars in lp are lists, vars elsewhere are not
(cons #f (map (lambda _ #t) ps))
(Null (Dummy (syntax/loc stx _)))
#f))]
[(list-no-order p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error
'match "dot dot k can only appear at the end of unordered match patterns"
stx
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
[(list-no-order p ...)
(let ([ps (syntax->list #'(p ...))])
(GSeq (for/list ([p ps]) (list (rearm+parse p)))
(map (lambda _ 1) ps)
(map (lambda _ 1) ps)
;; all of these patterns get bound to only one thing
(map (lambda _ #t) ps)
(Null (Dummy (syntax/loc stx _)))
#f))]
[(list) (Null (Dummy (syntax/loc stx _)))]
[(mlist) (Null (Dummy (syntax/loc stx _)))]
[(list ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(mlist ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(list p .. . rest)
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'list?)]
[(mlist p .. . rest)
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'mlist? #:to-list #'mlist->list #:mutable #t)]
[(list e es ...)
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
[(mlist e es ...)
(MPair (rearm+parse #'e) (rearm+parse (syntax/loc stx (mlist es ...))))]
[(list* . rest)
(rearm+parse (syntax/loc stx (list-rest . rest)))]
[(list-rest e)
(rearm+parse #'e)]
[(list-rest p dd . rest)
(ddk? #'dd)
(dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)) #'list?)]
[(list-rest e . es)
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
[(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]
[(mcons e1 e2) (MPair (rearm+parse #'e1) (rearm+parse #'e2))]
[(struct s pats)
(parse-struct disarmed-stx rearm+parse #'s #'pats)]
[(s . pats)
(and (identifier? #'s) (struct-info? (syntax-local-value #'s (lambda () #f))))
(parse-struct disarmed-stx rearm+parse #'s #'pats)]
[(? p q1 qs ...)
(OrderedAnd
(list (Pred (rearm #'p))
(And (map rearm+parse (syntax->list #'(q1 qs ...))))))]
[(? p)
(Pred (rearm #'p))]
[(app f ps ...) ;; only make a list for more than one pattern
(App #'f (map rearm+parse (syntax->list #'(ps ...))))]
[(quasiquote p)
(parse-quasi #'p rearm+parse)]
[(quasiquote . _)
(raise-syntax-error 'match "illegal use of quasiquote")]
[(quote . _)
(parse-quote disarmed-stx rearm+parse)]
[x
(identifier? #'x)
(parse-id (rearm #'x))]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in pattern" disarmed-stx))]))
;; (trace parse)

212
whalesong/lang/private/match/patterns.rkt Normal file
View File

@ -0,0 +1,212 @@
#lang racket/base
(require syntax/boundmap
racket/contract
"stxtime.rkt"
(for-syntax racket/base))
(provide (except-out (combine-out
(all-defined-out)
(all-from-out "stxtime.rkt"))
struct-key-ht
get-key
(struct-out Row)))
(define orig-stx (make-parameter #f))
(define-struct Pat () #:transparent)
;; v is an identifier
(define-struct (Var Pat) (v)
#:transparent
#:property
prop:custom-write (lambda (v p w?)
(fprintf p "(Var ~a)" (syntax-e (Var-v v)))))
(define-struct (Dummy Var) ()
#:transparent
#:property
prop:custom-write (lambda (v p w?) (fprintf p "_")))
;; constructor patterns
(define-struct (CPat Pat) () #:transparent)
;; start is what index to start at
(define-struct (Vector CPat) (ps) #:transparent)
(define-struct (Pair CPat) (a d) #:transparent)
(define-struct (MPair CPat) (a d) #:transparent)
(define-struct (Box CPat) (p) #:transparent)
;; p is a pattern to match against the literal
(define-struct (Atom CPat) (p) #:transparent)
(define-struct (String Atom) () #:transparent)
(define-struct (Number Atom) () #:transparent)
(define-struct (Symbol Atom) () #:transparent)
(define-struct (Keyword Atom) () #:transparent)
(define-struct (Char Atom) () #:transparent)
(define-struct (Bytes Atom) () #:transparent)
(define-struct (Regexp Atom) () #:transparent)
(define-struct (Boolean Atom) () #:transparent)
(define-struct (Null Atom) () #:transparent)
;; expr is an expression
;; ps is a list of patterns
(define-struct (App Pat) (expr ps) #:transparent)
;; pred is an expression
(define-struct (Pred Pat) (pred) #:transparent)
;; pred is an identifier
;; super is an identifier, or #f
;; complete? is a boolean
;; accessors is a listof identifiers (NB in reverse order from the struct info)
;; ps is a listof patterns
(define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent)
;; both fields are lists of pats
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
;; ps are patterns
(define-struct (Or Pat) (ps) #:transparent)
(define-struct (And Pat) (ps) #:transparent)
(define-struct (OrderedAnd And) () #:transparent)
;; p is a pattern
(define-struct (Not Pat) (p) #:transparent)
;; headss : listof listof pattern
;; mins : listof option number
;; maxs : listof option number
;; onces? : listof boolean -- is this pattern being bound only once (take the
;; car of the variables)
;; tail : pattern
;; mutable? : is this for mutable lists?
(define-struct (GSeq Pat) (headss mins maxs onces? tail mutable?) #:transparent)
;; match with equal?
;; v is a quotable racket value
(define-struct (Exact Pat) (v) #:transparent)
;; pats is a Listof Pat
;; rhs is an expression
;; unmatch is an identifier
;; vars-seen is a listof identifiers
(define-struct Row (pats rhs unmatch vars-seen) #:transparent
#:property
prop:custom-write
(lambda (v p w?) (fprintf p "(Row ~a <expr>)" (Row-pats v))))
(define struct-key-ht (make-free-identifier-mapping))
(define (get-key id)
(free-identifier-mapping-get
struct-key-ht id
(lambda ()
(let ([k (box-immutable (syntax-e id))])
(free-identifier-mapping-put! struct-key-ht id k)
k))))
;; pat-key returns either an immutable box, or a symbol., or #f
;; the result is a box iff the argument was a struct pattern
;; (eq? (pat-key p) (pat-key q)) if p and q match the same constructor
;; the result is #f if p is not a constructor pattern
(define (pat-key p)
(cond [(Struct? p) (get-key (Struct-id p))]
[(Box? p) 'box]
[(Vector? p) 'vector]
[(Pair? p) 'pair]
[(MPair? p) 'mpair]
[(String? p) 'string]
[(Symbol? p) 'symbol]
[(Number? p) 'number]
[(Bytes? p) 'bytes]
[(Char? p) 'char]
[(Regexp? p) 'regexp]
[(Keyword? p) 'keyword]
[(Boolean? p) 'boolean]
[(Null? p) 'null]
[else #f]))
;; (require mzlib/trace)
;; (trace pat-key)
;; Row-first-pat : Row -> Pat
;; Row must not have empty list of pats
(define (Row-first-pat r)
(car (Row-pats r)))
(define (Row-split-pats r)
(define p (Row-pats r))
(values (car p) (cdr p)))
;; merge : (liftof (listof id)) -> (listof id)
;; merges lists of identifiers, removing module-identifier=? duplicates
(define (merge l)
(cond [(null? l) null]
[(null? (cdr l)) (car l)]
[else (let ([m (make-module-identifier-mapping)])
(for* ([ids l] [id ids])
(module-identifier-mapping-put! m id #t))
(module-identifier-mapping-map m (lambda (k v) k)))]))
;; bound-vars : Pat -> listof identifiers
(define (bound-vars p)
(cond
[(Dummy? p) null]
[(Pred? p) null]
[(Var? p)
(let ([v (Var-v p)])
(list (free-identifier-mapping-get (current-renaming) v (lambda () v))))]
[(Or? p)
(bound-vars (car (Or-ps p)))]
[(Box? p)
(bound-vars (Box-p p))]
[(Atom? p) null]
[(Pair? p)
(merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))]
[(MPair? p)
(merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))]
[(GSeq? p)
(merge (cons (bound-vars (GSeq-tail p))
(for/list ([pats (GSeq-headss p)])
(merge (for/list ([pat pats])
(bound-vars pat))))))]
[(Vector? p)
(merge (map bound-vars (Vector-ps p)))]
[(Struct? p)
(merge (map bound-vars (Struct-ps p)))]
[(App? p)
(merge (map bound-vars (App-ps p)))]
[(Not? p) null]
[(And? p)
(merge (map bound-vars (And-ps p)))]
[(Exact? p) null]
[else (error 'match "bad pattern: ~a" p)]))
(define current-renaming (make-parameter (make-free-identifier-mapping)))
(define (copy-mapping ht)
(define new-ht (make-free-identifier-mapping))
(free-identifier-mapping-for-each
ht (lambda (k v) (free-identifier-mapping-put! new-ht k v)))
new-ht)
#|
;; EXAMPLES
(define p-x (make-Var #'x))
(define p-y (make-Var #'y))
(define p-d (make-Dummy #'_))
(define p-cons (make-Pair p-x p-y))
(define p-vec (make-Vector (list p-x p-y p-d)))
(define r1 (make-Row (list p-x) #'#f #f null))
(define r2 (make-Row (list p-y) #'#f #f null))
(define r3 (make-Row (list p-cons) #'#f #f null))
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
|#
(provide/contract (struct Row ([pats (listof Pat?)]
[rhs syntax?]
[unmatch (or/c identifier? false/c)]
[vars-seen (listof (cons/c identifier?
identifier?))])))

87
whalesong/lang/private/match/reorder.rkt Normal file
View File

@ -0,0 +1,87 @@
#lang racket/base
(require "patterns.rkt"
(for-syntax racket/base))
(provide reorder-columns)
#|
(define p-x (make-Var #'x))
(define p-y (make-Var #'y))
(define p-d (make-Dummy #'_))
(define p-cons (make-Pair p-x p-y))
(define p-vec (make-Vector (list p-x p-y p-d)))
(define r1 (make-Row (list p-x) #'#f #f null))
(define r2 (make-Row (list p-y) #'#f #f null))
(define r3 (make-Row (list p-cons) #'#f #f null))
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
(define r5 (make-Row (list p-x p-y p-cons) #'1 #f null))
(define r6 (make-Row (list p-cons p-y p-vec) #'1 #f null))
|#
(define-sequence-syntax in-par
(lambda () (raise-syntax-error 'in-par "bad"))
(lambda (stx)
(syntax-case stx ()
[((id) (_ lst-exprs))
#'[(id)
(:do-in
;;outer bindings
([(lst) lst-exprs])
;; outer check
(void) ; (unless (list? lst) (in-list lst))
;; loop bindings
([lst lst])
;; pos check
(not (ormap null? lst))
;; inner bindings
([(id) (map car lst)])
;; pre guard
#t
;; post guard
#t
;; loop args
((map cdr lst)))]]
[_ (error 'no (syntax->datum stx))])))
(define (or-all? ps l)
(ormap (lambda (p) (andmap p l)) ps))
(define (count-while pred l)
(for/sum ([e (in-list l)] #:break (not (pred e))) 1))
(define (score col)
(define n (length col))
(define c (car col))
(define preds (list Var? Pair? Null?))
(cond [(or-all? preds col) (add1 n)]
[(andmap CPat? col) n]
[(Var? c) (count-while Var? col)]
[(Pair? c) (count-while Pair? col)]
[(Vector? c) (count-while Vector? col)]
[(Box? c) (count-while Box? col)]
[else 0]))
(define (reorder-by ps scores*)
(for/fold
([pats null])
([score-ref scores*])
(cons (list-ref ps score-ref) pats)))
(define (reorder-columns rows vars)
(define scores (for/list ([i (in-naturals)]
[column (in-par (map (compose Row-pats) rows))])
(cons i (score column))))
(define scores* (reverse (map car (sort scores > #:key cdr))))
(values
(for/list ([row rows])
(let ([ps (Row-pats row)])
(make-Row (reorder-by ps scores*)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row))))
(reorder-by vars scores*)))

72
whalesong/lang/private/match/runtime.rkt Normal file
View File

@ -0,0 +1,72 @@
#lang whalesong
(require "parameters.rkt") ; whalesong-libs
(require racket/stxparam
(for-syntax racket/base))
(provide match-equality-test
exn:misc:match?
match:error
fail
matchable?
match-prompt-tag
mlist? mlist->list)
(define match-prompt-tag (make-continuation-prompt-tag 'match))
; (define match-equality-test (make-parameter equal?))
; This is an parameter that a user of match can set in order
; to change the the equality operations used to determine
; if repeated uses of an identifier in a pattern has "equal" values.
; The default is equal?, so in the Whalesong matcher we just hardcode it.
(define match-equality-test (λ () equal?))
(define-struct (exn:misc:match exn:fail) (value srclocs)
#:property prop:exn:srclocs (lambda (ex) (exn:misc:match-srclocs ex)))
(define (match:error val srclocs form-name)
(raise (make-exn:misc:match (format "~a: no matching clause for ~e" form-name val)
(current-continuation-marks)
val
srclocs)))
(define-syntax-parameter fail
(lambda (stx)
(raise-syntax-error
#f "used out of context: not in match pattern" stx)))
;; can we pass this value to regexp-match?
(define (matchable? e)
(or (string? e)
; (bytes? e) ; [Whalesong] no byte strings
))
;; duplicated because we can't depend on `compatibility` here
(define mpair? pair?) ; [Whalesong] no mutable pairs
(define mcdr cdr) ; [Whalesong]
(define mcar car)
(define (mlist? l)
(cond
[(null? l) #t]
[(mpair? l)
(let loop ([turtle l][hare (mcdr l)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(let ([hare (mcdr hare)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(loop (mcdr turtle) (mcdr hare))]
[else #f]))]
[else #f]))]
[else #f]))
(define (mlist->list l)
(cond
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))

81
whalesong/lang/private/match/split-rows.rkt Normal file
View File

@ -0,0 +1,81 @@
#lang racket/base
(require "patterns.rkt")
(provide split-rows)
;; split-rows : Listof[Row] -> Listof[Listof[Row]]
;; takes a matrix, and returns a list of matrices
;; each returned matrix does not require the mixture rule to do compilation of
;; the first column.
(define (split-rows rows [acc null])
(define (loop/var matched-rows prev-mats rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(Var? p)
(loop/var (cons r matched-rows) prev-mats rs)]
[else
(split-rows rows (cons (reverse matched-rows) prev-mats))]))))
(define (loop/con matched-rows prev-mats struct-key rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(and (Struct? p) struct-key (eq? (pat-key p) struct-key))
;; (printf "struct-keys were equal: ~a\n" struct-key)
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
[(and (Struct? p) (not struct-key))
;; (printf "no struct-key so far: ~a\n" struct-key)
(loop/con (cons r matched-rows) prev-mats (pat-key p) rs)]
[(and (CPat? p) (not (Struct? p)))
;; (printf "wasn't a struct: ~a\n" p)
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
[else (split-rows rows (cons (reverse matched-rows)
prev-mats))]))))
(define (loop/exact matched-rows prev-mats rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond
[(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(Exact? p)
(loop/exact (cons r matched-rows) prev-mats rs)]
[else (split-rows rows (cons (reverse matched-rows) prev-mats))]))))
(if (null? rows)
(reverse acc)
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rs (cons (list r) acc))]
[(Var? p)
(loop/var (list r) acc rs)]
[(Exact? p)
(loop/exact (list r) acc rs)]
[(CPat? p)
(if (Struct? p)
(begin
;; (printf "found a struct: ~a\n" (pat-key r))
(loop/con (list r) acc (pat-key p) rs))
(loop/con (list r) acc #f rs))]
[else (split-rows rs (cons (list r) acc))]))))
;; (require mzlib/trace)
;; (trace split-rows)
;; EXAMPLES:
#|
(define mat1 (list r1 r2 r3))
(define mat2 (list r1 r3 r2 r1))
|#

80
whalesong/lang/private/match/struct.rkt Normal file
View File

@ -0,0 +1,80 @@
#lang whalesong
(require "match-expander.rkt"
(for-syntax racket/base
racket/struct-info
syntax/id-table
racket/list))
(define-match-expander
struct*
(lambda (stx)
(syntax-case stx ()
[(_ struct-name (field+pat ...))
(let* ([fail (lambda ()
(raise-syntax-error
'struct* "not a structure definition"
stx #'struct-name))]
[v (if (identifier? #'struct-name)
(syntax-local-value #'struct-name fail)
(fail))]
[field-acc->pattern (make-free-id-table)])
(unless (struct-info? v) (fail))
; Check each pattern and capture the field-accessor name
(for-each (lambda (an)
(syntax-case an ()
[(field pat)
(unless (identifier? #'field)
(raise-syntax-error
'struct* "not an identifier for field name"
stx #'field))
(let ([field-acc
(datum->syntax #'field
(string->symbol
(format "~a-~a"
(syntax-e #'struct-name)
(syntax-e #'field)))
#'field)])
(when (free-id-table-ref field-acc->pattern field-acc #f)
(raise-syntax-error 'struct* "Field name appears twice" stx #'field))
(free-id-table-set! field-acc->pattern field-acc #'pat))]
[_
(raise-syntax-error
'struct* "expected a field pattern of the form (<field-id> <pat>)"
stx an)]))
(syntax->list #'(field+pat ...)))
(let* (; Get the structure info
[acc (fourth (extract-struct-info v))]
;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(empty? acc) acc]
[(not (first acc)) (rest acc)]
[else acc])]
; Order the patterns in the order of the accessors
[pats-in-order
(for/list ([field-acc (in-list acc)])
(begin0
(free-id-table-ref
field-acc->pattern field-acc
(syntax/loc stx _))
; Use up pattern
(free-id-table-remove! field-acc->pattern field-acc)))])
; Check that all patterns were used
(free-id-table-for-each
field-acc->pattern
(lambda (field-acc pat)
(when pat
(raise-syntax-error 'struct* "field name not associated with given structure type"
stx field-acc))))
(quasisyntax/loc stx
(struct struct-name #,pats-in-order))))])))
(provide struct* ==)
(define-match-expander
==
(lambda (stx)
(syntax-case stx ()
[(_ val comp)
#'(? (lambda (x) (comp val x)))]
[(_ val) #'(? (lambda (x) (equal? val x)))])))

28
whalesong/lang/private/match/stxtime.rkt Normal file
View File

@ -0,0 +1,28 @@
#lang racket/base
(provide (all-defined-out))
(define match-...-nesting (make-parameter 0))
(struct acc-prop (n acc))
(define (make-struct-type-property/accessor name [guard #f] [supers null])
(define-values (p pred? acc)
(make-struct-type-property name
(λ (pval sinfo)
(cond [(exact-nonnegative-integer? pval)
(acc-prop pval (cadddr sinfo))]
[else (if (procedure? guard)
(guard pval sinfo)
pval)]))
supers))
(values p pred? (lambda (v)
(define v* (acc v))
(if (acc-prop? v*)
((acc-prop-acc v*) v (acc-prop-n v*))
v*))))
(define-values (prop:match-expander match-expander? match-expander-proc)
(make-struct-type-property/accessor 'prop:match-expander))
(define-values (prop:legacy-match-expander legacy-match-expander? legacy-match-expander-proc)
(make-struct-type-property/accessor 'prop:legacy-match-expander ))

16315
whalesong/lang/private/match/test-match.js Normal file
View File

File diff suppressed because one or more lines are too long

0
whalesong/lang/private/match/test-match_1.js Normal file
View File