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

checkpoint

Browse Source 
svn: r17258
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-10 15:32:17 +00:00
parent 8ef5ad42c4
commit 5767e23d87
2 changed files with 31 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scheme/match/define-forms.ss
View File

@ -12,12 +12,15 @@
(provide define-forms) (provide define-forms)
(define-syntax-rule (define-forms parse-id (define-syntax-rule (define-forms parse-id
match match* match-lambda match-lambda* match-lambda** match-let match match* match-lambda match-lambda*
match-let* match-define match-letrec match/derived match*/derived) match-lambda** match-let match-let*
match-define match-letrec
match/derived match*/derived)
(... (...
(begin (begin
(provide match match* match-lambda match-lambda* match-lambda** match-let match-let* (provide match match* match-lambda match-lambda* match-lambda**
match-define match-letrec match/derived match*/derived) match-let match-let* match-define match-letrec
match/derived match*/derived)
(define-syntax (match* stx) (define-syntax (match* stx)
(syntax-parse stx (syntax-parse stx
[(_ es . clauses) [(_ es . clauses)
@ -66,11 +69,13 @@
[(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...) [(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
(with-syntax* (with-syntax*
([vars (generate-temporaries #'(pat ...))] ([vars (generate-temporaries #'(pat ...))]
[loop-body #`(match*/derived vars #,stx [(pat ...) (let () body1 body ...)])]) [loop-body #`(match*/derived vars #,stx
[(pat ...) (let () body1 body ...)])])
#'(letrec ([nm (lambda vars loop-body)]) #'(letrec ([nm (lambda vars loop-body)])
(nm init-exp ...)))] (nm init-exp ...)))]
[(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...) [(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
#`(match*/derived (init-exp ...) #,stx [(pat ...) (let () body1 body ...)])])) #`(match*/derived (init-exp ...) #,stx
[(pat ...) (let () body1 body ...)])]))
(define-syntax (match-let* stx) (define-syntax (match-let* stx)
(syntax-parse stx (syntax-parse stx
@ -80,7 +85,8 @@
#`(match*/derived #`(match*/derived
(exp) (exp)
#,stx #,stx
[(pat) #,(syntax/loc stx (match-let* (rest-pats ...) body1 body ...))])])) [(pat) #,(syntax/loc stx (match-let* (rest-pats ...)
body1 body ...))])]))
(define-syntax (match-letrec stx) (define-syntax (match-letrec stx)
(syntax-parse stx (syntax-parse stx
@ -100,4 +106,5 @@
(let ([p (parse-id #'pat (syntax-local-certifier))]) (let ([p (parse-id #'pat (syntax-local-certifier))])
(with-syntax ([vars (bound-vars p)]) (with-syntax ([vars (bound-vars p)])
(quasisyntax/loc stx (quasisyntax/loc stx
(define-values vars (match*/derived (rhs) #,stx [(pat) (values . vars)])))))]))))) (define-values vars (match*/derived (rhs) #,stx
[(pat) (values . vars)])))))])))))

16
collects/tests/typed-scheme/succeed/logic.ss Normal file
View File

@ -0,0 +1,16 @@
#lang typed-scheme
(: f ((U Number #f) (cons Any Any) -> Number))
(define (f x y)
(cond
[(and (number? x) (number? (car y))) (+ x (car y))]
[(number? (car y)) (+ (bool-to-0-or-1 x) (car y))]
[(number? x) x]
[else 0]))
(: bool-to-0-or-1 (Boolean -> Number))
(define (bool-to-0-or-1 b)
(if b 1 0))