Implemented Sam's suggested changes for new forms, and added a new match/values form.
This commit is contained in:
James Ian Johnson
Sam Tobin-Hochstadt
parent
93e1b634a3
commit
dc61372f3c
|
|
@ -12,18 +12,42 @@
|
|||
|
||||
(provide define-forms)
|
||||
|
||||
;; each pat matches a value in a multi-valued expression
|
||||
(define-for-syntax (match-values-clause->let-clause pats rhs)
|
||||
(with-syntax ([(pats ...) pats]
|
||||
[(ids ...) (generate-temporaries pats)])
|
||||
;; rhs evaluates to number of ids values.
|
||||
;; patterns should match against each id.
|
||||
(values #'(ids ...)
|
||||
#`[(ids ...) #,rhs])))
|
||||
|
||||
(define-for-syntax (match-values-clauses->let-clauses patses rhses)
|
||||
(for/lists (idses let-clauses)
|
||||
([pats (syntax->list patses)]
|
||||
[rhs (syntax->list rhses)])
|
||||
(match-values-clause->let-clause pats rhs)))
|
||||
|
||||
(define-for-syntax (all-same-length stx-listses)
|
||||
(let loop ([listses (syntax->list stx-listses)]
|
||||
[the-length #f])
|
||||
(cond [(null? listses) #t]
|
||||
[the-length
|
||||
(and (= the-length (length (syntax->list (car listses))))
|
||||
(loop (cdr listses) the-length))]
|
||||
[else (loop (cdr listses) (length (syntax->list (car listses))))])))
|
||||
|
||||
(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/derived match*/derived)
|
||||
match/values match/derived match*/derived)
|
||||
(...
|
||||
(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/derived match*/derived match-define-values)
|
||||
match/values match/derived match*/derived match-define-values)
|
||||
(define-syntax (match* stx)
|
||||
(syntax-parse stx
|
||||
[(_ es . clauses)
|
||||
|
|
@ -44,6 +68,16 @@
|
|||
[(_ arg:expr orig-stx clauses ...)
|
||||
(go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
|
||||
|
||||
(define-syntax (match/values stx)
|
||||
(syntax-parse stx
|
||||
[(_ arg:expr [(pats ...) rhs:expr] [(patses ...) rhses:expr] ...)
|
||||
#:fail-unless (all-same-length #'((pats ...) (patses ...) ...))
|
||||
"All clauses must have the same number of patterns"
|
||||
(define-values (ids let-clause)
|
||||
(match-values-clause->let-clause #'(pats ...) #'rhs))
|
||||
#`(let-values ([#,ids arg])
|
||||
(match*/derived #,ids #,stx [(pats ...) rhs] [(patses ...) rhses] ...))]))
|
||||
|
||||
(define-syntax (match-lambda stx)
|
||||
(syntax-parse stx
|
||||
[(_ . clauses)
|
||||
|
|
@ -65,6 +99,29 @@
|
|||
[body #`(match*/derived vars #,stx clauses ...)])
|
||||
(syntax/loc stx (lambda vars body)))]))
|
||||
|
||||
|
||||
(define-syntax (match-let-values stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...)
|
||||
(define-values (idses let-clauses)
|
||||
(match-values-clauses->let-clauses #'((patses ...) ...) #'(rhses ...)))
|
||||
#`(let-values #,let-clauses
|
||||
(match*/derived #,(append-map syntax->list idses) #,stx
|
||||
[(patses ... ...)
|
||||
(let () body1 body ...)]))]))
|
||||
|
||||
(define-syntax (match-let*-values stx)
|
||||
(syntax-parse stx
|
||||
[(_ () body1 body ...)
|
||||
#'(let () body1 body ...)]
|
||||
[(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
|
||||
(define-values (ids let-clause)
|
||||
(match-values-clause->let-clause #'(pats ...) #'rhs))
|
||||
#`(let-values (#,let-clause)
|
||||
(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)
|
||||
|
|
@ -76,46 +133,11 @@
|
|||
[(pat ...) (let () body1 body ...)])])
|
||||
#'(letrec ([nm (lambda vars loop-body)])
|
||||
(nm init-exp ...)))]
|
||||
[(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
|
||||
#`(match*/derived (init-exp ...) #,stx
|
||||
[(pat ...) (let () body1 body ...)])]))
|
||||
|
||||
(define-syntax (match-let* stx)
|
||||
(syntax-parse stx
|
||||
[(_ () body1 body ...)
|
||||
#'(let () body1 body ...)]
|
||||
[(_ ([pat exp] rest-pats ...) body1 body ...)
|
||||
#`(match*/derived
|
||||
(exp)
|
||||
#,stx
|
||||
[(pat) #,(syntax/loc stx (match-let* (rest-pats ...)
|
||||
body1 body ...))])]))
|
||||
|
||||
(define-syntax (match-let-values stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...)
|
||||
(define-values (let-clauses match-clauses)
|
||||
(for/lists (let-clauses match-clauses)
|
||||
([pats (syntax->list #'((patses ...) ...))]
|
||||
[rhs (syntax->list #'(rhses ...))])
|
||||
(with-syntax ([(pats ...) pats]
|
||||
[(ids ...) (generate-temporaries pats)])
|
||||
(values #`[(ids ...) #,rhs]
|
||||
#`([pats ids] ...)))))
|
||||
#`(let-values #,let-clauses
|
||||
#,(quasisyntax/loc stx
|
||||
(match-let #,(append-map syntax->list match-clauses)
|
||||
(let () body1 body ...))))]))
|
||||
|
||||
(define-syntax (match-let*-values stx)
|
||||
(syntax-parse stx
|
||||
[(_ () body1 body ...)
|
||||
#'(let () body1 body ...)]
|
||||
[(_ ([pats rhs] rest-pats ...) body1 body ...)
|
||||
#`(match-let-values ([pats rhs])
|
||||
#,(syntax/loc stx (match-let*-values (rest-pats ...)
|
||||
body1 body ...)))]))
|
||||
[(_ ([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
|
||||
|
|
@ -149,6 +171,6 @@
|
|||
(define-values vars
|
||||
(let-values ([(ids ...) rhs])
|
||||
(apply values
|
||||
(append
|
||||
(match*/derived (ids) #,stx
|
||||
[(pats) (list . pat-vars)]) ...))))))])))))
|
||||
(append
|
||||
(match*/derived (ids) #,stx
|
||||
[(pats) (list . pat-vars)]) ...))))))])))))
|
||||
|
|
|
|||
|
|
@ -18,4 +18,4 @@
|
|||
(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/derived match*/derived)
|
||||
match-define match-define-values match-letrec match/values match/derived match*/derived)
|
||||
|
|
|
|||
|
|
@ -20,4 +20,4 @@
|
|||
(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/derived match*/derived)
|
||||
match-define match-define-values match-letrec match/values match/derived match*/derived)
|
||||
|
|
|
|||
|
|
@ -368,6 +368,13 @@ same number of patterns as the number of @racket[val-expr]s.
|
|||
]
|
||||
}
|
||||
|
||||
@defform[(match/values expr clause clause ...)]{
|
||||
If @racket[expr] evaluates to @racket[n] values, then match all @racket[n]
|
||||
values against the patterns in @racket[clause ...]. Each clause must contain
|
||||
exactly @racket[n] patterns. At least one clause is required to determine how
|
||||
many values to expect from @racket[expr].
|
||||
}
|
||||
|
||||
@defform[(match-lambda clause ...)]{
|
||||
|
||||
Equivalent to @racket[(lambda (id) (match id clause ...))].
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/match
|
||||
(require scheme/match
|
||||
scheme/mpair
|
||||
scheme/control scheme/foreign
|
||||
(for-syntax scheme/base)
|
||||
|
|
@ -54,10 +54,10 @@
|
|||
(provide new-tests)
|
||||
|
||||
(define new-tests
|
||||
(test-suite
|
||||
(test-suite
|
||||
"new tests for match"
|
||||
|
||||
(comp
|
||||
|
||||
(comp
|
||||
1
|
||||
(match (list 1 2 3)
|
||||
[(list x ...) (=> unmatch)
|
||||
|
|
@ -66,26 +66,26 @@
|
|||
(error 'bad))
|
||||
0)]
|
||||
[_ 1]))
|
||||
|
||||
(comp
|
||||
|
||||
(comp
|
||||
'(1 2 3)
|
||||
(match (vector 1 2 3)
|
||||
[(vector (? number? x) ...) x]
|
||||
[_ 2]))
|
||||
|
||||
|
||||
(comp
|
||||
2
|
||||
(match (vector 'a 1 2 3)
|
||||
[(vector (? number? x) ...) x]
|
||||
[_ 2]))
|
||||
|
||||
|
||||
(comp
|
||||
3
|
||||
(match (list 'a 1 2 3)
|
||||
[(vector (? number? x) ...) x]
|
||||
[_ 3]))
|
||||
|
||||
|
||||
|
||||
|
||||
(comp -1
|
||||
(match (vector 1 2 3)
|
||||
[(or (list x) x) -1]
|
||||
|
|
@ -94,7 +94,7 @@
|
|||
[(vector a b) 2]
|
||||
[(vector a b c) 3]
|
||||
[(box _) 4]))
|
||||
|
||||
|
||||
(comp 12
|
||||
(match (list 12 12)
|
||||
[(list x x) x]
|
||||
|
|
@ -103,8 +103,8 @@
|
|||
(match (list 1 0)
|
||||
[(list x x) x]
|
||||
[_ 13]))
|
||||
|
||||
|
||||
|
||||
|
||||
(comp
|
||||
6
|
||||
(let ()
|
||||
|
|
@ -123,84 +123,84 @@
|
|||
[(cons x y) (+ x y)]
|
||||
[_ 0])))
|
||||
|
||||
|
||||
|
||||
(comp
|
||||
6
|
||||
(match (make-X 1 2 3)
|
||||
[(X: a b c) (+ a b c)]))
|
||||
|
||||
|
||||
|
||||
(comp
|
||||
|
||||
|
||||
(comp
|
||||
'(6 3 100 6)
|
||||
(list
|
||||
(f (cons 1 2) (cons 3 4))
|
||||
(f (box 1) (box 2))
|
||||
(f (list 10 20 30) (list 40))
|
||||
(f (vector 1 2 3) (vector 4))))
|
||||
|
||||
|
||||
(comp '(one (2 num) bool neither)
|
||||
(list
|
||||
(g 1)
|
||||
(g 2)
|
||||
(g #f)
|
||||
(g "foo")))
|
||||
|
||||
|
||||
(comp
|
||||
(split (list (list 1 2) (list 'a 'b) (list 'x 'y)))
|
||||
'((1 a x) (2 b y)))
|
||||
(comp
|
||||
(split2 (list (list 1 2) (list 'a 'b) (list 'x 'y)))
|
||||
'((1 a) (2 b) (x y)))
|
||||
|
||||
|
||||
(comp
|
||||
'yes
|
||||
(match (list (box 2) 2)
|
||||
[(list (or (box x) (list x)) x) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp
|
||||
'no
|
||||
(parameterize ([match-equality-test eq?])
|
||||
(match (list (cons 1 1) (cons 1 1))
|
||||
[(list x x) 'yes]
|
||||
[_ 'no])))
|
||||
|
||||
|
||||
(comp
|
||||
'no
|
||||
(match (list (box 2) 3)
|
||||
[(list (or (box x) (list x)) x) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp
|
||||
2
|
||||
(match (list 'one 'three)
|
||||
[(list 'one 'two) 1]
|
||||
[(list 'one 'three) 2]
|
||||
[(list 'two 'three) 3]))
|
||||
(comp
|
||||
(comp
|
||||
2
|
||||
(match (list 'one 'three)
|
||||
[(cons 'one (cons 'two '())) 1]
|
||||
[(cons 'one (cons 'three '())) 2]
|
||||
[(cons 'two (cons 'three '())) 3]))
|
||||
|
||||
|
||||
(comp 'yes
|
||||
(match '(1 x 2 y 3 z)
|
||||
[(list-no-order 1 2 3 'x 'y 'z) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
;; NOT WORKING YET
|
||||
(comp '(x y z)
|
||||
(match '(1 x 2 y 3 z)
|
||||
[(list-no-order 1 2 3 r1 r2 r3) (list r1 r2 r3)]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp '(x y z)
|
||||
(match '(1 x 2 y 3 z)
|
||||
[(list-no-order 1 2 3 rest ...) rest]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp
|
||||
'yes
|
||||
(match '(a (c d))
|
||||
|
|
@ -209,18 +209,18 @@
|
|||
(list-no-order 'c 'd)))
|
||||
'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp
|
||||
|
||||
|
||||
(comp
|
||||
'((1 2) (a b 1 2))
|
||||
(let ()
|
||||
(define-syntax-rule (match-lambda . cl)
|
||||
(lambda (e) (match e . cl)))
|
||||
|
||||
|
||||
(define (make-nil)
|
||||
'())
|
||||
(define nil? null?)
|
||||
|
||||
|
||||
(define make-::
|
||||
(match-lambda
|
||||
((list-no-order (list '|1| a) (list '|2| d))
|
||||
|
|
@ -229,7 +229,7 @@
|
|||
(define (::-content p)
|
||||
(list (list '|1| (car p))
|
||||
(list '|2| (cdr p))))
|
||||
|
||||
|
||||
(define my-append
|
||||
(match-lambda
|
||||
((list-no-order (list '|1| (? nil?))
|
||||
|
|
@ -245,11 +245,11 @@
|
|||
(list
|
||||
(my-append (list (list '|1| '())
|
||||
(list '|2| '(1 2))))
|
||||
|
||||
|
||||
(my-append (list (list '|1| '(a b))
|
||||
(list '|2| '(1 2)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(comp
|
||||
'yes
|
||||
(match
|
||||
|
|
@ -260,63 +260,63 @@
|
|||
(cons '|2| (cdr p)))))
|
||||
(hash-table ('|1| _) ('|2| _))))) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
;; examples from docs
|
||||
|
||||
|
||||
(comp 'yes
|
||||
(match '(1 2 3)
|
||||
[(list (not 4) ...) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 'no
|
||||
(match '(1 4 3)
|
||||
[(list (not 4) ...) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 1
|
||||
(match '(1 2)
|
||||
[(or (list a 1) (list a 2)) a]
|
||||
[_ 'bad]))
|
||||
|
||||
|
||||
(comp '(2 3)
|
||||
(match '(1 (2 3) 4)
|
||||
(match '(1 (2 3) 4)
|
||||
[(list _ (and a (list _ ...)) _) a]
|
||||
[_ 'bad]))
|
||||
|
||||
|
||||
|
||||
(comp
|
||||
|
||||
|
||||
|
||||
(comp
|
||||
'yes
|
||||
(match "apple"
|
||||
[(regexp #rx"p+(.)" (list _ "l")) 'yes]
|
||||
[_ 'no]))
|
||||
(comp
|
||||
(comp
|
||||
'no
|
||||
(match "append"
|
||||
[(regexp #rx"p+(.)" (list _ "l")) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp
|
||||
|
||||
|
||||
(comp
|
||||
'yes
|
||||
(match "apple"
|
||||
[(regexp #rx"p+" ) 'yes]
|
||||
[_ 'no]))
|
||||
(comp
|
||||
(comp
|
||||
'no
|
||||
(match "banana"
|
||||
[(regexp #rx"p+") 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
(comp
|
||||
|
||||
(comp
|
||||
'(0 1)
|
||||
(let ()
|
||||
(define-struct tree (val left right))
|
||||
|
||||
(match (make-tree 0 (make-tree 1 #f #f) #f)
|
||||
|
||||
(match (make-tree 0 (make-tree 1 #f #f) #f)
|
||||
[(struct tree (a (struct tree (b _ _)) _)) (list a b)]
|
||||
[_ 'no])))
|
||||
|
||||
|
||||
(comp 1
|
||||
(match #&1
|
||||
[(box a) a]
|
||||
|
|
@ -325,120 +325,120 @@
|
|||
(match #hasheq(("a" . 1) ("b" . 2))
|
||||
[(hash-table ("b" b) ("a" a)) (list b a)]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp #t
|
||||
(andmap string?
|
||||
(match #hasheq(("b" . 2) ("a" . 1))
|
||||
[(hash-table (key val) ...) key]
|
||||
[_ 'no])))
|
||||
|
||||
|
||||
(comp
|
||||
(match #(1 (2) (2) (2) 5)
|
||||
[(vector 1 (list a) ..3 5) a]
|
||||
[_ 'no])
|
||||
'(2 2 2))
|
||||
|
||||
|
||||
(comp '(1 3 4 5)
|
||||
(match '(1 2 3 4 5 6)
|
||||
(match '(1 2 3 4 5 6)
|
||||
[(list-no-order 6 2 y ...) y]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 1
|
||||
(match '(1 2 3)
|
||||
(match '(1 2 3)
|
||||
[(list-no-order 3 2 x) x]))
|
||||
(comp '((1 2 3) 4)
|
||||
(match '(1 2 3 . 4)
|
||||
(match '(1 2 3 . 4)
|
||||
[(list-rest a ... d) (list a d)]))
|
||||
|
||||
|
||||
(comp 4
|
||||
(match '(1 2 3 . 4)
|
||||
[(list-rest a b c d) d]))
|
||||
|
||||
|
||||
;; different behavior from the way match used to be
|
||||
(comp '(2 3 4)
|
||||
(match '(1 2 3 4 5)
|
||||
[(list 1 a ..3 5) a]
|
||||
[(list 1 a ..3 5) a]
|
||||
[_ 'else]))
|
||||
|
||||
|
||||
(comp '((1 2 3 4) ())
|
||||
(match (list 1 2 3 4 5)
|
||||
[(list x ... y ... 5) (list x y)]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp '((1 3 2) (4))
|
||||
(match (list 1 3 2 3 4 5)
|
||||
[(list x ... 3 y ... 5) (list x y)]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp '(3 2 1)
|
||||
(match '(1 2 3)
|
||||
[(list a b c) (list c b a)]))
|
||||
|
||||
|
||||
(comp '(2 3)
|
||||
(match '(1 2 3)
|
||||
[(list 1 a ...) a]))
|
||||
|
||||
|
||||
(comp 'else
|
||||
(match '(1 2 3)
|
||||
[(list 1 a ..3) a]
|
||||
[_ 'else]))
|
||||
|
||||
|
||||
(comp '(2 3 4)
|
||||
(match '(1 2 3 4)
|
||||
[(list 1 a ..3) a]
|
||||
[_ 'else]))
|
||||
|
||||
|
||||
(comp
|
||||
'(2 2 2)
|
||||
(match '(1 (2) (2) (2) 5)
|
||||
[(list 1 (list a) ..3 5) a]
|
||||
[_ 'else]))
|
||||
|
||||
|
||||
(comp
|
||||
#t
|
||||
(match "yes"
|
||||
["yes" #t]
|
||||
["no" #f]))
|
||||
|
||||
|
||||
(comp 3
|
||||
(match '(1 2 3)
|
||||
[(list _ _ a) a]))
|
||||
(comp '(3 2 1)
|
||||
(match '(1 2 3)
|
||||
[(list a b a) (list a b)]
|
||||
(match '(1 2 3)
|
||||
[(list a b a) (list a b)]
|
||||
[(list a b c) (list c b a)]))
|
||||
|
||||
|
||||
(comp '(2 '(x y z) 1)
|
||||
(match '(1 '(x y z) 2)
|
||||
[(list a b a) (list a b)]
|
||||
(match '(1 '(x y z) 2)
|
||||
[(list a b a) (list a b)]
|
||||
[(list a b c) (list c b a)]))
|
||||
|
||||
|
||||
(comp '(1 '(x y z))
|
||||
(match '(1 '(x y z) 1)
|
||||
[(list a b a) (list a b)]
|
||||
(match '(1 '(x y z) 1)
|
||||
[(list a b a) (list a b)]
|
||||
[(list a b c) (list c b a)]))
|
||||
|
||||
|
||||
(comp '(2 3)
|
||||
(match '(1 2 3)
|
||||
[`(1 ,a ,(? odd? b)) (list a b)]))
|
||||
|
||||
|
||||
(comp '(2 1 (1 2 3 4))
|
||||
(match-let ([(list a b) '(1 2)]
|
||||
[(vector x ...) #(1 2 3 4)])
|
||||
(match-let ([(list a b) '(1 2)]
|
||||
[(vector x ...) #(1 2 3 4)])
|
||||
(list b a x)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(comp '(1 2 3 4)
|
||||
(match-let* ([(list a b) '(#(1 2 3 4) 2)]
|
||||
[(vector x ...) a])
|
||||
(match-let* ([(list a b) '(#(1 2 3 4) 2)]
|
||||
[(vector x ...) a])
|
||||
x))
|
||||
|
||||
|
||||
(comp 2
|
||||
(let ()
|
||||
(match-define (list a b) '(1 2))
|
||||
b))
|
||||
|
||||
|
||||
(comp 'yes
|
||||
(match '(number_1 . number_2)
|
||||
[`(variable-except ,@(list vars ...))
|
||||
|
|
@ -446,7 +446,7 @@
|
|||
[(? list?)
|
||||
'no]
|
||||
[_ 'yes]))
|
||||
|
||||
|
||||
(comp "yes"
|
||||
(match
|
||||
'((555))
|
||||
|
|
@ -454,7 +454,7 @@
|
|||
(list-no-order 555)))
|
||||
"yes")
|
||||
(_ "no"))) ;; prints "no"
|
||||
|
||||
|
||||
(comp "yes"
|
||||
(match
|
||||
'((555))
|
||||
|
|
@ -462,7 +462,7 @@
|
|||
(list 555)))
|
||||
"yes")
|
||||
(_ "no"))) ;; prints "yes"
|
||||
|
||||
|
||||
(comp "yes"
|
||||
(match
|
||||
'((555))
|
||||
|
|
@ -470,36 +470,36 @@
|
|||
(list-no-order 555)))
|
||||
"yes")
|
||||
(_ "no"))) ;; prints "yes"
|
||||
|
||||
|
||||
(comp '("a") (match "a" ((regexp #rx"a" x) x)))
|
||||
(comp '(#"a")
|
||||
(comp '(#"a")
|
||||
(match #"a"
|
||||
((regexp #rx"a" x) x)
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 'yes (match #"a" (#"a" 'yes)))
|
||||
|
||||
|
||||
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand #'(match-lambda ((a ?) #f))) 'no))
|
||||
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand #'(match-lambda ((?) #f))) 'no))
|
||||
|
||||
|
||||
(comp
|
||||
'yes
|
||||
(let ()
|
||||
|
||||
|
||||
(m:define-match-expander exp1
|
||||
#:plt-match
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_match (x y))
|
||||
#'(list (list x y))))))
|
||||
|
||||
|
||||
(m:define-match-expander exp2
|
||||
#:plt-match
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_match x y)
|
||||
#'(exp1 (x y))))))
|
||||
|
||||
|
||||
(define (test tp)
|
||||
(match tp ((exp2 x y) x)))
|
||||
'yes))
|
||||
|
|
@ -510,28 +510,28 @@
|
|||
(let ()
|
||||
(define (foo x) (match x [1 (+ x x)]))
|
||||
(foo 1)))
|
||||
|
||||
|
||||
|
||||
|
||||
(comp 'yes
|
||||
(match (make-empt)
|
||||
[(struct empt ()) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 'yes
|
||||
(m:match (make-empt)
|
||||
[($ empt) 'yes]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 3
|
||||
(match (mcons 1 2)
|
||||
[(mcons a b) (+ a b)]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 3
|
||||
(match (mlist 1 2)
|
||||
[(mlist a b) (+ a b)]
|
||||
[_ 'no]))
|
||||
|
||||
|
||||
(comp 3
|
||||
(match (mlist 1 2)
|
||||
[(mlist a ...) (apply + a)]
|
||||
|
|
@ -539,7 +539,7 @@
|
|||
|
||||
(comp 1
|
||||
(match (box 'x) ('#&x 1) (else #f)))
|
||||
|
||||
|
||||
(comp 2
|
||||
(match (vector 1 2) ('#(1 2) 2) (else #f)))
|
||||
|
||||
|
|
@ -548,7 +548,7 @@
|
|||
[values (lambda _ 'no)])
|
||||
(match 1)
|
||||
'no))
|
||||
|
||||
|
||||
(comp 'yes
|
||||
(with-handlers ([exn:fail:syntax? (lambda _ 'yes)]
|
||||
[values (lambda _ 'no)])
|
||||
|
|
@ -560,49 +560,49 @@
|
|||
0))))
|
||||
|
||||
;; raises error
|
||||
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])
|
||||
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])
|
||||
(expand (quote-syntax (match '(1 x 2 y 3 z)
|
||||
[(list-no-order 1 2 3 rest ... e) rest]
|
||||
[_ 'no])))
|
||||
'no))
|
||||
(comp '((2 4) (2 1))
|
||||
(comp '((2 4) (2 1))
|
||||
(match '(3 2 4 3 2 1)
|
||||
[(list x y ... x z ...)
|
||||
[(list x y ... x z ...)
|
||||
(list y z)]))
|
||||
|
||||
(comp '(1 2)
|
||||
(match-let ([(vector a b) (vector 1 2)])
|
||||
(list a b)))
|
||||
|
||||
|
||||
(comp '(4 5)
|
||||
(let-values ([(x y)
|
||||
(match 1
|
||||
[(or (and x 2) (and x 3) (and x 4)) 3]
|
||||
[_ (values 4 5)])])
|
||||
(list x y)))
|
||||
|
||||
|
||||
(comp 'bad
|
||||
(match #(1)
|
||||
(match #(1)
|
||||
[(vector a b) a]
|
||||
[else 'bad]))
|
||||
|
||||
(comp '(1 2)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(match 'foo [_ (=> skip) (skip)] [_ (values 1 2)]))
|
||||
list))
|
||||
(comp 0
|
||||
(let ([z (make-parameter 0)])
|
||||
(match 1
|
||||
[(? number?) (=> f) (parameterize ([z 1]) (f))]
|
||||
[(? number?) (=> f) (parameterize ([z 1]) (f))]
|
||||
[(? number?) (z)])))
|
||||
|
||||
|
||||
;; make sure the prompts don't interfere
|
||||
(comp 12
|
||||
(%
|
||||
(let ([z (make-parameter 0)])
|
||||
(match 1
|
||||
[(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))]
|
||||
[(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))]
|
||||
[(? number?) (z)]))
|
||||
(lambda _ 12)))
|
||||
|
||||
|
|
@ -611,7 +611,7 @@
|
|||
(match 3
|
||||
[(or) 1]
|
||||
[_ 4]))
|
||||
|
||||
|
||||
(comp '((1 2) 3)
|
||||
(match `(begin 1 2 3)
|
||||
[`(begin ,es ... ,en)
|
||||
|
|
@ -619,14 +619,14 @@
|
|||
|
||||
(comp '(a b c)
|
||||
(let ()
|
||||
|
||||
|
||||
(define-struct foo (a b c) #:prefab)
|
||||
(match (make-foo 'a 'b 'c)
|
||||
[`#s(foo ,x ,y ,z)
|
||||
(list x y z)])))
|
||||
(comp '(a b c)
|
||||
(let ()
|
||||
|
||||
|
||||
(define-struct foo (a b c) #:prefab)
|
||||
(define-struct (bar foo) (d) #:prefab)
|
||||
(match (make-bar 'a 'b 'c 1)
|
||||
|
|
@ -639,11 +639,11 @@
|
|||
([x _double*]
|
||||
[y _double*]
|
||||
[a _double*]))
|
||||
|
||||
|
||||
(match (make-pose 1 2 3)
|
||||
[(struct pose (x y a)) "Gotcha!"]
|
||||
[else "Epic fail!"])))
|
||||
|
||||
|
||||
(comp #f
|
||||
(match (list 'a 'b 'c)
|
||||
[(or (list a b)
|
||||
|
|
@ -653,17 +653,17 @@
|
|||
(list a))))
|
||||
#t]
|
||||
[_ #f]))
|
||||
|
||||
|
||||
(comp '(2 7)
|
||||
(let ()
|
||||
(define-match-expander foo
|
||||
(syntax-rules () [(_) 1])
|
||||
(syntax-id-rules (set!)
|
||||
(syntax-id-rules (set!)
|
||||
[(set! _ v) v]
|
||||
[(_) 2]))
|
||||
(list (foo)
|
||||
(set! foo 7))))
|
||||
|
||||
|
||||
(comp 0
|
||||
(let ()
|
||||
(define-match-expander foo
|
||||
|
|
@ -672,4 +672,24 @@
|
|||
[(foo) 0]
|
||||
[_ 1])))
|
||||
|
||||
(comp '(1 2 4)
|
||||
(call-with-values
|
||||
(λ () (match-let-values ([(x y) (values 1 2)] [(3 w) (values 3 4)])
|
||||
(list x y w)))
|
||||
list))
|
||||
|
||||
(comp '(1 3 4)
|
||||
(call-with-values
|
||||
(λ () (match-let*-values ([(x y) (values 1 2)] [(y w) (values 3 4)])
|
||||
(list x y w)))
|
||||
list))
|
||||
|
||||
(comp '(1 2 3)
|
||||
(match/values (values 1 2 3)
|
||||
[(x y z) (list x y z)]))
|
||||
|
||||
(comp '(1 2)
|
||||
(let () (match-define-values (x y 3) (values 1 2 3))
|
||||
(list x y)))
|
||||
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user