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

.

Browse Source 
original commit: 9826922bf9d4669b93a7bf9cc0798a590f61c385
This commit is contained in:
Matthew Flatt 2001-09-14 23:11:03 +00:00
parent 9d63ffdfd0
commit 20ec5d40ea
1 changed files with 33 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/mzlib/match.ss
View File

@ -97,7 +97,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module match mzscheme (module match mzscheme
(require-for-syntax "private/mkmatch.ss") (require-for-syntax "private/mkmatch.ss"
(lib "stx.ss" "syntax")
(lib "struct.ss" "syntax"))
(provide (provide
match match
@ -132,12 +134,29 @@
(let parse-pattern ([p p]) (let parse-pattern ([p p])
(define (r l) (map parse-pattern (syntax->list l))) (define (r l) (map parse-pattern (syntax->list l)))
(define (i v) (match:syntax-err p (format "illegal use of ~a" v))) (define (i v) (match:syntax-err p (format "illegal use of ~a" v)))
(syntax-case p (_ quote $ ? and or not set! get! quasiquote ... ___) (syntax-case* p (_ quote $ ? and or not set! get! quasiquote ... ___) module-or-top-identifier=?
[_ '_] [_ '_]
[(quote x) `(quote ,(syntax-object->datum (syntax x)))] [(quote x) `(quote ,(syntax-object->datum (syntax x)))]
[(quote . _) (i "quote")] [(quote . _) (i "quote")]
[($ struct p ...) [($ struct p ...)
`($ struct ,@(r (syntax (p ...))))] (let ([name (syntax struct)])
(unless (identifier? name)
(i "$; not followed by an identifier"))
(let ([info (syntax-local-value name (lambda () #f))])
(unless (struct-declaration-info? info)
(i (format "$; `~a' is not the name of a structure type"
(syntax-e name))))
(let ([pred (caddr info)]
[sel (reverse
(let loop ([l (list-ref info 3)])
(if (or (null? l) (not (car l)))
null
(cons (car l) (loop (cdr l))))))])
(unless (= (length sel)
(length (syntax->list (syntax (p ...)))))
(i (format "$; wrong number of fields for `~a'"
(syntax-e name))))
`($ ,(cons pred sel) ,@(r (syntax (p ...)))))))]
[($ . _) (i "$")] [($ . _) (i "$")]
[(and p ...) [(and p ...)
`(and ,@(r (syntax (p ...))))] `(and ,@(r (syntax (p ...))))]
@ -239,37 +258,37 @@
(syntax->list (syntax (clause ...)))) (syntax->list (syntax (clause ...))))
stx) stx)
stx)]) stx)])
(syntax (syntax/loc stx
(let ([mv exp]) (let ([mv exp])
body)))]))) body)))])))
(define-syntax match-lambda (define-syntax match-lambda
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ clause ...) [(_ clause ...)
(syntax (lambda (x) (match x clause ...)))]))) (syntax/loc stx (lambda (x) (match x clause ...)))])))
(define-syntax match-lambda* (define-syntax match-lambda*
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ clause ...) [(_ clause ...)
(syntax (lambda x (match x clause ...)))]))) (syntax/loc stx (lambda x (match x clause ...)))])))
(define-syntax match-let* (define-syntax match-let*
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ () body1 body ...) [(_ () body1 body ...)
(syntax (begin body1 body ...))] (syntax/loc stx (begin body1 body ...))]
[(_ ([pat1 exp1] [pat exp] ...) body1 body ...) [(_ ([pat1 exp1] [pat exp] ...) body1 body ...)
(syntax (match exp1 (syntax/loc stx (match exp1
[pat1 (match-let* ([pat exp] ...) [pat1 (match-let* ([pat exp] ...)
body1 body ...)]))]))) body1 body ...)]))])))
(define-syntax match-let (define-syntax match-let
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([pat exp] ...) body1 body ...) [(_ ([pat exp] ...) body1 body ...)
(syntax (match-let* ([(pat ...) (list exp ...)]) (syntax/loc stx (match-let* ([(pat ...) (list exp ...)])
body1 body ...))]))) body1 body ...))])))
(define-syntax match-letrec (define-syntax match-letrec
(lambda (stx) (lambda (stx)