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

reformatting

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-01 16:52:45 -04:00
parent dd4c63ab07
commit 9e17a6d993
1 changed files with 50 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
collects/mzlib/private/match/match-internal-func.ss
View File

@ -1,16 +1,16 @@
(module match-internal-func mzscheme (module match-internal-func mzscheme
(provide (all-defined)) (provide (all-defined))
(require-for-syntax "gen-match.ss" (require-for-syntax "gen-match.ss"
"match-helper.ss" "match-helper.ss"
"match-error.ss") "match-error.ss")
(require (lib "etc.ss") (require (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
"match-expander.ss" "match-expander.ss"
"match-error.ss") "match-error.ss")
(define-syntax (match stx) (define-syntax (match stx)
(syntax-case stx () (syntax-case stx ()
@ -22,7 +22,7 @@
(syntax-case stx () (syntax-case stx ()
[(k . clauses) [(k . clauses)
#'(lambda (exp) (match exp . clauses))])) #'(lambda (exp) (match exp . clauses))]))
(define-syntax (match-lambda* stx) (define-syntax (match-lambda* stx)
(syntax-case stx () (syntax-case stx ()
[(k . clauses) [(k . clauses)
@ -65,57 +65,57 @@
((_ ([pat exp] rest ...) body ...) ((_ ([pat exp] rest ...) body ...)
(if (pattern-var? (syntax pat)) (if (pattern-var? (syntax pat))
#'(let ([pat exp]) #'(let ([pat exp])
(match-let* (rest ...) body ...)) (match-let* (rest ...) body ...))
#'(match exp [pat (match-let* (rest ...) body ...)])) #'(match exp [pat (match-let* (rest ...) body ...)]))
))) )))
(define-syntax (match-letrec stx) (define-syntax (match-letrec stx)
(syntax-case stx () (syntax-case stx ()
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
[(_ ([pat exp] ...) . body) [(_ ([pat exp] ...) . body)
(andmap pattern-var? (andmap pattern-var?
(syntax->list #'(pat ...))) (syntax->list #'(pat ...)))
#'(letrec ([pat exp] ...) . body)] #'(letrec ([pat exp] ...) . body)]
[(_ ([pat exp] ...) . body) [(_ ([pat exp] ...) . body)
(let* ((**match-bound-vars** '()) (let* ((**match-bound-vars** '())
(compiled-match (compiled-match
(gen-match #'the-exp (gen-match #'the-exp
'() '()
#'(((list pat ...) never-used)) #'(((list pat ...) never-used))
stx stx
(lambda (sf bv) (lambda (sf bv)
(set! **match-bound-vars** bv) (set! **match-bound-vars** bv)
#`(begin #`(begin
#,@(map (lambda (x) #`(set! #,(car x) #,(cdr x))) #,@(map (lambda (x) #`(set! #,(car x) #,(cdr x)))
(reverse bv)) (reverse bv))
. body ))))) . body )))))
#`(letrec (#,@(map #`(letrec (#,@(map
(lambda (x) #`(#,(car x) #f)) (lambda (x) #`(#,(car x) #f))
(reverse **match-bound-vars**)) (reverse **match-bound-vars**))
(the-exp (list exp ...))) (the-exp (list exp ...)))
#,compiled-match))])) #,compiled-match))]))
(define-syntax (match-define stx) (define-syntax (match-define stx)
(syntax-case stx () (syntax-case stx ()
[(_ pat exp) [(_ pat exp)
(identifier? #'pat) (identifier? #'pat)
#'(define pat exp)] #'(define pat exp)]
[(_ pat exp) [(_ pat exp)
(let* ((**match-bound-vars** '()) (let* ([**match-bound-vars** '()]
(compiled-match [compiled-match
(gen-match #'the-exp (gen-match #'the-exp
'() '()
#'((pat never-used)) #'((pat never-used))
stx stx
(lambda (sf bv) (lambda (sf bv)
(set! **match-bound-vars** bv) (set! **match-bound-vars** bv)
#`(begin #`(begin
#,@(map (lambda (x) #,@(map (lambda (x)
#`(set! #,(car x) #,(cdr x))) #`(set! #,(car x) #,(cdr x)))
(reverse bv))))))) (reverse bv)))))])
#`(begin #,@(map #`(begin #,@(map
(lambda (x) #`(define #,(car x) #f)) (lambda (x) #`(define #,(car x) #f))
(reverse **match-bound-vars**)) (reverse **match-bound-vars**))
(let ((the-exp exp)) (let ((the-exp exp))
#,compiled-match)))])) #,compiled-match)))]))
) )