..
original commit: dd9ff1ea1597f595ea7d62b1a61cde0f41acd064
This commit is contained in:
Robby Findler
parent
6135bd8497
commit
a99bea0a0a
|
|
@ -6,6 +6,12 @@
|
|||
;; Bruce Hauman <bhauman@cs.wcu.edu>. The latest version of this software
|
||||
;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.html.
|
||||
;;
|
||||
;; Special thanks go out to:
|
||||
;; Robert Bruce Findler for support and bug detection.
|
||||
;; Doug Orleans for pointing out that pairs should be reused while
|
||||
;; matching lists.
|
||||
;;
|
||||
;;
|
||||
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
|
||||
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
|
||||
;;
|
||||
|
|
@ -184,6 +190,14 @@
|
|||
((number? x) (number->string x))
|
||||
(else x)))
|
||||
l)))))
|
||||
;; we definitely want inturned variables here
|
||||
(get-exp-var
|
||||
(let ((count 0))
|
||||
(lambda ()
|
||||
(set! count (add1 count))
|
||||
(string->symbol
|
||||
(string-append "exp"
|
||||
(number->string count))))))
|
||||
|
||||
;; struct-pred-accessors - given a syntax object that is the
|
||||
;; name of a structure this function returns two values:
|
||||
|
|
@ -252,12 +266,20 @@
|
|||
(lambda (exp tsf patlist stx . success-func)
|
||||
(let* ((unrb (box #f))
|
||||
(compiled-match
|
||||
(if (null? success-func)
|
||||
(gen exp tsf patlist stx unrb)
|
||||
(gen exp tsf patlist stx unrb (car success-func)))))
|
||||
(quasisyntax/loc stx
|
||||
(let ((match-failure
|
||||
(lambda ()
|
||||
(match:error #,exp (quote #,stx)))))
|
||||
#,(if (null? success-func)
|
||||
(gen exp tsf patlist
|
||||
stx unrb (syntax (match-failure)))
|
||||
(gen exp tsf patlist
|
||||
stx unrb (syntax (match-failure))
|
||||
(car success-func)))))))
|
||||
(if (unbox unrb)
|
||||
(unreachable (unbox unrb) stx))
|
||||
compiled-match)))
|
||||
|
||||
;; gen is is the helper function for gen-match. In reality gen-match
|
||||
;; is just a wrapper for gen that allows for the detection of unreached
|
||||
;; patterns. This is implemented through the use of the unreached
|
||||
|
|
@ -274,9 +296,9 @@
|
|||
;; bottom of the recursion tree. For more information on this
|
||||
;; function see the _next_ function.
|
||||
(gen
|
||||
(lambda (exp tsf patlist stx unreach-box . success-func)
|
||||
(lambda (exp tsf patlist stx unreach-box failure-func . success-func)
|
||||
(if (stx-null? patlist)
|
||||
(quasisyntax (match:error #,exp (quote #,stx)))
|
||||
failure-func ;(quasisyntax/loc stx (match:error #,exp (quote #,stx)))
|
||||
(with-syntax (((clause1 clauselist ...) patlist))
|
||||
(let-values (((pat body fail-sym)
|
||||
(syntax-case (syntax clause1) (=>)
|
||||
|
|
@ -292,7 +314,8 @@
|
|||
sf
|
||||
(syntax (clauselist ...))
|
||||
stx
|
||||
unreach-box)))
|
||||
unreach-box
|
||||
failure-func)))
|
||||
(success
|
||||
(begin (let ((tail (syntax-object->datum
|
||||
(syntax (clauselist ...)))))
|
||||
|
|
@ -301,7 +324,7 @@
|
|||
(if (null? success-func)
|
||||
(lambda (sf bv)
|
||||
(if fail-sym
|
||||
#`(call-with-current-continuation
|
||||
(quasisyntax/loc stx (call-with-current-continuation
|
||||
(lambda (fail-cont)
|
||||
(let
|
||||
((failure
|
||||
|
|
@ -313,9 +336,9 @@
|
|||
#,@(map car bv))
|
||||
#,@body)
|
||||
failure
|
||||
#,@(map cdr bv)))))
|
||||
#`((lambda #,(map car bv)
|
||||
#,@body) #,@(map cdr bv))))
|
||||
#,@(map cdr bv))))))
|
||||
(quasisyntax/loc stx ((lambda #,(map car bv)
|
||||
#,@body) #,@(map cdr bv)))))
|
||||
(car success-func)))))
|
||||
;; next is the major internal function of gen
|
||||
;; This is implemented in what Wright terms as mock-continuation-passing
|
||||
|
|
@ -342,7 +365,7 @@
|
|||
(next
|
||||
pat-syntax
|
||||
(quote-syntax dummy)
|
||||
(syntax ())
|
||||
'()
|
||||
'()
|
||||
(lambda (sf bv) '(dummy-symbol))
|
||||
(lambda (sf bv) (out (map car bv)))))))
|
||||
|
|
@ -350,57 +373,62 @@
|
|||
(syntax-case phrase (unquote unquote-splicing)
|
||||
(p
|
||||
(let ((pat (syntax-object->datum (syntax p))))
|
||||
(or (null? pat)
|
||||
(string? pat)
|
||||
(boolean? pat)
|
||||
(char? pat)
|
||||
(or (null? pat)
|
||||
(string? pat)
|
||||
(boolean? pat)
|
||||
(char? pat)
|
||||
(number? pat)))
|
||||
(syntax p))
|
||||
(p
|
||||
(identifier? (syntax p))
|
||||
(syntax 'p))
|
||||
(syntax/loc phrase 'p))
|
||||
(,p (syntax p))
|
||||
((,@p . ()) (syntax p))
|
||||
((,@p . rest)
|
||||
#`#,(append (syntax->list (syntax p))
|
||||
((,@p . rest)
|
||||
#`#,(append (syntax->list (syntax p))
|
||||
(parse-quasi (syntax rest))))
|
||||
((p ddk)
|
||||
(stx-dot-dot-k? (syntax ddk))
|
||||
#`(#,(parse-quasi (syntax p)) ddk))
|
||||
#`(#,(parse-quasi (syntax p)) ddk))
|
||||
((x . y) #`(#,(parse-quasi (syntax x)) .
|
||||
#,(parse-quasi (syntax y))))
|
||||
(p
|
||||
(vector? (syntax-object->datum (syntax p)))
|
||||
#`#,(apply vector
|
||||
(syntax->list
|
||||
(parse-quasi
|
||||
#`#,(apply vector
|
||||
(syntax->list
|
||||
(parse-quasi
|
||||
(vector->list (syntax-e (syntax p)))))))
|
||||
(p
|
||||
(box? (syntax-object->datum (syntax p)))
|
||||
#`#,(box (parse-quasi (unbox (syntax-e (syntax p))))))
|
||||
(p (match:syntax-err
|
||||
(p (match:syntax-err
|
||||
(syntax-object->datum (syntax p)
|
||||
"syntax error in quasi-pattern")))))))
|
||||
|
||||
|
||||
(syntax-case* p (_ quote quasiquote ? = and or not $ set!
|
||||
get! ... ___ unquote unquote-splicing) stx-equal?
|
||||
(_ (ks sf bv))
|
||||
(pt (identifier? (syntax pt))
|
||||
(ks sf (cons (cons (syntax pt) e) bv)))
|
||||
(() (emit #`(null? #,e) sf bv kf ks))
|
||||
(pt (or (stx-? string? (syntax pt))
|
||||
(stx-? boolean? (syntax pt))
|
||||
(stx-? char? (syntax pt))
|
||||
(stx-? number? (syntax pt)))
|
||||
(emit #`(equal? #,e pt) sf bv kf ks))
|
||||
(pt
|
||||
(and (identifier? (syntax pt))
|
||||
(not (stx-dot-dot-k? (syntax pt))))
|
||||
(ks sf (cons (cons (syntax pt) e) bv)))
|
||||
(() (emit (quasisyntax/loc p (null? #,e)) sf bv kf ks))
|
||||
(pt
|
||||
;; could convert the syntax once
|
||||
(or (stx-? string? (syntax pt))
|
||||
(stx-? boolean? (syntax pt))
|
||||
(stx-? char? (syntax pt))
|
||||
(stx-? number? (syntax pt)))
|
||||
(emit (quasisyntax/loc p (equal? #,e pt)) sf bv kf ks))
|
||||
((quote _)
|
||||
(emit #`(equal? #,e #,p) sf bv kf ks))
|
||||
(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
|
||||
(`quasi-pat
|
||||
(next (parse-quasi (syntax quasi-pat)) e sf bv kf ks))
|
||||
|
||||
('item
|
||||
(emit #`(equal? #,e #,p) sf bv kf ks))
|
||||
(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
|
||||
;('(items ...)
|
||||
;(emit #`(equal? #,e #,p) sf bv kf ks))
|
||||
;(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
|
||||
((? pred pat1 pats ...)
|
||||
(next (syntax (and (? pred) pat1 pats ...))
|
||||
e
|
||||
|
|
@ -408,10 +436,25 @@
|
|||
bv
|
||||
kf
|
||||
ks))
|
||||
;; could we check to see if a predicate is a procedure here?
|
||||
((? pred)
|
||||
(emit #`(pred #,e) sf bv kf ks))
|
||||
(emit (quasisyntax/loc p (pred #,e)) sf bv kf ks))
|
||||
;; syntax checking
|
||||
((? pred ...)
|
||||
(match:syntax-err
|
||||
p
|
||||
(if (zero? (length (syntax-e (syntax (pred ...)))))
|
||||
"a predicate pattern must have a predicate following the ?"
|
||||
"syntax error in predicate pattern")))
|
||||
((= op pat)
|
||||
(next (syntax pat) #`(op #,e) sf bv kf ks))
|
||||
(next (syntax pat)(quasisyntax/loc p (op #,e)) sf bv kf ks))
|
||||
;; syntax checking
|
||||
((= op ...)
|
||||
(match:syntax-err
|
||||
p
|
||||
(if (zero? (length (syntax-e (syntax (op ...)))))
|
||||
"an operation pattern must have a procedure following the ="
|
||||
"there should be one pattern following the operator")))
|
||||
((and pats ...)
|
||||
(let loop
|
||||
((p (syntax (pats ...)))
|
||||
|
|
@ -446,35 +489,75 @@
|
|||
ks)))))
|
||||
((not pat)
|
||||
(next (syntax pat) e sf bv ks kf)) ;; swap success and fail
|
||||
;; could try to catch syntax local value error and rethrow syntax error
|
||||
(($ struct-name fields ...)
|
||||
(let ((num-of-fields (stx-length (syntax (fields ...)))))
|
||||
(let-values (((pred accessors)
|
||||
(struct-pred-accessors (syntax struct-name))))
|
||||
(emit #`(#,pred #,e)
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
(let rloop ((n 0))
|
||||
(lambda (sf bv)
|
||||
(if (= n num-of-fields)
|
||||
(ks sf bv)
|
||||
(next
|
||||
(list-ref (syntax->list (syntax (fields ...))) n)
|
||||
#`(#,(list-ref accessors n) #,e)
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
(rloop (+ 1 n))))))))))
|
||||
(let ((dif (- (length accessors) num-of-fields)))
|
||||
(if (not (zero? dif))
|
||||
(match:syntax-err
|
||||
p
|
||||
(string-append
|
||||
(if (> dif 0) "not enough " "too many ")
|
||||
"fields for structure in pattern"))
|
||||
(emit (quasisyntax/loc stx (#,pred #,e))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
(let rloop ((n 0))
|
||||
(lambda (sf bv)
|
||||
(if (= n num-of-fields)
|
||||
(ks sf bv)
|
||||
(next
|
||||
(list-ref (syntax->list (syntax (fields ...))) n)
|
||||
(quasisyntax/loc stx (#,(list-ref accessors n) #,e))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
(rloop (+ 1 n))))))))))))
|
||||
;; syntax checking
|
||||
(($ ident ...)
|
||||
(match:syntax-err
|
||||
p
|
||||
(if (zero? (length (syntax-e (syntax (ident ...)))))
|
||||
(format "~a~n~a~n~a"
|
||||
"a structure pattern must have the name "
|
||||
"of a defined structure followed with patterns "
|
||||
"to match each field of that structure")
|
||||
"syntax error in structure pattern")))
|
||||
((set! ident)
|
||||
(identifier? (syntax ident))
|
||||
(ks sf (cons (cons (syntax ident) (setter e (syntax ident))) bv)))
|
||||
(ks sf (cons (cons (syntax ident) (setter e p)) bv)))
|
||||
;; syntax checking
|
||||
((set! ident ...)
|
||||
(let ((x (length (syntax-e (syntax (ident ...))))))
|
||||
(match:syntax-err
|
||||
p
|
||||
(if (= x 1)
|
||||
"there should be an identifier after set! in pattern"
|
||||
(string-append "there should "
|
||||
(if (zero? x) "" "only ")
|
||||
"be one identifier after set! in pattern")))))
|
||||
((get! ident)
|
||||
(identifier? (syntax ident))
|
||||
(ks sf (cons (cons (syntax ident) (getter e (syntax ident))) bv)))
|
||||
(ks sf (cons (cons (syntax ident) (getter e p)) bv)))
|
||||
((get! ident ...)
|
||||
(let ((x (length (syntax-e (syntax (ident ...))))))
|
||||
(match:syntax-err
|
||||
p
|
||||
(if (= x 1)
|
||||
"there should be an identifier after get! in pattern"
|
||||
(string-append "there should "
|
||||
(if (zero? x) "" "only ")
|
||||
"be one identifier after get! in pattern")))))
|
||||
((pat dot-dot-k)
|
||||
(stx-dot-dot-k? (syntax dot-dot-k))
|
||||
(and (not (or (memq (syntax-e (syntax pat))
|
||||
'(unquote unquote-splicing ... ___))
|
||||
(stx-dot-dot-k? (syntax pat))))
|
||||
(stx-dot-dot-k? (syntax dot-dot-k)))
|
||||
(emit
|
||||
#`(list? #,e)
|
||||
(quasisyntax/loc stx (list? #,e))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
|
|
@ -504,9 +587,9 @@
|
|||
(syntax exp-sym)))
|
||||
(syntax pred))
|
||||
(whatever
|
||||
#`(lambda (exp-sym)
|
||||
#,ptst)))))
|
||||
(assm #`(andmap #,tst #,e)
|
||||
(quasisyntax/loc stx (lambda (exp-sym)
|
||||
#,ptst))))))
|
||||
(assm (quasisyntax/loc stx (andmap #,tst #,e))
|
||||
(kf sf bv)
|
||||
(ks sf bv)))))
|
||||
(id
|
||||
|
|
@ -523,9 +606,9 @@
|
|||
(syntax-object->datum x)
|
||||
'-bindings)))
|
||||
bound)))
|
||||
#`(let loop ((exp #,e)
|
||||
(quasisyntax/loc stx (let loop ((exp #,e)
|
||||
#,@(map
|
||||
(lambda (x) #`(#,x '()))
|
||||
(lambda (x) (quasisyntax/loc stx (#,x '())))
|
||||
binding-list-names))
|
||||
(if (null? exp)
|
||||
#,(ks sf
|
||||
|
|
@ -534,7 +617,7 @@
|
|||
bound
|
||||
(map
|
||||
(lambda (x)
|
||||
#`(reverse #,x))
|
||||
(quasisyntax/loc stx (reverse #,x)))
|
||||
binding-list-names))
|
||||
bv))
|
||||
#,(next (syntax the-pat)
|
||||
|
|
@ -545,29 +628,31 @@
|
|||
;; bindings
|
||||
kf
|
||||
(lambda (sf bv)
|
||||
#`(loop
|
||||
(quasisyntax/loc stx (loop
|
||||
(cdr exp)
|
||||
#,@(map
|
||||
(lambda
|
||||
(b-var
|
||||
bindings-var)
|
||||
#`(cons
|
||||
(quasisyntax/loc stx (cons
|
||||
#,(cdr
|
||||
(assq
|
||||
b-var
|
||||
bv))
|
||||
#,bindings-var))
|
||||
bound binding-list-names)))))))))))))
|
||||
#,bindings-var)))
|
||||
bound binding-list-names)))))))))))))))
|
||||
(case k
|
||||
((0) (ksucc sf bv))
|
||||
((1) (emit #`(pair? #,e) sf bv kf ksucc))
|
||||
(else (emit #`(>= (length #,e) #,k)
|
||||
((1) (emit (quasisyntax/loc stx (pair? #,e)) sf bv kf ksucc))
|
||||
(else (emit (quasisyntax/loc stx (>= (length #,e) #,k))
|
||||
sf bv kf ksucc)))))))
|
||||
;; handle proper and improper lists
|
||||
((car-pat . cdr-pat) ;pattern ;(pat1 pats ...)
|
||||
;(stx-? pair? (syntax pattern))
|
||||
(not (or (memq (syntax-e (syntax car-pat))
|
||||
'(unquote unquote-splicing))
|
||||
(stx-dot-dot-k? (syntax car-pat))))
|
||||
(emit
|
||||
#`(pair? #,e)
|
||||
(quasisyntax/loc stx (pair? #,e))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
|
|
@ -578,13 +663,14 @@
|
|||
bv
|
||||
kf
|
||||
(lambda (sf bv)
|
||||
(next (syntax cdr-pat)
|
||||
(add-d e)
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
ks))))))
|
||||
;;this is where vectors ... will go
|
||||
(let ((cdr-exp-var (get-exp-var)))
|
||||
#`(let ((#,cdr-exp-var (cdr #,e)))
|
||||
#,(next (syntax cdr-pat)
|
||||
#`#,cdr-exp-var
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
ks))))))))
|
||||
(pt
|
||||
(and (vector? (syntax-e (syntax pt)))
|
||||
(let* ((temp (syntax-e (syntax pt)))
|
||||
|
|
@ -599,19 +685,19 @@
|
|||
;; get the bindings for the second to last element:
|
||||
;; 'pat' in pat ...
|
||||
(bound (getbindings (vector-ref vec-stx vlen))))
|
||||
(emit #`(vector? #,e)
|
||||
(emit (quasisyntax/loc stx (vector? #,e))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
(lambda (sf bv)
|
||||
(assm #`(>= (vector-length #,e) #,minlen)
|
||||
(assm (quasisyntax/loc stx (>= (vector-length #,e) #,minlen))
|
||||
(kf sf bv)
|
||||
((let vloop ((n 0))
|
||||
(lambda (sf bv)
|
||||
(cond
|
||||
((not (= n vlen))
|
||||
(next (vector-ref vec-stx n)
|
||||
#`(vector-ref #,e #,n)
|
||||
(quasisyntax/loc stx (vector-ref #,e #,n))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
|
|
@ -629,51 +715,51 @@
|
|||
(syntax-object->datum x)
|
||||
'-bindings)))
|
||||
bound)))
|
||||
#`(let vloop
|
||||
(quasisyntax/loc stx (let vloop
|
||||
((index (- (vector-length #,e) 1))
|
||||
#,@(map (lambda (x) #`(#,x '()))
|
||||
#,@(map (lambda (x) (quasisyntax/loc stx (#,x '())))
|
||||
binding-list-names))
|
||||
(if (> #,vlen index)
|
||||
#,(ks sf (append (map cons bound
|
||||
binding-list-names)
|
||||
bv))
|
||||
#,(next (vector-ref vec-stx n)
|
||||
#`(vector-ref #,e index)
|
||||
(quasisyntax/loc stx (vector-ref #,e index))
|
||||
sf
|
||||
bv ;; we alway start over
|
||||
;; with the old bindings
|
||||
kf
|
||||
(lambda (sf bv)
|
||||
#`(vloop
|
||||
(quasisyntax/loc stx (vloop
|
||||
(- index 1)
|
||||
#,@(map
|
||||
(lambda (b-var
|
||||
bindings-var)
|
||||
#`(cons
|
||||
(quasisyntax/loc stx (cons
|
||||
#,(cdr
|
||||
(assq
|
||||
b-var
|
||||
bv))
|
||||
#,bindings-var))
|
||||
#,bindings-var)))
|
||||
bound
|
||||
binding-list-names)))))))))))
|
||||
binding-list-names)))))))))))))
|
||||
sf
|
||||
bv))))))
|
||||
(pt
|
||||
(stx-? vector? (syntax pt))
|
||||
(let ((vlen (stx-? vector-length (syntax pt))))
|
||||
(emit
|
||||
#`(vector? #,e)
|
||||
(quasisyntax/loc stx (vector? #,e))
|
||||
sf bv kf
|
||||
(lambda (sf bv)
|
||||
(emit #`(equal? (vector-length #,e) #,vlen)
|
||||
(emit (quasisyntax/loc stx (equal? (vector-length #,e) #,vlen))
|
||||
sf bv kf
|
||||
(let vloop ((n 0))
|
||||
(lambda (sf bv)
|
||||
(if (= n vlen)
|
||||
(ks sf bv)
|
||||
(next (vector-ref (syntax-e (syntax pt)) n)
|
||||
#`(vector-ref #,e #,n)
|
||||
(quasisyntax/loc stx (vector-ref #,e #,n))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
|
|
@ -681,18 +767,18 @@
|
|||
(pt
|
||||
(stx-? box? (syntax pt))
|
||||
(emit
|
||||
#`(box? #,e)
|
||||
(quasisyntax/loc stx (box? #,e))
|
||||
sf bv kf
|
||||
(lambda (sf bv)
|
||||
(next (unbox (syntax-e (syntax pt)))
|
||||
#`(unbox #,e)
|
||||
(quasisyntax/loc stx (unbox #,e))
|
||||
sf
|
||||
bv
|
||||
kf
|
||||
ks))))
|
||||
(got-to-far
|
||||
(got-too-far
|
||||
(match:syntax-err
|
||||
(syntax go-to-far)
|
||||
(syntax/loc stx got-too-far)
|
||||
"syntax error in pattern")))))))))))
|
||||
|
||||
;; emit's true function is to manage the tests-seen-so-far lists
|
||||
|
|
@ -702,39 +788,38 @@
|
|||
;; determined to be a false property emit calls the fail function.
|
||||
;; emit adds implied truths to the test seen so far list so that
|
||||
;; these truths can be checked against later.
|
||||
(emit
|
||||
(emit
|
||||
(lambda (tst sf bv kf ks)
|
||||
(let ((test (syntax-object->datum tst))
|
||||
(seen-so-far (syntax-object->datum sf)))
|
||||
(let ((test (syntax-object->datum tst)))
|
||||
(cond
|
||||
((in test seen-so-far) (ks sf bv))
|
||||
((in `(not ,test) seen-so-far) (kf sf bv))
|
||||
(else
|
||||
(let* ((implied
|
||||
(syntax-case tst (equal? null?)
|
||||
((equal? e p) ;remember this is a pattern
|
||||
(cond ((stx-? string? (syntax e))
|
||||
(list (syntax (string? e))))
|
||||
((stx-? boolean? (syntax e))
|
||||
(list (syntax (boolean? e))))
|
||||
((stx-? char? (syntax e))
|
||||
(list (syntax (char? e))))
|
||||
((stx-? number? (syntax e))
|
||||
(list (syntax (number? e))))
|
||||
((in test sf) (ks sf bv))
|
||||
((in `(not ,test) sf) (kf sf bv))
|
||||
(else
|
||||
(let* ((pred (car test))
|
||||
(exp (cadr test))
|
||||
(implied
|
||||
(cond
|
||||
((equal? pred 'equal?)
|
||||
(cond ((string? exp)
|
||||
(list `(string? ,exp)))
|
||||
((boolean? exp)
|
||||
(list `(boolean? ,exp)))
|
||||
((char? exp)
|
||||
(list `(char? ,exp)))
|
||||
((number? exp)
|
||||
(list `(number? ,exp)))
|
||||
(else '())))
|
||||
((null? e) ; remember that this is a pattern
|
||||
(list (syntax (list? e))))
|
||||
;; skipping vec-structure from original as it was not used
|
||||
(_ '())))
|
||||
((equal? pred 'null?)
|
||||
(list `(list? ,exp)))
|
||||
(else '())))
|
||||
(not-imp
|
||||
(syntax-case tst (list?)
|
||||
((list? e) ; just a pattern
|
||||
(list (syntax (not (null? e)))))
|
||||
(_ '())))
|
||||
(s (ks #`#,(cons tst (append implied (syntax->list sf))) bv))
|
||||
(k (kf #`#,(cons #`(not #,tst) (append not-imp (syntax->list sf))) bv)))
|
||||
(if (equal? pred 'list?)
|
||||
(list `(not (null? ,exp)))
|
||||
'()))
|
||||
(s (ks (cons test (append implied sf)) bv))
|
||||
(k (kf (cons `(not ,test) (append not-imp sf)) bv)))
|
||||
(assm tst k s)))))))
|
||||
|
||||
|
||||
;; assm - this function is responsible for constructing the actual
|
||||
;; if statements. It examines the incoming failure action and compares
|
||||
;; it to the current one if they are the same it concats the tests
|
||||
|
|
@ -753,19 +838,19 @@
|
|||
let) ;free-identifier=? ;stx-equal?
|
||||
((if (and tsts ...) true-act fail-act)
|
||||
(equal? f (syntax-object->datum (syntax fail-act)))
|
||||
#`(if (and #,tst tsts ...) true-act fail-act))
|
||||
(quasisyntax/loc tst (if (and #,tst tsts ...) true-act fail-act)))
|
||||
((if tst-prev true-act fail-act)
|
||||
(equal? f (syntax-object->datum (syntax fail-act)))
|
||||
#`(if (and #,tst tst-prev) true-act fail-act))
|
||||
(quasisyntax/loc tst (if (and #,tst tst-prev) true-act fail-act)))
|
||||
((call-with-current-continuation
|
||||
(lambda (k) (let ((fail (lambda () (_ f2)))) s2)))
|
||||
(equal? f (syntax-object->datum (syntax f2)))
|
||||
#`(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(let ((fail (lambda () (k #,main-fail))))
|
||||
#,(assm tst ((syntax fail)) (syntax s2))))))
|
||||
(quasisyntax/loc tst (call-with-current-continuation
|
||||
(lambda (k)
|
||||
(let ((fail (lambda () (k #,main-fail))))
|
||||
#,(assm tst ((syntax fail)) (syntax s2)))))))
|
||||
;; leaving out pattern that is never used in original
|
||||
(_ #`(if #,tst #,main-succ #,main-fail))))))))
|
||||
(_ (quasisyntax/loc tst (if #,tst #,main-succ #,main-fail)))))))))
|
||||
|
||||
(in (lambda (e l)
|
||||
(or (member e l)
|
||||
|
|
@ -886,9 +971,9 @@
|
|||
((car-thing exp)
|
||||
(let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
|
||||
(if new
|
||||
#`(#,(cadr new) exp)
|
||||
#'(car (car-thing exp)))))
|
||||
(exp #'(car exp)))))
|
||||
(quasisyntax/loc exp-syntax (#,(cadr new) exp))
|
||||
(syntax/loc exp-syntax (car (car-thing exp))))))
|
||||
(exp (syntax/loc exp-syntax (car exp))))))
|
||||
|
||||
(add-d
|
||||
(lambda (exp-syntax)
|
||||
|
|
@ -896,9 +981,9 @@
|
|||
((car-thing exp)
|
||||
(let ((new (assq (syntax-object->datum (syntax car-thing)) c---rs)))
|
||||
(if new
|
||||
#`(#,(cddr new) exp)
|
||||
#'(cdr (car-thing exp)))))
|
||||
(exp #'(cdr exp)))))
|
||||
(quasisyntax/loc exp-syntax (#,(cddr new) exp))
|
||||
(syntax/loc exp-syntax (cdr (car-thing exp))))))
|
||||
(exp (syntax/loc exp-syntax (cdr exp))))))
|
||||
|
||||
(c---rs '((car caar . cdar)
|
||||
(cdr cadr . cddr)
|
||||
|
|
@ -943,7 +1028,8 @@
|
|||
(syntax-case e (vector-ref unbox car cdr)
|
||||
(p
|
||||
(not (stx-pair? (syntax p)))
|
||||
(match:syntax-err ident "unnested set! pattern"))
|
||||
(match:syntax-err ident
|
||||
"set! pattern should be nested inside of a list, vector or box"))
|
||||
((vector-ref vector index)
|
||||
(syntax (let ((x vector))
|
||||
(lambda (y)
|
||||
|
|
@ -967,19 +1053,22 @@
|
|||
(let ((a (assq (syntax-object->datum (syntax acc))
|
||||
get-c---rs)))
|
||||
(if a
|
||||
#`(let ((x (#,(cadr a) exp)))
|
||||
(lambda (y)
|
||||
(#,(mk-setter (cddr a)) x y)))
|
||||
#`(let ((x exp))
|
||||
(lambda (y)
|
||||
(#,(mk-setter (syntax-object->datum (syntax acc)))
|
||||
x y))))))))))
|
||||
(quasisyntax/loc ident
|
||||
(let ((x (#,(cadr a) exp)))
|
||||
(lambda (y)
|
||||
(#,(mk-setter (cddr a)) x y))))
|
||||
(quasisyntax/loc ident
|
||||
(let ((x exp))
|
||||
(lambda (y)
|
||||
(#,(mk-setter (syntax-object->datum (syntax acc)))
|
||||
x y)))))))))))
|
||||
|
||||
(getter (lambda (e ident)
|
||||
(syntax-case e (vector-ref unbox car cdr)
|
||||
(p
|
||||
(not (stx-pair? (syntax p)))
|
||||
(match:syntax-err ident "unnested set! pattern"))
|
||||
(match:syntax-err ident
|
||||
"get! pattern should be nested inside of a list, vector or box"))
|
||||
((vector-ref vector index)
|
||||
(syntax (let ((x vector))
|
||||
(lambda ()
|
||||
|
|
@ -999,11 +1088,12 @@
|
|||
(let ((a (assq (syntax-object->datum (syntax acc))
|
||||
get-c---rs)))
|
||||
(if a
|
||||
#`(let ((x (#,(cadr a) exp)))
|
||||
(lambda () (#,(cddr a) x)))
|
||||
#'(let ((x exp))
|
||||
(lambda ()
|
||||
(acc x)))))))))
|
||||
(quasisyntax/loc ident
|
||||
(let ((x (#,(cadr a) exp)))
|
||||
(lambda () (#,(cddr a) x))))
|
||||
(syntax/loc ident (let ((x exp))
|
||||
(lambda ()
|
||||
(acc x))))))))))
|
||||
|
||||
|
||||
(get-c---rs '((caar car . car)
|
||||
|
|
@ -1036,102 +1126,111 @@
|
|||
(cddddr cdddr . cdr)))
|
||||
|
||||
(match-mac (lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ exp clause ...)
|
||||
#`(let ((x exp)) #,(gen-match (syntax x)
|
||||
(syntax ())
|
||||
(syntax (clause ...))
|
||||
stx))))))
|
||||
(syntax-case stx (=>)
|
||||
((_ exp (pat body) ...)
|
||||
(quasisyntax/loc stx (let ((x exp)) #,(gen-match (syntax x)
|
||||
'()
|
||||
(syntax ((pat body) ...))
|
||||
stx))))
|
||||
((_ exp (pat (=> fail) body) ...)
|
||||
(quasisyntax/loc stx (let ((x exp)) #,(gen-match (syntax x)
|
||||
'()
|
||||
(syntax ((pat (=> fail) body) ...))
|
||||
stx)))))))
|
||||
|
||||
(match-lambda-mac (lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(syntax (lambda (exp) (match exp clause ...)))])))
|
||||
(syntax/loc stx (lambda (exp) (match exp clause ...)))])))
|
||||
|
||||
|
||||
(match-lambda*-mac (lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(k clause ...)
|
||||
(syntax (lambda exp (match exp clause ...)))])))
|
||||
(syntax/loc stx (lambda exp (match exp clause ...)))])))
|
||||
(match-let-mac
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name () body1 body ...)
|
||||
(syntax (let 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 (let name ([pat1 exp1] [pat exp] ...) body1 body ...))
|
||||
(syntax
|
||||
(syntax/loc stx (let name ([pat1 exp1] [pat exp] ...) body1 body ...))
|
||||
(syntax/loc stx
|
||||
(letrec ([name
|
||||
(match-lambda* ((pat1 pat ...) body1 body ...))])
|
||||
(name exp1 exp ...)))))]
|
||||
[(_ () body1 body ...)
|
||||
(syntax (begin body1 body...))]
|
||||
(syntax/loc stx (begin body1 body...))]
|
||||
[(_ ([pat1 exp1] [pat exp]...) body1 body ...)
|
||||
(syntax ((match-lambda* ((pat1 pat ...) body1 body ...)) exp1 exp ...))])))
|
||||
(syntax/loc stx ((match-lambda* ((pat1 pat ...) body1 body ...)) exp1 exp ...))])))
|
||||
(match-let*-mac
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax (let* () body body1 ...)))
|
||||
(syntax/loc stx (let* () body body1 ...)))
|
||||
((_ ([pat exp] rest ...) body body1 ...)
|
||||
(if (pattern-var? (syntax-object->datum (syntax pat)))
|
||||
(syntax (let ([pat exp]) (match-let* (rest ...) body body1 ...)))
|
||||
(syntax (match exp [pat (match-let* (rest ...) body body1 ...)])))))))
|
||||
(syntax/loc stx (let ([pat exp]) (match-let* (rest ...) body body1 ...)))
|
||||
(syntax/loc stx (match exp [pat (match-let* (rest ...) body body1 ...)])))))))
|
||||
|
||||
(match-letrec-mac
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ () body body1 ...)
|
||||
(syntax (let () body body1 ...)))
|
||||
(syntax/loc stx (let () body body1 ...)))
|
||||
((_ ([pat exp] ...) body body1 ...)
|
||||
(andmap pattern-var?
|
||||
(syntax-object->datum (syntax (pat ...)))) ;if they are not patterns
|
||||
(syntax (letrec ([pat exp] ...) body body1 ...)))
|
||||
(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 (syntax ((pat ...) never-used)))
|
||||
stx
|
||||
(lambda (sf bv)
|
||||
(set! **match-bound-vars** bv)
|
||||
#`(begin
|
||||
#,@(map (lambda (x)
|
||||
#`(set! #,(car x) #,(cdr x)))
|
||||
(reverse bv))
|
||||
body body1 ...)))))
|
||||
#`(letrec (#,@(map
|
||||
(lambda (x) #`(#,(car x) #f))
|
||||
(reverse **match-bound-vars**))
|
||||
(the-exp (list exp ...)))
|
||||
#,compiled-match))))))
|
||||
(quasisyntax/loc stx (begin
|
||||
#,@(map (lambda (x)
|
||||
#`(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)))))))
|
||||
|
||||
(match-define-mac
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat exp)
|
||||
(identifier? (syntax pat))
|
||||
(syntax (begin (define pat exp)))]
|
||||
(syntax/loc stx (begin (define pat exp)))]
|
||||
[(_ pat exp)
|
||||
(let* ((**match-bound-vars** '())
|
||||
(compiled-match
|
||||
(gen-match (syntax the-exp)
|
||||
(syntax ())
|
||||
(list (syntax (pat never-used)))
|
||||
'()
|
||||
(list (syntax/loc (syntax pat) (pat never-used)))
|
||||
stx
|
||||
(lambda (sf bv)
|
||||
(set! **match-bound-vars** bv)
|
||||
#`(begin
|
||||
#,@(map (lambda (x)
|
||||
#`(set! #,(car x) #,(cdr x)))
|
||||
(reverse bv)))))))
|
||||
#`(begin #,@(map
|
||||
(lambda (x) #`(define #,(car x) #f))
|
||||
(reverse **match-bound-vars**))
|
||||
(let ((the-exp exp))
|
||||
#,compiled-match)))])))
|
||||
(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))))])))
|
||||
) ;; end of let rec binding area
|
||||
(values match-mac
|
||||
match-lambda-mac
|
||||
|
|
@ -1142,4 +1241,3 @@
|
|||
match-define-mac)))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user