Adding match to ASL
This commit is contained in:
Jay McCarthy
parent
eeada45868
commit
407dcee206
|
|
@ -48,6 +48,7 @@
|
|||
[advanced-when when]
|
||||
[advanced-unless unless]
|
||||
[advanced-case case]
|
||||
[advanced-match match]
|
||||
[advanced-delay delay]
|
||||
[advanced-module-begin #%module-begin]
|
||||
)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
;; The posn struct for the teaching languages
|
||||
(provide struct:posn make-posn posn? posn-x posn-y set-posn-x! set-posn-y!
|
||||
(rename-out (posn posn-id))
|
||||
(rename-out (posn-signature posn)))
|
||||
|
||||
(struct posn (x y) #:mutable #:transparent)
|
||||
|
|
|
|||
|
|
@ -49,7 +49,10 @@
|
|||
(rename deinprogramm/quickcheck/quickcheck quickcheck:property property)
|
||||
test-engine/scheme-tests
|
||||
scheme/class
|
||||
(only lang/private/teachprims beginner-equal? beginner-equal~?))
|
||||
"../posn.rkt"
|
||||
(only lang/private/teachprims
|
||||
beginner-equal? beginner-equal~?
|
||||
advanced-cons advanced-list*))
|
||||
(require-for-syntax "teachhelp.ss"
|
||||
"teach-shared.ss"
|
||||
syntax/kerncase
|
||||
|
|
@ -209,6 +212,7 @@
|
|||
advanced-begin
|
||||
advanced-begin0
|
||||
advanced-case
|
||||
advanced-match
|
||||
advanced-shared
|
||||
advanced-delay)
|
||||
|
||||
|
|
@ -2521,6 +2525,133 @@
|
|||
(syntax/loc stx (case v-expr . clauses)))))]
|
||||
[_else (bad-use-error 'case stx)]))))
|
||||
|
||||
;; match (advanced)
|
||||
(define (advanced-match/proc stx)
|
||||
(ensure-expression
|
||||
stx
|
||||
(lambda ()
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(teach-syntax-error
|
||||
'match
|
||||
stx
|
||||
#f
|
||||
"expected an expression after `match', but nothing's there")]
|
||||
[(_ expr)
|
||||
(teach-syntax-error
|
||||
'match
|
||||
stx
|
||||
#f
|
||||
"expected a pattern--answer clause after the expression following `match', but nothing's there")]
|
||||
[(_ v-expr clause ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))])
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case clause ()
|
||||
[(pattern answer ...)
|
||||
(let ([pattern (syntax pattern)]
|
||||
[answers (syntax->list (syntax (answer ...)))])
|
||||
(check-single-expression 'match
|
||||
"for the answer in a `match' clause"
|
||||
clause
|
||||
answers
|
||||
null))]
|
||||
[()
|
||||
(teach-syntax-error
|
||||
'match
|
||||
stx
|
||||
clause
|
||||
"expected a pattern--answer clause, but found an empty clause")]
|
||||
[_else
|
||||
(teach-syntax-error
|
||||
'match
|
||||
stx
|
||||
clause
|
||||
"expected a pattern--answer clause, but found ~a"
|
||||
(something-else clause))]))
|
||||
clauses)
|
||||
|
||||
(letrec
|
||||
([check-and-translate-qqp
|
||||
(λ (qqp)
|
||||
(syntax-case qqp (intermediate-unquote intermediate-unquote-splicing)
|
||||
[(intermediate-unquote p)
|
||||
(quasisyntax/loc qqp
|
||||
(unquote #,(check-and-translate-p #'p)))]
|
||||
[(intermediate-unquote-splicing p)
|
||||
(quasisyntax/loc qqp
|
||||
(unquote-splicing #,(check-and-translate-p #'p)))]
|
||||
[(qqpi ...)
|
||||
(quasisyntax/loc qqp
|
||||
(#,@(map check-and-translate-qqp (syntax->list #'(qqpi ...)))))]
|
||||
[_
|
||||
qqp]))]
|
||||
[check-and-translate-p
|
||||
(λ (p)
|
||||
(syntax-case p (struct posn true false empty intermediate-quote intermediate-quasiquote advanced-cons list advanced-list* vector box)
|
||||
[true
|
||||
(syntax/loc p
|
||||
#t)]
|
||||
[false
|
||||
(syntax/loc p
|
||||
#f)]
|
||||
[empty
|
||||
(syntax/loc p
|
||||
(list))]
|
||||
[(intermediate-quote qp)
|
||||
(syntax/loc p
|
||||
(quote qp))]
|
||||
[(intermediate-quasiquote qqp)
|
||||
(quasisyntax/loc p
|
||||
(quasiquote #,(check-and-translate-qqp #'qqp)))]
|
||||
[(advanced-cons p1 p2)
|
||||
(quasisyntax/loc p
|
||||
(cons #,(check-and-translate-p #'p1)
|
||||
#,(check-and-translate-p #'p2)))]
|
||||
[(list pi ...)
|
||||
(quasisyntax/loc p
|
||||
(list #,@(map check-and-translate-p (syntax->list #'(pi ...)))))]
|
||||
[(advanced-list* pi ...)
|
||||
(quasisyntax/loc p
|
||||
(list* #,@(map check-and-translate-p (syntax->list #'(pi ...)))))]
|
||||
[(struct posn (pi ...))
|
||||
(quasisyntax/loc p
|
||||
(struct posn-id #,(map check-and-translate-p (syntax->list #'(pi ...)))))]
|
||||
[(struct struct-id (pi ...))
|
||||
(quasisyntax/loc p
|
||||
(struct struct-id #,(map check-and-translate-p (syntax->list #'(pi ...)))))]
|
||||
[(vector pi ...)
|
||||
(quasisyntax/loc p
|
||||
(vector #,@(map check-and-translate-p (syntax->list #'(pi ...)))))]
|
||||
[(box p1)
|
||||
(quasisyntax/loc p
|
||||
(box #,(check-and-translate-p #'p1)))]
|
||||
[_
|
||||
(let ([v (syntax->datum p)])
|
||||
(if (or (and (symbol? v)
|
||||
(not (member v '(true false empty))))
|
||||
(number? v)
|
||||
(string? v)
|
||||
(char? v))
|
||||
p
|
||||
(teach-syntax-error
|
||||
'match
|
||||
stx
|
||||
p
|
||||
"expected a pattern, but found ~a"
|
||||
(something-else p))))]))])
|
||||
(let ([clauses
|
||||
(map (λ (c)
|
||||
(syntax-case c ()
|
||||
[(p e)
|
||||
(quasisyntax/loc c
|
||||
(#,(check-and-translate-p #'p) e))]))
|
||||
clauses)])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx
|
||||
(match v-expr . clauses))))))]
|
||||
[_else (bad-use-error 'match stx)]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; delay (advanced)
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,9 @@
|
|||
|
||||
@schemegrammar*+qq[
|
||||
#:literals (define define-struct define-datatype lambda λ cond else if and or empty true false require lib planet
|
||||
local let let* letrec time begin begin0 set! delay shared recur when case unless
|
||||
local let let* letrec time begin begin0 set! delay shared recur when case match unless
|
||||
; match
|
||||
_ cons list list* struct vector box
|
||||
check-expect check-within check-error)
|
||||
(check-expect check-within check-error require)
|
||||
[program (code:line def-or-expr ...)]
|
||||
|
|
@ -75,6 +77,7 @@
|
|||
[(choice choice ...) expr])
|
||||
(case expr [(choice choice ...) expr] ...
|
||||
[else expr])
|
||||
(match expr [pattern expr] ...)
|
||||
(if expr expr expr)
|
||||
(when expr expr)
|
||||
(unless expr expr)
|
||||
|
|
@ -88,11 +91,37 @@
|
|||
(code:line @#,elem{@schemevalfont{`}@scheme[_quasiquoted]} (code:comment @#,seclink["beginner-abbr-quasiquote"]{quasiquote}))
|
||||
number
|
||||
true
|
||||
|
||||
false
|
||||
string
|
||||
character]
|
||||
[choice (code:line id (code:comment @#,t{treated as a symbol}))
|
||||
number]
|
||||
[pattern _
|
||||
empty
|
||||
id
|
||||
number
|
||||
true
|
||||
false
|
||||
string
|
||||
character
|
||||
@#,elem{@schemevalfont{'}@scheme[_quoted]}
|
||||
@#,elem{@schemevalfont{`}@scheme[_quasiquoted-pattern]}
|
||||
(cons pattern pattern)
|
||||
(list pattern ...)
|
||||
(list* pattern ...)
|
||||
(struct id (pattern ...))
|
||||
(vector pattern ...)
|
||||
(box pattern)]
|
||||
[quasiquoted-pattern id
|
||||
number
|
||||
string
|
||||
character
|
||||
(quasiquoted-pattern ...)
|
||||
@#,elem{@schemevalfont{'}@scheme[_quasiquoted-pattern]}
|
||||
@#,elem{@schemevalfont{`}@scheme[_quasiquoted-pattern]}
|
||||
@#,elem{@schemefont[","]@scheme[_pattern]}
|
||||
@#,elem{@schemefont[",@"]@scheme[_pattern]}]
|
||||
]
|
||||
|
||||
@|prim-nonterms|
|
||||
|
|
@ -293,7 +322,22 @@ This form of @scheme[case] is similar to the prior one, except that
|
|||
the final @scheme[else] clause is always taken if no prior line
|
||||
contains a choice matching the value of the initial @scheme[expr]. In
|
||||
other words, so there is no possibility to ``fall off the end'' of
|
||||
the @scheme[case] form.}
|
||||
the @scheme[case] form.}@; ----------------------------------------------------------------------
|
||||
|
||||
@section{@scheme[match]}
|
||||
|
||||
@defform[(match expr [pattern expr] ...)]{
|
||||
|
||||
A @scheme[match] form contains one or more ``lines'' that are
|
||||
surrounded by parentheses or square brackets. Each line contains a
|
||||
pattern---a description of a value---and an answer @scheme[expr].
|
||||
The initial @scheme[expr] is evaluated, and the resulting value
|
||||
is matched against the pattern in each line, where the lines are
|
||||
considered in order. The first line that contains a matching pattern
|
||||
provides an answer @scheme[expr] whose value is the result of the
|
||||
whole @scheme[match] expression. This @scheme[expr] may reference
|
||||
identifiers bound in the matching pattern. If none of the lines
|
||||
contains a matching pattern, it is an error.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -343,6 +343,102 @@
|
|||
(htdp-test #f 'a? (a? 1))
|
||||
(htdp-top-pop 1)
|
||||
|
||||
;; match
|
||||
|
||||
(htdp-syntax-test #'match #rx"match: found a use of `match' that does not follow an open parenthesis")
|
||||
(htdp-syntax-test #'(match) #rx"match: expected an expression after `match', but nothing's there")
|
||||
(htdp-syntax-test #'(match 1) #rx"match: expected a pattern--answer clause after the expression following `match', but nothing's there")
|
||||
|
||||
(htdp-syntax-test #'(match 1 10) #rx"match: expected a pattern--answer clause, but found a number")
|
||||
(htdp-syntax-test #'(match 1 x) #rx"match: expected a pattern--answer clause, but found something else")
|
||||
(htdp-syntax-test #'(match 1 []) #rx"match: expected a pattern--answer clause, but found an empty clause")
|
||||
(htdp-syntax-test #'(match 1 [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there")
|
||||
(htdp-syntax-test #'(match 1 [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
|
||||
(htdp-syntax-test #'(match 1 [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
|
||||
|
||||
(htdp-syntax-test #'(match 1 [x 10] 10) #rx"match: expected a pattern--answer clause, but found a number")
|
||||
(htdp-syntax-test #'(match 1 [x 10] x) #rx"match: expected a pattern--answer clause, but found something else")
|
||||
(htdp-syntax-test #'(match 1 [x 10] []) #rx"match: expected a pattern--answer clause, but found an empty clause")
|
||||
(htdp-syntax-test #'(match 1 [x 10] [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there")
|
||||
(htdp-syntax-test #'(match 1 [x 10] [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
|
||||
(htdp-syntax-test #'(match 1 [x 10] [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part")
|
||||
|
||||
(define-syntax-rule (htdp-match/v res pat expr val)
|
||||
(htdp-test res 'pat (match expr [pat val] [else #f])))
|
||||
(define-syntax-rule (htdp-match res pat expr)
|
||||
(htdp-match/v res pat expr #t))
|
||||
|
||||
(htdp-match #t true true)
|
||||
(htdp-match #f true false)
|
||||
(htdp-match #f true 1)
|
||||
|
||||
(htdp-match #f false true)
|
||||
(htdp-match #t false false)
|
||||
(htdp-match #f false 1)
|
||||
|
||||
(htdp-match #t empty empty)
|
||||
(htdp-match #f empty 1)
|
||||
|
||||
(htdp-match #t 1 1)
|
||||
(htdp-match #t '1 1)
|
||||
(htdp-match #t `1 1)
|
||||
(htdp-match #f 1 2)
|
||||
|
||||
(htdp-match #t "foo" "foo")
|
||||
(htdp-match #t '"foo" "foo")
|
||||
(htdp-match #t `"foo" "foo")
|
||||
(htdp-match #f "foo" "bar")
|
||||
|
||||
(htdp-match #t #\a #\a)
|
||||
(htdp-match #t '#\a #\a)
|
||||
(htdp-match #t `#\a #\a)
|
||||
(htdp-match #f #\a #\b)
|
||||
|
||||
(htdp-match #t 'a 'a)
|
||||
(htdp-match #f 'a 'b)
|
||||
|
||||
(htdp-match #t '(a b) (list 'a 'b))
|
||||
(htdp-match #t ''a ''a)
|
||||
(htdp-match #t '`a '`a)
|
||||
(htdp-match #t ',a ',a)
|
||||
(htdp-match #t ',@a ',@a)
|
||||
|
||||
(htdp-match #t `(a b) (list 'a 'b))
|
||||
(htdp-match #t `'a ''a)
|
||||
(htdp-match #t ``a '`a)
|
||||
|
||||
(htdp-match #t (cons a b) (list 1))
|
||||
(htdp-match #f (cons 1 2) 1)
|
||||
(htdp-match #t (list a b) (list 1 2))
|
||||
(htdp-match #f (list a b) (list 1))
|
||||
(htdp-match #t (list* a b) (list 1))
|
||||
(htdp-match #f (list* a b) empty)
|
||||
|
||||
(htdp-match #t (vector x y) (vector 1 2))
|
||||
(htdp-match #f (vector x x) (vector 1 2))
|
||||
(htdp-match #t (vector _ _) (vector 1 2))
|
||||
(htdp-match #f (vector x y) (vector 1))
|
||||
|
||||
(htdp-match #t (box x) (box 1))
|
||||
(htdp-match #f (box x) 1)
|
||||
|
||||
(htdp-match/v 1 a 1 a)
|
||||
|
||||
(htdp-top (define-struct my-posn (x y)))
|
||||
(htdp-match/v 3 (struct my-posn (x y)) (make-my-posn 1 2) (+ x y))
|
||||
(htdp-top-pop 1)
|
||||
|
||||
(htdp-match/v 3 (struct posn (x y)) (make-posn 1 2) (+ x y))
|
||||
(htdp-match/v 3 (cons (struct posn (x y)) empty) (cons (make-posn 1 2) empty) (+ x y))
|
||||
(htdp-match/v 3 (list* (struct posn (x y)) empty) (list* (make-posn 1 2) empty) (+ x y))
|
||||
(htdp-match/v 3 (list (struct posn (x y))) (list (make-posn 1 2)) (+ x y))
|
||||
(htdp-match/v 3 (vector (struct posn (x y))) (vector (make-posn 1 2)) (+ x y))
|
||||
(htdp-match/v 3 (box (struct posn (x y))) (box (make-posn 1 2)) (+ x y))
|
||||
|
||||
(htdp-match/v 3 `,(struct posn (x y)) (make-posn 1 2) (+ x y))
|
||||
(htdp-match/v 1 `(a ,b) (list 'a 1) b)
|
||||
(htdp-match/v 1 `(a ,@(list b)) (list 'a 1) b)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -397,10 +397,3 @@
|
|||
(htdp-err/rt-test (error "several numbers " 1 " 2 " 3 " 4")
|
||||
#rx"^several numbers 1 2 3 4$")
|
||||
|
||||
(htdp-top (require scheme/match))
|
||||
(htdp-test 17 'match (match 'x ['x 17]))
|
||||
(htdp-test 'x 'match (match 'x ['y 17][z z]))
|
||||
(htdp-test 2 'match (match (list 1 2 3) [(cons a (cons b c)) b]))
|
||||
(htdp-test 3 'match (match (list 1 2 3) [(list a b c) c]))
|
||||
(htdp-test (list 2 3) 'match (match (list 1 2 3) [(cons a c) c]))
|
||||
(htdp-top-pop 1)
|
||||
|
|
|
|||
|
|
@ -30,13 +30,3 @@
|
|||
(htdp-syntax-test #'((unquote-splicing (list 10))))
|
||||
|
||||
(htdp-err/rt-test `(,@4))
|
||||
|
||||
(htdp-top (require scheme/match))
|
||||
(htdp-test 17 'match (match 'x [`x 17]))
|
||||
(htdp-test 'x 'match (match 'x [`y 17][z z]))
|
||||
(htdp-test 2 'match (match (list 1 2 3) [`(,a ,b 3) b]))
|
||||
(htdp-test 'no 'match (match (list 1 2 3) [`(,a ,b 4) b] [z 'no]))
|
||||
(htdp-test 2 'match (match (list 1 2 3) [`(,a ,b ,c) b]))
|
||||
(htdp-test 2 'match (match (list 1 2 3) [`(,a ,@`(,b ,@`(,c))) b]))
|
||||
(htdp-test (list 2 3) 'match (match (list 1 2 3) [`(,a ,b ...) b]))
|
||||
(htdp-top-pop 1)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user