320 lines
11 KiB
Scheme
320 lines
11 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Pattern Matching Syntactic Extensions for Scheme
|
|
;;
|
|
;; Specialized for MzScheme; works with define-struct
|
|
;;
|
|
;; Report bugs to wright@research.nj.nec.com. The most recent version of
|
|
;; this software can be obtained by anonymous FTP from ftp.nj.nec.com
|
|
;; in file pub/wright/match.tar.Z. Be sure to set "type binary" when
|
|
;; transferring this file.
|
|
;;
|
|
;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
|
|
;; Adapted from code originally written by Bruce F. Duba, 1991.
|
|
;;
|
|
;; This software is in the public domain. Feel free to copy,
|
|
;; distribute, and modify this software as desired. No warranties
|
|
;; nor guarantees of any kind apply. Please return any improvements
|
|
;; or bug fixes to wright@research.nj.nec.com so that they may be included
|
|
;; in future releases.
|
|
;;
|
|
;; This macro package extends Scheme with several new expression forms.
|
|
;; Following is a brief summary of the new forms. See the associated
|
|
;; LaTeX documentation for a full description of their functionality.
|
|
;;
|
|
;;
|
|
;; match expressions:
|
|
;;
|
|
;; exp ::= ...
|
|
;; | (match exp clause ...)
|
|
;; | (match-lambda clause ...)
|
|
;; | (match-lambda* clause ...)
|
|
;; | (match-let ((pat exp) ...) body)
|
|
;; | (match-let* ((pat exp) ...) body)
|
|
;; | (match-letrec ((pat exp) ...) body)
|
|
;; | (match-define pat exp)
|
|
;;
|
|
;; clause ::= (pat body) | (pat => exp)
|
|
;;
|
|
;; patterns: matches:
|
|
;;
|
|
;; pat ::= identifier anything, and binds identifier
|
|
;; | _ anything
|
|
;; | () the empty list
|
|
;; | #t #t
|
|
;; | #f #f
|
|
;; | string a string
|
|
;; | number a number
|
|
;; | character a character
|
|
;; | 'sexp an s-expression
|
|
;; | 'symbol a symbol (special case of s-expr)
|
|
;; | (pat_1 ... pat_n) list of n elements
|
|
;; | (pat_1 ... pat_n . pat_{n+1}) list of n or more
|
|
;; | (pat_1 ... pat_n pat_n+1 ooo) list of n or more, each element
|
|
;; of remainder must match pat_n+1
|
|
;; | #(pat_1 ... pat_n) vector of n elements
|
|
;; | #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each element
|
|
;; of remainder must match pat_n+1
|
|
;; | #&pat box
|
|
;; | ($ struct-name pat_1 ... pat_n) a structure
|
|
;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
|
|
;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
|
|
;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
|
|
;; | (? predicate pat_1 ... pat_n) if predicate true and all of
|
|
;; pat_1 thru pat_n match
|
|
;; | (set! identifier) anything, and binds setter
|
|
;; | (get! identifier) anything, and binds getter
|
|
;; | `qp a quasi-pattern
|
|
;;
|
|
;; ooo ::= ... zero or more
|
|
;; | ___ zero or more
|
|
;; | ..k k or more
|
|
;; | __k k or more
|
|
;;
|
|
;; quasi-patterns: matches:
|
|
;;
|
|
;; qp ::= () the empty list
|
|
;; | #t #t
|
|
;; | #f #f
|
|
;; | string a string
|
|
;; | number a number
|
|
;; | character a character
|
|
;; | identifier a symbol
|
|
;; | (qp_1 ... qp_n) list of n elements
|
|
;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
|
|
;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
|
|
;; of remainder must match qp_n+1
|
|
;; | #(qp_1 ... qp_n) vector of n elements
|
|
;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
|
|
;; of remainder must match qp_n+1
|
|
;; | #&qp box
|
|
;; | ,pat a pattern
|
|
;; | ,@pat a pattern
|
|
;;
|
|
;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
|
|
;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
|
|
;;
|
|
;; End of user visible/modifiable stuff.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(module mymatch mzscheme
|
|
(require-for-syntax "private/mkmatch.ss"
|
|
(lib "stx.ss" "syntax")
|
|
(lib "struct.ss" "syntax"))
|
|
|
|
(provide
|
|
match-fail
|
|
match
|
|
match-lambda
|
|
match-lambda*
|
|
match-letrec
|
|
match-let
|
|
match-let*
|
|
match-define)
|
|
|
|
(define match:version "Version 1.10mz, Feb 5, 1996")
|
|
|
|
(define-struct (exn:misc:match exn) (value))
|
|
|
|
(define match-fail (gensym 'match-fail))
|
|
|
|
(define match:error
|
|
(case-lambda
|
|
((val) match-fail)
|
|
; (raise
|
|
; (make-exn:misc:match
|
|
; (format "match: no matching clause for ~e" val)
|
|
; (current-continuation-marks)
|
|
; val)))
|
|
((val expr) match-fail)))
|
|
; (raise
|
|
; (make-exn:misc:match
|
|
; (format "match: no matching clause for ~e: ~s" val expr)
|
|
; (current-continuation-marks)
|
|
; val)))))
|
|
|
|
(define-syntax parse-pattern
|
|
;; NOT A MACRO: this is a macro utility function
|
|
(lambda (p)
|
|
(let parse-pattern ([p p])
|
|
(define (r l) (map parse-pattern (syntax->list l)))
|
|
(define (i v) (match:syntax-err p (format "illegal use of ~a" v)))
|
|
(syntax-case* p (_ quote $ ? and or not set! get! quasiquote ... ___) module-or-top-identifier=?
|
|
[_ '_]
|
|
[(quote x) `(quote ,(syntax-object->datum (syntax x)))]
|
|
[(quote . _) (i "quote")]
|
|
[($ struct 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 "$")]
|
|
[(and p ...)
|
|
`(and ,@(r (syntax (p ...))))]
|
|
[(and . _) (i "and")]
|
|
[(or p ...)
|
|
`(or ,@(r (syntax (p ...))))]
|
|
[(or . _) (i "or")]
|
|
[(not p ...)
|
|
`(not ,@(r (syntax (p ...))))]
|
|
[(not . _) (i "not")]
|
|
[(? pred p ...)
|
|
`(? ,(syntax pred) ,@(r (syntax (p ...))))]
|
|
[(? . _) (i "?")]
|
|
[(set! i)
|
|
`(set! ,(syntax i))]
|
|
[(set! . _) (i "set!")]
|
|
[(get! i)
|
|
`(get! ,(syntax i))]
|
|
[(get! . _) (i "get!")]
|
|
[(quasiquote q)
|
|
`(,'quasiquote ,(:ucall parse-quasipattern (syntax q)))]
|
|
[(quasiquote . _) (i "quasiquote")]
|
|
[(p (... ...))
|
|
`(,(parse-pattern (syntax p)) ...)]
|
|
[(p ___)
|
|
`(,(parse-pattern (syntax p)) ___)]
|
|
[(p ..k)
|
|
(and (identifier? (syntax ..k))
|
|
(let ([s (symbol->string (syntax-e (syntax ..k)))])
|
|
(regexp-match re:..k s)))
|
|
`(,(parse-pattern (syntax p)) ,(syntax-e (syntax ..k)))]
|
|
[(p . rest)
|
|
(identifier? (syntax i))
|
|
(cons (parse-pattern (syntax p)) (parse-pattern (syntax rest)))]
|
|
[i (identifier? (syntax i)) (syntax i)]
|
|
[_else
|
|
(let ([s (syntax-e p)])
|
|
(cond
|
|
[(vector? s) (list->vector (map parse-pattern (vector->list s)))]
|
|
[(box? s) (box (parse-pattern (unbox s)))]
|
|
[else s]))]))))
|
|
|
|
(define-syntax parse-quasipattern
|
|
;; NOT A MACRO: this is a macro utility function
|
|
(lambda (p)
|
|
(define (i v) (match:syntax-err p (format "illegal use of ~a" v)))
|
|
(let parse-quasipattern ([p p])
|
|
(syntax-case p (unquote unquote-splicing ...)
|
|
[(unquote x) `(,'unquote ,(:ucall parse-pattern (syntax x)))]
|
|
[(unquote . _) (i "unquote")]
|
|
[(unquote-splicing x) `(,'unquote-splicing ,(:ucall parse-pattern (syntax x)))]
|
|
[(unquote-splicing . _) (i "unquote-splicing")]
|
|
[(p (... ...))
|
|
`(,(parse-quasipattern (syntax p)) ...)]
|
|
[(p ..k)
|
|
(and (identifier? (syntax ..k))
|
|
(let ([s (symbol->string (syntax-e (syntax ..k)))])
|
|
(regexp-match re:..k s)))
|
|
`(,(parse-quasipattern (syntax p)) ,(syntax-e (syntax ..k)))]
|
|
[(i . rest)
|
|
(identifier? (syntax i))
|
|
(cons (syntax-object->datum (syntax i)) (parse-quasipattern (syntax rest)))]
|
|
[(qp . rest)
|
|
(cons (parse-quasipattern (syntax qp)) (parse-quasipattern (syntax rest)))]
|
|
[_else
|
|
(let ([s (syntax-e p)])
|
|
(cond
|
|
[(vector? s) (list->vector (map parse-quasipattern (vector->list s)))]
|
|
[(box? s) (box (parse-quasipattern (unbox s)))]
|
|
[else s]))]))))
|
|
|
|
|
|
|
|
|
|
|
|
(define-syntax match
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ exp clause ...)
|
|
(with-syntax ([body
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(genmatch
|
|
(quote-syntax mv)
|
|
(map
|
|
(lambda (c)
|
|
(syntax-case c (=>)
|
|
[(p (=> i) e e1 ...)
|
|
`(,(:ucall parse-pattern (syntax p))
|
|
(=> ,(syntax i))
|
|
,@(syntax->list (syntax (e e1 ...))))]
|
|
[(p e e1 ...)
|
|
`(,(:ucall parse-pattern (syntax p))
|
|
,@(syntax->list (syntax (e e1 ...))))]
|
|
[_else
|
|
(match:syntax-err
|
|
c
|
|
"bad match clause")]))
|
|
(syntax->list (syntax (clause ...))))
|
|
stx)
|
|
stx)])
|
|
(syntax/loc stx
|
|
(let ([mv exp])
|
|
body)))])))
|
|
|
|
(define-syntax match-lambda
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ clause ...)
|
|
(syntax/loc stx (lambda (x) (match x clause ...)))])))
|
|
|
|
(define-syntax match-lambda*
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ clause ...)
|
|
(syntax/loc stx (lambda x (match x clause ...)))])))
|
|
|
|
(define-syntax match-let*
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ () body1 body ...)
|
|
(syntax/loc stx (begin body1 body ...))]
|
|
[(_ ([pat1 exp1] [pat exp] ...) body1 body ...)
|
|
(syntax/loc stx (match exp1
|
|
[pat1 (match-let* ([pat exp] ...)
|
|
body1 body ...)]))])))
|
|
(define-syntax match-let
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ ([pat exp] ...) body1 body ...)
|
|
(syntax/loc stx (match-let* ([(pat ...) (list exp ...)])
|
|
body1 body ...))])))
|
|
|
|
(define-syntax match-letrec
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ ([pat exp] ...) body1 body ...)
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(genletrec
|
|
(map (lambda (p) (:ucall parse-pattern p)) (syntax->list (syntax (pat ...))))
|
|
(syntax->list (syntax (exp ...)))
|
|
(syntax->list (syntax (body1 body ...)))
|
|
stx)
|
|
stx)])))
|
|
|
|
(define-syntax match-define
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ pat exp)
|
|
(datum->syntax-object
|
|
(quote-syntax here)
|
|
(gendefine (:ucall parse-pattern (syntax pat))
|
|
(syntax exp)
|
|
stx)
|
|
stx)]))))
|