revamped implementation of match, from samth@ccs.neu.edu, including match-equality-test and define-match-expander
original commit: 4c27dde572305c616cdefec94974595209d79e8a
This commit is contained in:
Sam Tobin-Hochstadt
parent
6752e1667a
commit
fe33280d30
|
|
@ -124,460 +124,74 @@
|
|||
match-let
|
||||
match-let*
|
||||
match-letrec
|
||||
match-define
|
||||
match-test
|
||||
match-define
|
||||
match-equality-test
|
||||
exn:misc:match?
|
||||
exn:misc:match-value)
|
||||
|
||||
(require-for-syntax (lib "stx.ss" "syntax")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "include.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "struct.ss" "syntax"))
|
||||
|
||||
(require (lib "etc.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
(define-struct (exn:misc:match exn:fail) (value))
|
||||
|
||||
(define match:error
|
||||
(case-lambda
|
||||
((val)
|
||||
(raise
|
||||
(make-exn:misc:match
|
||||
(string->immutable-string (format "match: no matching clause for ~e" val))
|
||||
(current-continuation-marks)
|
||||
val)))
|
||||
((val expr)
|
||||
(raise
|
||||
(make-exn:misc:match
|
||||
(string->immutable-string (format "match: no matching clause for ~e: ~s" val expr))
|
||||
(current-continuation-marks)
|
||||
val)))))
|
||||
|
||||
(define-syntax-set (match
|
||||
match-lambda
|
||||
match-lambda*
|
||||
match-let
|
||||
match-let*
|
||||
match-letrec
|
||||
match-define
|
||||
match-test
|
||||
m:match-test)
|
||||
|
||||
(include (build-path "private" "plt-match" "match-inc.scm"))
|
||||
|
||||
(define node-count 0)
|
||||
|
||||
(define (match-func-plt stx stx-orig)
|
||||
(syntax-case stx (=>)
|
||||
((_ exp clause ...)
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(let ((x exp))
|
||||
#,(gen-match (syntax x)
|
||||
'()
|
||||
(syntax (clause ...))
|
||||
stx-orig))))))
|
||||
|
||||
(define match-lambda-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(lambda (exp) #,(match-func
|
||||
(syntax/loc stx (match exp clause ...))
|
||||
stx-orig)))])))
|
||||
|
||||
(define match-lambda*-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(lambda exp #,(match-func
|
||||
(syntax/loc stx (match exp clause ...))
|
||||
stx-orig)))])))
|
||||
|
||||
(define match-let-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(_ name () body1 body ...)
|
||||
(syntax/loc stx-orig (let name () body1 body ...))]
|
||||
[(_ name ([pat1 exp1] [pat exp]...) body1 body ...)
|
||||
(identifier? (syntax name))
|
||||
(let ((pat-list (syntax-object->datum (syntax (pat1 pat ...))))
|
||||
(real-name (syntax-object->datum (syntax name))))
|
||||
(if (andmap pattern-var? pat-list)
|
||||
(syntax/loc
|
||||
stx-orig
|
||||
(let name ([pat1 exp1] [pat exp] ...) body1 body ...))
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(letrec ([name
|
||||
#,(match-lambda*-func (syntax/loc stx-orig (match-lambda* ((pat1 pat ...) body1 body ...)))
|
||||
stx-orig)
|
||||
])
|
||||
(name exp1 exp ...)))))]
|
||||
[(_ () body1 body ...)
|
||||
(syntax/loc stx-orig (begin body1 body...))]
|
||||
[(_ ([pat1 exp1] [pat exp]...) body1 body ...)
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
( #,(match-lambda*-func (syntax/loc stx-orig (match-lambda* ((pat1 pat ...) body1 body ...)))
|
||||
stx-orig)
|
||||
exp1 exp ...))])))
|
||||
|
||||
(define match-let*-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax/loc stx-orig (let* () body body1 ...)))
|
||||
((_ ([pat exp] rest ...) body body1 ...)
|
||||
(if (pattern-var? (syntax-object->datum (syntax pat)))
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(let ([pat exp])
|
||||
#,(match-let*-func (syntax/loc stx-orig (match-let* (rest ...) body body1 ...)) stx-orig)
|
||||
)
|
||||
)
|
||||
(match-func
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(match exp [pat #,(match-let*-func
|
||||
(syntax/loc stx-orig (match-let* (rest ...) body body1 ...))
|
||||
stx-orig)]))
|
||||
stx-orig))))))
|
||||
|
||||
(define match-letrec-func-plt
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax/loc stx (let () body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(andmap pattern-var?
|
||||
(syntax-object->datum (syntax (pat ...))))
|
||||
(syntax/loc stx (letrec ([pat exp] ...) body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(let* ((**match-bound-vars** '())
|
||||
(compiled-match
|
||||
(gen-match (syntax the-exp);(syntax (list exp ...))
|
||||
'()
|
||||
(syntax (((list pat ...) never-used)))
|
||||
stx-orig
|
||||
(lambda (sf bv)
|
||||
(set! **match-bound-vars** bv)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(begin
|
||||
#,@(map (lambda (x)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(set! #,(car x) #,(cdr x))))
|
||||
(reverse bv))
|
||||
body body1 ...))))))
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(letrec (#,@(map
|
||||
(lambda (x) (quasisyntax/loc stx (#,(car x) #f)))
|
||||
(reverse **match-bound-vars**))
|
||||
(the-exp (list exp ...)))
|
||||
#,compiled-match)))))))
|
||||
|
||||
(define match-define-func-plt
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(_ pat exp)
|
||||
(identifier? (syntax pat))
|
||||
(syntax/loc stx-orig (begin (define pat exp)))]
|
||||
[(_ pat exp)
|
||||
(let* ((**match-bound-vars** '())
|
||||
(compiled-match
|
||||
(gen-match (syntax the-exp)
|
||||
'()
|
||||
(syntax/loc (syntax pat) ((pat never-used)))
|
||||
stx-orig
|
||||
(lambda (sf bv)
|
||||
(set! **match-bound-vars** bv)
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(begin
|
||||
#,@(map (lambda (x)
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(set! #,(car x) #,(cdr x))))
|
||||
(reverse bv))))))))
|
||||
(quasisyntax/loc stx-orig
|
||||
(begin #,@(map
|
||||
(lambda (x) (quasisyntax/loc
|
||||
stx
|
||||
(define #,(car x) #f)))
|
||||
(reverse **match-bound-vars**))
|
||||
(let ((the-exp exp))
|
||||
#,compiled-match))))])))
|
||||
|
||||
;; these are the translators
|
||||
(define m:match-test/proc
|
||||
(lambda (stx)
|
||||
(syntax-case stx (=>)
|
||||
((_ clause ...)
|
||||
(begin
|
||||
(set! node-count 0)
|
||||
(let-values (((stx t rt gc) (time-apply gen-match
|
||||
(list (syntax x)
|
||||
'()
|
||||
(syntax (clause ...))
|
||||
stx))))
|
||||
#`(list ; (let ((dat-struct (seconds->date (current-seconds))))
|
||||
; (list (date-month dat-struct)
|
||||
; (date-day dat-struct)
|
||||
; (date-year dat-struct)));
|
||||
; (list #,@(get-date))
|
||||
#,node-count
|
||||
#,rt)))))))
|
||||
|
||||
(define match-test/proc
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ clause ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(m:match-test
|
||||
#,@(map handle-clause
|
||||
(syntax-e (syntax (clause ...))))))))))
|
||||
|
||||
(define match/proc
|
||||
(lambda (stx)
|
||||
(match-func stx stx)))
|
||||
|
||||
(define match-lambda/proc
|
||||
(lambda (stx)
|
||||
(match-lambda-func stx stx)))
|
||||
|
||||
(define match-lambda*/proc
|
||||
(lambda (stx)
|
||||
(match-lambda*-func stx stx)))
|
||||
|
||||
(define match-let/proc
|
||||
(lambda (stx)
|
||||
(match-let-func stx stx)))
|
||||
|
||||
(define match-let*/proc
|
||||
(lambda (stx)
|
||||
(match-let*-func stx stx)))
|
||||
|
||||
(define match-letrec/proc
|
||||
(lambda (stx)
|
||||
(match-letrec-func stx stx)))
|
||||
|
||||
(define match-define/proc
|
||||
(lambda (stx)
|
||||
(match-define-func stx stx)))
|
||||
|
||||
(define match-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
((_ exp clause ...)
|
||||
(match-func-plt
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(match exp
|
||||
#,@(map handle-clause
|
||||
(syntax-e (syntax (clause ...))))))
|
||||
stx-orig)))))
|
||||
|
||||
(define match-letrec-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax/loc stx (let () body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(andmap pattern-var?
|
||||
(syntax-object->datum (syntax (pat ...))))
|
||||
(syntax/loc stx (letrec ([pat exp] ...) body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(match-letrec-func-plt
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(match-letrec #,(map
|
||||
handle-let-clause
|
||||
(syntax->list (syntax ([pat exp] ...))))
|
||||
body body1 ...))
|
||||
stx-orig)))))
|
||||
|
||||
|
||||
(define match-define-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(_ pat exp)
|
||||
(identifier? (syntax pat))
|
||||
(syntax/loc stx (begin (define pat exp)))]
|
||||
[(_ pat exp)
|
||||
(match-define-func-plt
|
||||
(quasisyntax/loc
|
||||
stx-orig
|
||||
(match-define #,(convert-pat (syntax pat)) exp))
|
||||
stx-orig)])))
|
||||
|
||||
|
||||
|
||||
;; these functions convert the patterns from the old syntax
|
||||
;; to the new syntax
|
||||
(define (handle-let-clause stx)
|
||||
(syntax-case stx ()
|
||||
((pat exp)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(#,(convert-pat (syntax pat)) exp)))))
|
||||
|
||||
(define handle-clause
|
||||
(lambda (stx)
|
||||
(syntax-case stx (=>)
|
||||
((pat (=> id) expr ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(#,(convert-pat (syntax pat)) (=> id) expr ...)))
|
||||
((pat expr ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(#,(convert-pat (syntax pat)) expr ...))))))
|
||||
|
||||
|
||||
(define (convert-pat stx)
|
||||
(define (imp-list? x)
|
||||
(define (keyword? x)
|
||||
(member (syntax-object->datum x)
|
||||
'(
|
||||
quote
|
||||
quasiquote
|
||||
?
|
||||
=
|
||||
and
|
||||
or
|
||||
not
|
||||
$
|
||||
set!
|
||||
get!
|
||||
;unquote
|
||||
;unquote-splicing
|
||||
)))
|
||||
(let/ec out
|
||||
(let loop ((x x))
|
||||
(cond ((null? x) (out #f))
|
||||
((or (not (pair? x))
|
||||
(and (list? x)
|
||||
(keyword? (car x))))
|
||||
(list
|
||||
(quasisyntax/loc stx #,x)))
|
||||
(else (cons (car x) (loop (cdr x))))))))
|
||||
(define stx-equal?
|
||||
(lambda (a b)
|
||||
(equal? (syntax-object->datum a)
|
||||
(syntax-object->datum b))))
|
||||
(define (convert-quasi stx)
|
||||
(syntax-case stx (unquote quasiquote unquote-splicing)
|
||||
(,pat
|
||||
(quasisyntax/loc stx ,#,(convert-pat (syntax pat))))
|
||||
(,@pat
|
||||
(quasisyntax/loc stx ,@#,(convert-pat (syntax pat))))
|
||||
((x . y)
|
||||
(quasisyntax/loc
|
||||
stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y)))))
|
||||
(pat
|
||||
(vector? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
#,(list->vector (map convert-quasi
|
||||
(vector->list (syntax-e stx))))))
|
||||
(pat
|
||||
(box? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx #,(box (convert-quasi (unbox (syntax-e stx))))))
|
||||
(pat stx)))
|
||||
;(write (syntax-object->datum stx))(newline)
|
||||
(syntax-case*
|
||||
stx
|
||||
(_ ? = and or not $ set! get! quasiquote
|
||||
quote unquote unquote-splicing) stx-equal?
|
||||
(p
|
||||
(dot-dot-k? (syntax-object->datum (syntax p)))
|
||||
stx)
|
||||
(_ stx)
|
||||
(() (quasisyntax/loc stx (list)))
|
||||
('() (quasisyntax/loc stx (list)))
|
||||
('item stx)
|
||||
(p
|
||||
(let ((old-pat (syntax-object->datum stx)))
|
||||
(or (string? old-pat)
|
||||
(boolean? old-pat)
|
||||
(char? old-pat)
|
||||
(number? old-pat)))
|
||||
stx)
|
||||
((? pred)
|
||||
stx)
|
||||
((? pred a ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(? pred #,@(map convert-pat
|
||||
(syntax-e (syntax (a ...)))))))
|
||||
(`pat
|
||||
(quasisyntax/loc stx `#,(convert-quasi (syntax pat))))
|
||||
((= op pat)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(app op #,(convert-pat (syntax pat)))))
|
||||
((and pats ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(and #,@(map convert-pat
|
||||
(syntax-e (syntax (pats ...)))))))
|
||||
((or pats ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(or #,@(map convert-pat
|
||||
(syntax-e (syntax (pats ...)))))))
|
||||
((not pat)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(not #,(convert-pat (syntax pat)))))
|
||||
(($ struct-name fields ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(struct struct-name
|
||||
#,(map convert-pat
|
||||
(syntax-e (syntax (fields ...)))))))
|
||||
((get! id)
|
||||
stx)
|
||||
((set! id)
|
||||
stx)
|
||||
((quote p) stx)
|
||||
((car-pat . cdr-pat)
|
||||
(let ((l (imp-list? (syntax-e stx))))
|
||||
(if l
|
||||
(quasisyntax/loc
|
||||
stx (list-rest #,@(map convert-pat l)))
|
||||
(quasisyntax/loc
|
||||
stx (list #,@(map convert-pat (syntax-e stx)))))))
|
||||
(pt
|
||||
(vector? (syntax-object->datum stx))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(vector #,@(map convert-pat
|
||||
(vector->list (syntax-e stx))))))
|
||||
(pt
|
||||
(box? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(box #,(convert-pat (unbox (syntax-e stx))))))
|
||||
(pt
|
||||
(identifier? stx)
|
||||
stx)
|
||||
(got-too-far
|
||||
(match:syntax-err
|
||||
(syntax/loc stx got-too-far)
|
||||
"syntax error in pattern"))))
|
||||
)
|
||||
exn:misc:match-value
|
||||
define-match-expander)
|
||||
|
||||
(require-for-syntax "private/convert-pat.ss"
|
||||
"private/match-helper.ss")
|
||||
|
||||
(require-for-template mzscheme (prefix plt: "private/match-internal-func.ss"))
|
||||
|
||||
(require (prefix plt: "private/match-internal-func.ss")
|
||||
"private/match-expander.ss"
|
||||
"private/match-helper.ss"
|
||||
"private/match-error.ss")
|
||||
|
||||
(define-syntax (match-lambda stx)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
|
||||
#'(plt:match-lambda new-clauses ...))]))
|
||||
|
||||
(define-syntax (match-lambda* stx)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
|
||||
#'(plt:match-lambda* new-clauses ...))]))
|
||||
|
||||
(define-syntax (match-let stx)
|
||||
(syntax-case stx ()
|
||||
[(k name (clauses ...) body ...)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-let name (new-clauses ...) body ...))]
|
||||
[(k (clauses ...) body ...)
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-let (new-clauses ...) body ...))]))
|
||||
|
||||
(define-syntax (match-let* stx)
|
||||
(syntax-case stx ()
|
||||
[(k (clauses ...) body ...)
|
||||
(with-syntax
|
||||
([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-let* (new-clauses ...) body ...))]))
|
||||
|
||||
(define-syntax (match stx)
|
||||
(syntax-case stx ()
|
||||
[(_ exp clause ...)
|
||||
(with-syntax
|
||||
([(new-clauses ...) (handle-clauses #'(clause ...))])
|
||||
#'(plt:match exp new-clauses ...))]))
|
||||
|
||||
(define-syntax (match-letrec stx)
|
||||
(syntax-case stx ()
|
||||
[(k (clauses ...) body ...)
|
||||
(with-syntax
|
||||
([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-letrec (new-clauses ...) body ...))]))
|
||||
|
||||
|
||||
(define-syntax (match-define stx)
|
||||
(syntax-case stx ()
|
||||
[(k pat exp)
|
||||
(with-syntax ([new-pat (convert-pat #'pat)])
|
||||
#'(plt:match-define new-pat exp))]))
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -138,308 +138,21 @@
|
|||
match-let*
|
||||
match-letrec
|
||||
match-define
|
||||
match-test
|
||||
match:test-no-order
|
||||
pregexp-match-with-error
|
||||
exn:misc:match?
|
||||
exn:misc:match-value)
|
||||
exn:misc:match-value
|
||||
match-equality-test
|
||||
define-match-expander)
|
||||
|
||||
(require-for-syntax (lib "stx.ss" "syntax")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "include.ss")
|
||||
(lib "struct.ss" "syntax")
|
||||
(lib "pretty.ss"))
|
||||
(require (lib "pregexp.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss"))
|
||||
(require "private/match-internal-func.ss"
|
||||
"private/match-expander.ss"
|
||||
"private/match-helper.ss"
|
||||
"private/match-error.ss"
|
||||
"private/render-helpers.ss")
|
||||
|
||||
;; this makes pregexp errors a little more friendly
|
||||
(define (pregexp-match-with-error regex str)
|
||||
(if (or (string? regex)
|
||||
(and (pair? regex)
|
||||
(equal? ':sub (car regex))))
|
||||
(pregexp-match regex str)
|
||||
(error 'match:pregex
|
||||
(string-append
|
||||
"this pattern expects either a S-regexp or a U-regexp,"
|
||||
" given " (format "~s" regex) "; "
|
||||
"other argument was " (format "~s" str)))))
|
||||
|
||||
(define-struct (exn:misc:match exn:fail) (value))
|
||||
|
||||
(define match:error
|
||||
(case-lambda
|
||||
((val)
|
||||
(raise
|
||||
(make-exn:misc:match
|
||||
(string->immutable-string (format "match: no matching clause for ~e" val))
|
||||
(current-continuation-marks)
|
||||
val)))
|
||||
((val expr)
|
||||
(raise
|
||||
(make-exn:misc:match
|
||||
(string->immutable-string (format "match: no matching clause for ~e: ~s" val expr))
|
||||
(current-continuation-marks)
|
||||
val)))))
|
||||
|
||||
(define-syntax-set (match
|
||||
match-lambda
|
||||
match-lambda*
|
||||
match-let
|
||||
match-let*
|
||||
match-letrec
|
||||
match-define
|
||||
match-test
|
||||
)
|
||||
|
||||
(include (build-path "private" "plt-match" "match-inc.scm"))
|
||||
|
||||
(define node-count 0)
|
||||
|
||||
|
||||
;;!(syntax match-test)
|
||||
;; This macro only returns a list of two numbers.
|
||||
;; The first number represents the
|
||||
;; number of nodes generated in the process of compiling the match
|
||||
;; expression. This gives one and idea as to the size of the
|
||||
;; compiled expression.
|
||||
;; The second number is the amount of "real" time in milliseconds
|
||||
;; it took to compile the patterns.
|
||||
(define match-test/proc
|
||||
(lambda (stx)
|
||||
(syntax-case stx (=>)
|
||||
((_ clause ...)
|
||||
(begin
|
||||
(set! node-count 0)
|
||||
(let-values (((stx t rt gc) (time-apply gen-match
|
||||
(list (syntax x)
|
||||
'()
|
||||
(syntax (clause ...))
|
||||
stx))))
|
||||
#`(list #,(add1 node-count)
|
||||
#,rt)))))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define (match-func stx stx-orig)
|
||||
(syntax-case stx (=>)
|
||||
((_ exp clause ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let ((x exp))
|
||||
#,(gen-match (syntax x)
|
||||
'()
|
||||
(syntax (clause ...))
|
||||
stx-orig))))))
|
||||
|
||||
(define match-lambda-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(lambda (exp) #,(match-func
|
||||
(syntax/loc stx (match exp clause ...))
|
||||
stx-orig)))])))
|
||||
|
||||
(define match-lambda*-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(lambda exp #,(match-func
|
||||
(syntax/loc stx (match exp clause ...))
|
||||
stx-orig)))])))
|
||||
|
||||
(define match-let-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(_ name () body1 body ...)
|
||||
(syntax/loc stx (let name () body1 body ...))]
|
||||
[(_ name ([pat1 exp1] [pat exp]...) body1 body ...)
|
||||
(identifier? (syntax name))
|
||||
(let ((pat-list (syntax-object->datum (syntax (pat1 pat ...))))
|
||||
(real-name (syntax-object->datum (syntax name))))
|
||||
(if (andmap pattern-var? pat-list)
|
||||
(syntax/loc
|
||||
stx
|
||||
(let name ([pat1 exp1] [pat exp] ...) body1 body ...))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(letrec ([name
|
||||
#,(match-lambda*-func (syntax/loc stx (match-lambda* ((list pat1 pat ...) body1 body ...)))
|
||||
stx-orig)
|
||||
])
|
||||
(name exp1 exp ...)))))]
|
||||
[(_ () body1 body ...)
|
||||
(syntax/loc stx (begin body1 body...))]
|
||||
[(_ ([pat1 exp1] [pat exp]...) body1 body ...)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
( #,(match-lambda*-func (syntax/loc stx (match-lambda* ((list pat1 pat ...) body1 body ...)))
|
||||
stx-orig)
|
||||
exp1 exp ...))])))
|
||||
|
||||
(define match-let*-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax/loc stx (let* () body body1 ...)))
|
||||
((_ ([pat exp] rest ...) body body1 ...)
|
||||
(if (pattern-var? (syntax-object->datum (syntax pat)))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let ([pat exp])
|
||||
#,(match-let*-func (syntax (match-let* (rest ...) body body1 ...)) stx-orig)
|
||||
)
|
||||
)
|
||||
(match-func
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(match exp [pat #,(match-let*-func
|
||||
(syntax (match-let* (rest ...) body body1 ...))
|
||||
stx-orig)]))
|
||||
stx-orig))))))
|
||||
|
||||
(define match-letrec-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax/loc stx (let () body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(andmap pattern-var?
|
||||
(syntax-object->datum (syntax (pat ...))))
|
||||
(syntax/loc stx (letrec ([pat exp] ...) body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(let* ((**match-bound-vars** '())
|
||||
(compiled-match
|
||||
(gen-match (syntax the-exp);(syntax (list exp ...))
|
||||
'()
|
||||
(syntax (((list pat ...) never-used)))
|
||||
stx-orig
|
||||
(lambda (sf bv)
|
||||
(set! **match-bound-vars** bv)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(begin
|
||||
#,@(map (lambda (x)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(set! #,(car x) #,(cdr x))))
|
||||
(reverse bv))
|
||||
body body1 ...))))))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(letrec (#,@(map
|
||||
(lambda (x) (quasisyntax/loc stx (#,(car x) #f)))
|
||||
(reverse **match-bound-vars**))
|
||||
(the-exp (list exp ...)))
|
||||
#,compiled-match)))))))
|
||||
|
||||
(define match-define-func
|
||||
(lambda (stx stx-orig)
|
||||
(syntax-case stx ()
|
||||
[(_ pat exp)
|
||||
(identifier? (syntax pat))
|
||||
(syntax/loc stx (begin (define pat exp)))]
|
||||
[(_ pat exp)
|
||||
(let* ((**match-bound-vars** '())
|
||||
(compiled-match
|
||||
(gen-match (syntax the-exp)
|
||||
'()
|
||||
(syntax/loc (syntax pat) ((pat never-used)))
|
||||
stx-orig
|
||||
(lambda (sf bv)
|
||||
(set! **match-bound-vars** bv)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(begin
|
||||
#,@(map (lambda (x)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(set! #,(car x) #,(cdr x))))
|
||||
(reverse bv))))))))
|
||||
(quasisyntax/loc stx
|
||||
(begin #,@(map
|
||||
(lambda (x) (quasisyntax/loc
|
||||
stx
|
||||
(define #,(car x) #f)))
|
||||
(reverse **match-bound-vars**))
|
||||
(let ((the-exp exp))
|
||||
#,compiled-match))))])))
|
||||
(define match/proc
|
||||
(lambda (stx)
|
||||
(match-func stx stx)))
|
||||
|
||||
(define match-lambda/proc
|
||||
(lambda (stx)
|
||||
(match-lambda-func stx stx)))
|
||||
|
||||
(define match-lambda*/proc
|
||||
(lambda (stx)
|
||||
(match-lambda*-func stx stx)))
|
||||
|
||||
(define match-let/proc
|
||||
(lambda (stx)
|
||||
(match-let-func stx stx)))
|
||||
|
||||
(define match-let*/proc
|
||||
(lambda (stx)
|
||||
(match-let*-func stx stx)))
|
||||
|
||||
(define match-letrec/proc
|
||||
(lambda (stx)
|
||||
(match-letrec-func stx stx)))
|
||||
|
||||
(define match-define/proc
|
||||
(lambda (stx)
|
||||
(match-define-func stx stx)))
|
||||
|
||||
)
|
||||
|
||||
;;!(function match:test-no-order
|
||||
;; (form (match:test-no-order tests l last-test ddk-num)
|
||||
;; ->
|
||||
;; bool)
|
||||
;; (contract (list list test integer) -> bool))
|
||||
;; This is a recursive depth first search for a sequence of
|
||||
;; items in list l which will satisfy all of the tests in list
|
||||
;; tests. This is used for list-no-order and hash-table patterns.
|
||||
;; This function also handles ddk patterns by passing it the last
|
||||
;; test before the ddk and the value of k.
|
||||
(define (match:test-no-order tests l last-test ddk-num)
|
||||
(define (handle-last-test test l)
|
||||
(and (>= (length l) ddk-num)
|
||||
(andmap test l)))
|
||||
(define (dep-first-test head rest tests)
|
||||
(cond ((null? tests)
|
||||
(if last-test
|
||||
(handle-last-test last-test (cons head rest))
|
||||
#f))
|
||||
((null? rest)
|
||||
(if last-test
|
||||
(and (= 0 ddk-num)
|
||||
(= 1 (length tests))
|
||||
((car tests) head))
|
||||
(and (= 1 (length tests))
|
||||
((car tests) head))))
|
||||
(else (and (pair? tests)
|
||||
((car tests) head)
|
||||
(match:test-no-order (cdr tests)
|
||||
rest
|
||||
last-test
|
||||
ddk-num)))))
|
||||
(let loop ((lst l))
|
||||
(if (null? lst)
|
||||
#f
|
||||
(or (dep-first-test (car lst) (remove (car lst) l) tests)
|
||||
(loop (cdr lst))))))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user