diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index 1e527a1..6868535 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -125,6 +125,7 @@ match-let* match-letrec match-define + match-test ) (require-for-syntax (lib "stx.ss" "syntax") @@ -159,6 +160,8 @@ match-let* match-letrec match-define + match-test + m:match-test m:match m:match-letrec m:match-define @@ -312,6 +315,35 @@ #,@(map handle-clause (syntax-e (syntax (clause ...)))))))))) +(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-letrec/proc (lambda (stx) (syntax-case stx () @@ -377,10 +409,9 @@ not $ set! - var get! - unquote - unquote-splicing + ;unquote + ;unquote-splicing ))) (let/ec out (let loop ((x x)) @@ -415,6 +446,7 @@ (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 diff --git a/collects/mzlib/plt-match.ss b/collects/mzlib/plt-match.ss index f8e4abd..8e22368 100644 --- a/collects/mzlib/plt-match.ss +++ b/collects/mzlib/plt-match.ss @@ -7,9 +7,10 @@ ;; ;; Special thanks go out to: ;; Robert Bruce Findler for support and bug detection. +;; Scott Owens for the new constructor grammer. ;; 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. @@ -52,6 +53,7 @@ ;; | character a character ;; | 'sexp an s-expression ;; | 'symbol a symbol (special case of s-expr) +;; | (var id) allows one to use ..k or _ as identifiers ;; | (list lvp_1 ... lvp_n) list of n elements ;; | (list-rest lvp_1 ... lvp_n pat) an improper list of n elements ;; plus a last element which represents @@ -110,15 +112,12 @@ ;; of remainder must match qp_n+1 ;; | #&qp box ;; | ,pat a pattern -;; | ,@(lvp . . . lvp-n) -;; | ,@(lvp-1 . . . lvp-n . pat) +;; | ,@(list lvp . . . lvp-n) +;; | ,@(list-rest lvp-1 . . . lvp-n pat) ;; | ,@`qp qp must evaluate to a list as ;; so that this rule resembles the ;; above two rules ;; -;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $, -;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___) -;; cannot be used as pattern variables. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -132,13 +131,11 @@ match-let* match-letrec match-define - match-count match:test-no-order ) (require-for-syntax (lib "stx.ss" "syntax") (lib "etc.ss") - ;(lib "pretty.ss") (lib "list.ss") (lib "include.ss")) @@ -169,32 +166,12 @@ match-let* match-letrec match-define - match-count ) (include "private/plt-match/match-inc.scm") (define node-count 0) - ;;!(syntax match-count) - ;; This macro only returns a number. This number represents the - ;; number of nodes generated in the process of compiling the match - ;; expresseion. This gives one and idea as to the size of the - ;; compiled expression. This is mostly used for testing. - (define match-count/proc - (lambda (stx) - (syntax-case stx (=>) - ((_ exp clause ...) - (begin - (set! node-count 0) - (quasisyntax/loc - stx - (let ((x exp)) #,(gen-match (syntax x) - '() - (syntax (clause ...)) - stx))) - #`#,node-count))))) - (define match/proc (lambda (stx) (syntax-case stx (=>) diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss index 486f668..af319fb 100644 --- a/collects/tests/mzscheme/unit.ss +++ b/collects/tests/mzscheme/unit.ss @@ -183,7 +183,7 @@ (import struct:a a?) (export x? make-x x-z both) - (define-syntax a (list #'struct:a #f #'a? (list #f) (list #f))) + (define-syntax a (list #'struct:a #f #'a? (list #f) (list #f) #f)) (define-struct (x a) (y z)) (define both (lambda (v) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss index 17a6f37..f373605 100644 --- a/collects/tests/mzscheme/unitsig.ss +++ b/collects/tests/mzscheme/unitsig.ss @@ -274,7 +274,7 @@ m2-2^ (import m2-1^) - (define-syntax a (list #'struct:a #f #f (list #f) (list #f))) + (define-syntax a (list #'struct:a #f #f (list #f) (list #f) #f)) (define-struct (x a) (y z)) (define both (lambda (v)