diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index 02ddaa4..0097302 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -6,6 +6,12 @@ ;; Bruce Hauman . 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))) ) -