From 9e17a6d99380d755f855aa2c73f757e82f14b5d6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 Sep 2006 16:52:45 -0400 Subject: [PATCH 01/14] reformatting --- .../private/match/match-internal-func.ss | 100 +++++++++--------- 1 file changed, 50 insertions(+), 50 deletions(-) diff --git a/collects/mzlib/private/match/match-internal-func.ss b/collects/mzlib/private/match/match-internal-func.ss index ac059ecd65..2f671c9347 100644 --- a/collects/mzlib/private/match/match-internal-func.ss +++ b/collects/mzlib/private/match/match-internal-func.ss @@ -1,16 +1,16 @@ (module match-internal-func mzscheme - + (provide (all-defined)) (require-for-syntax "gen-match.ss" "match-helper.ss" "match-error.ss") - + (require (lib "etc.ss") (lib "list.ss") "match-expander.ss" "match-error.ss") - + (define-syntax (match stx) (syntax-case stx () @@ -22,7 +22,7 @@ (syntax-case stx () [(k . clauses) #'(lambda (exp) (match exp . clauses))])) - + (define-syntax (match-lambda* stx) (syntax-case stx () [(k . clauses) @@ -65,57 +65,57 @@ ((_ ([pat exp] rest ...) body ...) (if (pattern-var? (syntax pat)) #'(let ([pat exp]) - (match-let* (rest ...) body ...)) + (match-let* (rest ...) body ...)) #'(match exp [pat (match-let* (rest ...) body ...)])) ))) (define-syntax (match-letrec stx) - (syntax-case stx () - [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] - [(_ ([pat exp] ...) . body) - (andmap pattern-var? - (syntax->list #'(pat ...))) - #'(letrec ([pat exp] ...) . body)] - [(_ ([pat exp] ...) . body) - (let* ((**match-bound-vars** '()) - (compiled-match - (gen-match #'the-exp - '() - #'(((list pat ...) never-used)) - stx - (lambda (sf bv) - (set! **match-bound-vars** bv) - #`(begin - #,@(map (lambda (x) #`(set! #,(car x) #,(cdr x))) - (reverse bv)) - . body ))))) - #`(letrec (#,@(map - (lambda (x) #`(#,(car x) #f)) - (reverse **match-bound-vars**)) - (the-exp (list exp ...))) - #,compiled-match))])) + (syntax-case stx () + [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] + [(_ ([pat exp] ...) . body) + (andmap pattern-var? + (syntax->list #'(pat ...))) + #'(letrec ([pat exp] ...) . body)] + [(_ ([pat exp] ...) . body) + (let* ((**match-bound-vars** '()) + (compiled-match + (gen-match #'the-exp + '() + #'(((list pat ...) never-used)) + stx + (lambda (sf bv) + (set! **match-bound-vars** bv) + #`(begin + #,@(map (lambda (x) #`(set! #,(car x) #,(cdr x))) + (reverse bv)) + . body ))))) + #`(letrec (#,@(map + (lambda (x) #`(#,(car x) #f)) + (reverse **match-bound-vars**)) + (the-exp (list exp ...))) + #,compiled-match))])) (define-syntax (match-define stx) (syntax-case stx () - [(_ pat exp) - (identifier? #'pat) - #'(define pat exp)] - [(_ pat exp) - (let* ((**match-bound-vars** '()) - (compiled-match - (gen-match #'the-exp - '() - #'((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)))])) + [(_ pat exp) + (identifier? #'pat) + #'(define pat exp)] + [(_ pat exp) + (let* ([**match-bound-vars** '()] + [compiled-match + (gen-match #'the-exp + '() + #'((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)))])) ) \ No newline at end of file From c702686b0127731692154065816b0766f58ae8a1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 Sep 2006 17:27:47 -0400 Subject: [PATCH 02/14] gen-match.ss: kill dead code, remove pointless argument match-internal-func.ss: - use match-define to implement match-letrec - clean up match-letrec using with-syntax --- collects/mzlib/private/match/gen-match.ss | 134 +++++------------- .../private/match/match-internal-func.ss | 55 +++---- 2 files changed, 58 insertions(+), 131 deletions(-) diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss index 25a22a12c1..fd1d0ba54b 100644 --- a/collects/mzlib/private/match/gen-match.ss +++ b/collects/mzlib/private/match/gen-match.ss @@ -10,6 +10,7 @@ "update-counts.scm" "update-binding-counts.scm" "render-test-list.scm" + "render-helpers.ss" "reorder-tests.scm" "tag-negate-tests.scm" "convert-pat.ss") @@ -53,18 +54,9 @@ [pat (match:syntax-err #'pat "syntax error in clause")])) - ;;!(function test-list-with-success-func - ;; (form (test-list-with-success-func exp car-patlist - ;; stx success-func) - ;; -> - ;; (test-list success-func)) - ;; (contract (syntax-object pair syntax-object - ;; (list list -> syntax-object)) - ;; -> - ;; (list ((list list -> syntax) list -> - ;; (list list -> syntax))))) + ;; test-list-with-success-func : syntax (cons syntax boolean) syntax success-func -> (cons test-list success-func) ;; This function takes an exp which is to be matched, a marked - ;; clause, and a syntax-object that is fro reporting errors. It + ;; clause, and a syntax-object that is for reporting errors. It ;; returns a pair the car of which is a list of test structs which ;; are in essense partially evaluated tests. The cdr of the ;; result is a function which takes a failure function and a list @@ -100,48 +92,8 @@ (define test-list (render-test-list pat exp (lambda (x) x) stx)) (cons test-list success)) - ;;!(function gen - ;; (form (gen exp tsf patlist stx failure-func opt success-func) - ;; -> - ;; syntax) - ;; (contract (syntax list list syntax - ;; (() -> void) bool (list list -> syntax)) - ;; -> - ;; syntax)) - ;; This function is primarily called by gen-help and takes the the - ;; newly marked clauses and the failure-func which is really a - ;; variable-name which will bound to the failure in the runtime - ;; code. This function then This function - ;; then takes these lists of partially compiled tests and reorders - ;; them in an attempt to reduce the size of the final compiled - ;; match expression. Binding counts are also updated to help - ;; determind which supexpressions of the expression to be matched - ;; need to be bound by let expressions. After all of this the - ;; tests are "coupled" together for final compilation. - #;(define (gen exp tsf patlist stx failure-func opt success-func) - ;; iterate through list and render each pattern to a list of tests - ;; and success functions - (define rendered-list - (map (lambda (clause) (test-list-with-success-func - exp clause stx success-func)) - patlist)) - (update-counts rendered-list) - (tag-negate-tests rendered-list) - (update-binding-counts rendered-list) - ((meta-couple (reorder-all-lists rendered-list) - (lambda (sf bv) failure-func) - '() - '()) - '() '())) + ;; gen-match : syntax list list syntax success-func -> syntax - ;;!(function gen-match - ;; (form (gen-match exp tsf patlist stx [success-func]) - ;; -> - ;; compiled-pattern) - ;; (contract (syntax-object list list syntax-object - ;; (list list -> syntax-object)) - ;; -> - ;; syntax-object)) ;;

gen-match is the gateway through which match accesses the match ;; pattern compiler. ;; @@ -156,7 +108,7 @@ ;; ;;

patlist - is a list of the pattern clauses of the match expr ;; these can be of either form (pat body ...) or - ;; (pat (=> fail) body ...)x + ;; (pat (=> fail) body ...) ;; ;;

stx is the original syntax of the match expression. ;; This is only used for error reporting. @@ -168,46 +120,38 @@ ;; about a match (namely the bound match variables) is at the bottom ;; of the recursion tree. The success function must take two arguments ;; and it should return a syntax object. - (define gen-match - (opt-lambda (exp tsf patlist stx [success-func #f]) - (initer) - (when (stx-null? patlist) - (match:syntax-err stx "null clause list")) - (print-time "entering gen-match") - (let* (;; We set up the list of - ;; clauses so that one can mark that they have been "reached". - [marked-clauses (mark-patlist patlist)] - [failure-func #'(match-failure)] - ;; iterate through list and render each pattern to a list of partially compiled tests - ;; and success functions. - ;; These are partially compiled - ;; because the test structures containa a function that needs to - ;; be coupled with the other functions of the other test - ;; structures before actual compilation results. - [rendered-list (map (lambda (clause) (test-list-with-success-func - exp clause stx success-func)) - marked-clauses)] - [_ (begin - (print-time "finished render-list") - (update-counts rendered-list) - (tag-negate-tests rendered-list) - (update-binding-counts rendered-list))] - ;; couple the partially compiled tests together into the final result. - [compiled-exp - (begin - (print-time "starting coupling") - ((meta-couple (reorder-all-lists rendered-list) - (lambda (sf bv) failure-func) - '() - '()) - '() '()))] - ;; Also wrap the final compilation in syntax which binds the - ;; match-failure function. - [compiled-match - #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) - #,compiled-exp)]) - (print-time "finished coupling") - (unreachable marked-clauses stx) - (print-time "done") - compiled-match))) + (define/opt (gen-match exp patlist stx [success-func #f]) + (when (stx-null? patlist) + (match:syntax-err stx "null clause list")) + (let* (;; We set up the list of + ;; clauses so that one can mark that they have been "reached". + [marked-clauses (mark-patlist patlist)] + [failure-func #'(match-failure)] + ;; iterate through list and render each pattern to a list of partially compiled tests + ;; and success functions. + ;; These are partially compiled + ;; because the test structures containa a function that needs to + ;; be coupled with the other functions of the other test + ;; structures before actual compilation results. + [rendered-list (map (lambda (clause) (test-list-with-success-func + exp clause stx success-func)) + marked-clauses)] + [_ (begin + (update-counts rendered-list) + (tag-negate-tests rendered-list) + (update-binding-counts rendered-list))] + ;; couple the partially compiled tests together into the final result. + [compiled-exp + ((meta-couple (reorder-all-lists rendered-list) + (lambda (sf bv) failure-func) + '() + '()) + '() '())] + ;; Also wrap the final compilation in syntax which binds the + ;; match-failure function. + [compiled-match + #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) + #,compiled-exp)]) + (unreachable marked-clauses stx) + compiled-match)) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/match-internal-func.ss b/collects/mzlib/private/match/match-internal-func.ss index 2f671c9347..133961f8c7 100644 --- a/collects/mzlib/private/match/match-internal-func.ss +++ b/collects/mzlib/private/match/match-internal-func.ss @@ -15,7 +15,7 @@ (define-syntax (match stx) (syntax-case stx () [(_ exp . clauses) - (with-syntax ([body (gen-match #'x '() #'clauses stx)]) + (with-syntax ([body (gen-match #'x #'clauses stx)]) #`(let ([x exp]) body))])) (define-syntax (match-lambda stx) @@ -76,24 +76,10 @@ (andmap pattern-var? (syntax->list #'(pat ...))) #'(letrec ([pat exp] ...) . body)] - [(_ ([pat exp] ...) . body) - (let* ((**match-bound-vars** '()) - (compiled-match - (gen-match #'the-exp - '() - #'(((list pat ...) never-used)) - stx - (lambda (sf bv) - (set! **match-bound-vars** bv) - #`(begin - #,@(map (lambda (x) #`(set! #,(car x) #,(cdr x))) - (reverse bv)) - . body ))))) - #`(letrec (#,@(map - (lambda (x) #`(#,(car x) #f)) - (reverse **match-bound-vars**)) - (the-exp (list exp ...))) - #,compiled-match))])) + [(_ ([pat exp] ...) . body) + #'(let () + (match-define (list pat ...) (list exp ...)) + . body)])) (define-syntax (match-define stx) (syntax-case stx () @@ -101,21 +87,18 @@ (identifier? #'pat) #'(define pat exp)] [(_ pat exp) - (let* ([**match-bound-vars** '()] - [compiled-match - (gen-match #'the-exp - '() - #'((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)))])) + (let ([**match-bound-vars** '()]) + (with-syntax ([compiled-match + (gen-match #'the-exp + #'((pat never-used)) + stx + (lambda (sf bv) + (set! **match-bound-vars** bv) + (with-syntax ([((vars . vals) ...) (reverse bv)]) + #'(begin (set! vars vals) ...))))] + [(vars ...) (reverse **match-bound-vars**)]) + #'(begin + (define vars #f) ... + (let ([the-exp exp]) + compiled-match))))])) ) \ No newline at end of file From 32e8e721751d7e2971f89cbd7e03293d77741d57 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 Sep 2006 18:42:58 -0400 Subject: [PATCH 03/14] gen-match: - use begin-with-definitions for code clarity - rename some variables - better contracts (comments) test-structure: - delete unused field update-counts: - general reformatting - delete dead code - refactoring to eliminate duplication --- collects/mzlib/private/match/gen-match.ss | 78 ++++--- .../mzlib/private/match/test-structure.scm | 8 +- .../mzlib/private/match/update-counts.scm | 206 +++++++----------- 3 files changed, 115 insertions(+), 177 deletions(-) diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss index fd1d0ba54b..cbb13ae19d 100644 --- a/collects/mzlib/private/match/gen-match.ss +++ b/collects/mzlib/private/match/gen-match.ss @@ -19,11 +19,7 @@ (lib "etc.ss") "match-error.ss") - - - ;;!(function mark-patlist - ;; (form (mark-patlist clauses) -> marked-clause-list) - ;; (contract list -> list)) + ;; mark-patlist : listof[x] -> listof[(cons x #f)] ;; This function takes each clause from the match expression and ;; pairs it with the dummy value #f. This value will be set! when ;; the pattern matcher compiles a possible successful match for @@ -61,13 +57,13 @@ ;; are in essense partially evaluated tests. The cdr of the ;; result is a function which takes a failure function and a list ;; of let-bound expressions and returns a success-function. - (define (test-list-with-success-func exp car-patlist stx success-func) - (define-values (pat body fail-sym) (parse-clause (car car-patlist))) + (define (test-list-with-success-func exp pat/mark stx success-func) + (define-values (pat body fail-sym) (parse-clause (car pat/mark))) (define (success fail let-bound) (if (not success-func) (lambda (sf bv) ;; mark this pattern as reached - (set-cdr! car-patlist #t) + (set-cdr! pat/mark #t) (with-syntax ([fail-var fail-sym] [(bound-vars ...) (map car bv)] [(args ...) (map (lambda (b) (subst-bindings (cdr b) let-bound)) bv)] @@ -80,7 +76,7 @@ #'(let ([bound-vars args] ...) . body)))) (lambda (sf bv) ;; mark this pattern as reached - (set-cdr! car-patlist #t) + (set-cdr! pat/mark #t) (let ((bv (map (lambda (bind) (cons (car bind) @@ -120,38 +116,38 @@ ;; about a match (namely the bound match variables) is at the bottom ;; of the recursion tree. The success function must take two arguments ;; and it should return a syntax object. - (define/opt (gen-match exp patlist stx [success-func #f]) - (when (stx-null? patlist) - (match:syntax-err stx "null clause list")) - (let* (;; We set up the list of - ;; clauses so that one can mark that they have been "reached". - [marked-clauses (mark-patlist patlist)] - [failure-func #'(match-failure)] - ;; iterate through list and render each pattern to a list of partially compiled tests - ;; and success functions. - ;; These are partially compiled - ;; because the test structures containa a function that needs to - ;; be coupled with the other functions of the other test - ;; structures before actual compilation results. - [rendered-list (map (lambda (clause) (test-list-with-success-func - exp clause stx success-func)) - marked-clauses)] - [_ (begin - (update-counts rendered-list) - (tag-negate-tests rendered-list) - (update-binding-counts rendered-list))] - ;; couple the partially compiled tests together into the final result. - [compiled-exp - ((meta-couple (reorder-all-lists rendered-list) - (lambda (sf bv) failure-func) - '() - '()) - '() '())] - ;; Also wrap the final compilation in syntax which binds the - ;; match-failure function. - [compiled-match - #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) - #,compiled-exp)]) + (define/opt (gen-match exp patlist stx [success-func #f]) + (begin-with-definitions + (when (stx-null? patlist) + (match:syntax-err stx "null clause list")) + ;; We set up the list of + ;; clauses so that one can mark that they have been "reached". + (define marked-clauses (mark-patlist patlist)) + (define failure-func #'(match-failure)) + ;; iterate through list and render each pattern to a list of partially compiled tests + ;; and success functions. + ;; These are partially compiled + ;; because the test structures containa a function that needs to + ;; be coupled with the other functions of the other test + ;; structures before actual compilation results. + (define rendered-list (map (lambda (clause) (test-list-with-success-func + exp clause stx success-func)) + marked-clauses)) + (update-counts rendered-list) + (tag-negate-tests rendered-list) + (update-binding-counts rendered-list) + ;; couple the partially compiled tests together into the final result. + (define compiled-exp + ((meta-couple (reorder-all-lists rendered-list) + (lambda (sf bv) failure-func) + '() + '()) + '() '())) + ;; Also wrap the final compilation in syntax which binds the + ;; match-failure function. + (define compiled-match + #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) + #,compiled-exp)) (unreachable marked-clauses stx) compiled-match)) ) \ No newline at end of file diff --git a/collects/mzlib/private/match/test-structure.scm b/collects/mzlib/private/match/test-structure.scm index 0d43994575..12a29a99a7 100644 --- a/collects/mzlib/private/match/test-structure.scm +++ b/collects/mzlib/private/match/test-structure.scm @@ -31,7 +31,6 @@ ;; of bind-exp-stx ;; bind-count - is the number of times in the bind-exp is found in the ;; test list in which this test is a member - ;; times-used-neg - ??? (this appears to never be used) ;; used-set-neg - ??? ;; closest-shape-tst - ??? ;; equal-set - ??? @@ -43,7 +42,6 @@ bind-exp-stx bind-exp bind-count - times-used-neg used-set-neg closest-shape-tst equal-set) @@ -65,7 +63,7 @@ ;; comp - the compilation function which will finish the compilation ;; after tests have been reordered (define (make-shape-test test exp comp) - (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 0 '() #f '())) + (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 '() #f '())) ;;!(function make-reg-test ;; (form (make-shape-test test exp comp) -> test-struct) @@ -81,7 +79,7 @@ ;; comp - the compilation function which will finish the compilation ;; after tests have been reordered (define (make-reg-test test exp comp) - (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 0 '() #f '())) + (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 '() #f '())) ;;!(function make-act-test ;; (form (make-shape-test test exp comp) -> test-struct) @@ -99,7 +97,7 @@ ;; comp - the compilation function which will finish the compilation ;; after tests have been reordered (define (make-act act-name exp comp) - (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 -1 '() #f '())) + (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 '() #f '())) ;;!(function action-test? ;; (form (action-test? test) -> bool) diff --git a/collects/mzlib/private/match/update-counts.scm b/collects/mzlib/private/match/update-counts.scm index ce1b72fb26..e8f4ebe90f 100644 --- a/collects/mzlib/private/match/update-counts.scm +++ b/collects/mzlib/private/match/update-counts.scm @@ -6,6 +6,7 @@ (require "test-structure.scm" "match-helper.ss" + (lib "etc.ss") (lib "list.ss")) ;;!(function test-filter @@ -17,14 +18,6 @@ (define (test-filter tlist) (filter (lambda (t) (not (= -1 (test-times-used t)))) tlist)) - #;(define test-filter - (lambda (tlist) - (if (null? tlist) - '() - (if (= -1 (test-times-used (car tlist))) - (test-filter (cdr tlist)) - (cons (car tlist) - (test-filter (cdr tlist))))))) ;; !(function inverse-in @@ -33,30 +26,26 @@ ;; This function checks to see if any of the members of the test-list ;; would be eliminated by the function if the test was in the test so far ;; list. This is the opposite of what the in function does. - (define inverse-in - (lambda (test test-list) - (or (pos-inverse-in test test-list) - (neg-inverse-in test test-list)))) + (define (inverse-in test test-list) + (or (pos-inverse-in test test-list) + (neg-inverse-in test test-list))) - (define pos-inverse-in - (lambda (test test-list) - (let ((test-with-implied (cons test (implied test)))) - (ormap (lambda (t) (in t test-with-implied)) - test-list) - ))) + (define (pos-inverse-in test test-list) + (let ([test-with-implied (cons test (implied test))]) + (ormap (lambda (t) (in t test-with-implied)) + test-list))) + - (define neg-inverse-in - (lambda (test test-list) - (let ((test-with-implied (cons test (implied test)))) - (ormap (lambda (t) (in `(not ,t) test-with-implied)) - test-list) - ))) + (define (neg-inverse-in test test-list) + (let ([test-with-implied (cons test (implied test))]) + (ormap (lambda (t) (in `(not ,t) test-with-implied)) + test-list))) + - (define logical-member - (lambda (item lst) - (ormap (lambda (cur) - (logical-equal? item cur)) - lst))) + (define (logical-member item lst) + (ormap (lambda (cur) + (logical-equal? item cur)) + lst)) (define (logical-equal? a b) (or (equal? a b) #t @@ -72,132 +61,87 @@ (eq? (car a) 'list?) (eq? (car b) 'null?) (equal? (cadr a) (cadr b))))) - ;; this implements the above code - #;(define logical-equal? - (lambda x - (if (pair? x) - (let ((exp8163 (cdr x))) - (if (and (pair? exp8163) (null? (cdr exp8163))) - (if (equal? (car exp8163) (car x)) - #t - (let ((exp8164 (car x))) - (if (and (pair? exp8164) (equal? (car exp8164) 'list?)) - (let ((exp8165 (cdr exp8164))) - (if (and (pair? exp8165) (null? (cdr exp8165))) - (let ((exp8166 (car exp8163))) - (if (and (pair? exp8166) (equal? (car exp8166) 'null?)) - (let ((exp8167 (cdr exp8166))) - (if (and (pair? exp8167) - (null? (cdr exp8167)) - (equal? (car exp8167) (car exp8165))) - ((lambda (x) #t) (car exp8165)) - ((lambda (else) #f) x))) - ((lambda (else) #f) x))) - ((lambda (else) #f) x))) - ((lambda (else) #f) x)))) - ((lambda (else) #f) x))) - ((lambda (else) #f) x)))) - - (define truncate-list - (lambda (pos used-set-neg) - (cond ((null? used-set-neg) - '()) - ((>= pos (car used-set-neg)) - (list pos)) - (else - (cons (car used-set-neg) - (truncate-list pos (cdr used-set-neg))))))) - - (define truncate-list-neg - (lambda (pos used-set-neg) - (cond ((null? used-set-neg) - '()) - ((>= pos (car used-set-neg)) - '()) - (else - (cons (car used-set-neg) - (truncate-list-neg pos (cdr used-set-neg))))))) + ;; truncate-list : int listof[int] -> listof[int] + ;; truncate-list-neg : int listof[int] -> listof[int] + ;; truncate-list removes all elements of a list after the element at least as large as p + ;; truncate-list-neg removes the found element as well + (define-values (truncate-list truncate-list-neg) + (let ([mk (lambda (pos-f) + (define (f p l) + (cond [(null? l) + '()] + [(>= p (car l)) + (pos-f p)] + [else + (cons (car l) + (f p (cdr l)))])) + f)]) + (values (mk list) (mk (lambda (x) '()))))) - ;;!(function update-count - ;; (form (update-count test tests-rest pos) -> void) - ;; (contract (test-struct list integer) -> void)) + ;; update-count : test listof[test] int -> void ;; This function updates the test-times-used and test-used-set ;; fields of the test structs. These fields are essential to ;; determining the order of the tests. - (define update-count - (lambda (test tests-rest pos mem-table) - (let loop ((l tests-rest) - (p (add1 pos))) + (define (update-count test tests-rest pos mem-table) + (let loop ([l tests-rest] + [p (add1 pos)]) (if (null? l) - (begin - ;; memoize - (hash-table-get mem-table (test-tst test) - (lambda () - (hash-table-put! - mem-table - (test-tst test) (list (test-used-set test) - (test-used-set-neg test))))) - ) - (let ((entry-pair + (hash-table-get mem-table (test-tst test) + (lambda () + (hash-table-put! + mem-table + (test-tst test) + (list (test-used-set test) + (test-used-set-neg test))))) + (let ([entry-pair (hash-table-get mem-table (test-tst test) (lambda () - (when ( - ;member - logical-member - ;inverse-in - (test-tst test) (car l)) + (when (logical-member (test-tst test) (car l)) (set-test-times-used! test (add1 (test-times-used test))) (set-test-used-set! test (cons p (test-used-set test))) - (set-test-equal-set! test (cons p (test-equal-set test))) - ) + (set-test-equal-set! test (cons p (test-equal-set test)))) (when (neg-inverse-in (test-tst test) (car l)) (set-test-used-set-neg! test (cons p (test-used-set-neg test)))) - (loop (cdr l) (add1 p)) - )))) + (loop (cdr l) (add1 p))))]) (when (and (list? entry-pair) (not (null? entry-pair))) - (let ((trun-used (truncate-list pos (car entry-pair)))) + (let ([trun-used (truncate-list pos (car entry-pair))]) (set-test-used-set! test trun-used) (set-test-equal-set! test trun-used) (set-test-times-used! test (length trun-used)) - (set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair))))) - ))))) + (set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair))))))))) + - ;;!(function update-counts - ;; (form (update-counts render-list) -> void) - ;; (contract list -> void)) + ;; update-counts : listof[(cons test any)] -> void ;; This function essentially calls update-count on every test in ;; all of the test lists. - (define update-counts - (lambda (render-list) - (let* ((mem-table (make-hash-table 'equal)) - (test-master-list (map test-filter - (map car render-list))) - (test-so-far-lists ;; horrible name + (define (update-counts render-list) + (let* ([mem-table (make-hash-table 'equal)] + [test-master-list (map (compose test-filter car) render-list)] + [test-so-far-lists ;; horrible name (map - (lambda (tl) - (let ((f (map test-tst (test-filter tl)))) - f)) - test-master-list))) - (let loop ((tml test-master-list) - (tsf test-so-far-lists) - (pos 1)) + (lambda (tl) (map test-tst (test-filter tl))) + test-master-list)]) + (let loop ([tml test-master-list] + [tsf test-so-far-lists] + [pos 1]) (if (null? tml) - '() + (void) (begin - (for-each (lambda (t) - (set-test-times-used! t 1) - (set-test-used-set! - t - (cons pos (test-used-set t))) - (set-test-equal-set! - t - (cons pos (test-equal-set t))) - (update-count t (cdr tsf) pos mem-table)) - (car tml)) - (loop (cdr tml) (cdr tsf) (add1 pos)))))))) + (for-each + (lambda (t) + (set-test-times-used! t 1) + (set-test-used-set! + t + (cons pos (test-used-set t))) + (set-test-equal-set! + t + (cons pos (test-equal-set t))) + (update-count t (cdr tsf) pos mem-table)) + (car tml)) + (loop (cdr tml) (cdr tsf) (add1 pos))))))) ) From 3a77f5a9140e8fa14bf724836f0f668f74841c4a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 5 Sep 2006 18:56:04 -0400 Subject: [PATCH 04/14] Work toward adding simplication pass before render-test-list. --- collects/mzlib/private/match/match-error.ss | 3 + .../private/match/render-test-list-impl.ss | 17 +-- .../mzlib/private/match/simplify-patterns.ss | 136 ++++++++++++++++++ 3 files changed, 140 insertions(+), 16 deletions(-) create mode 100644 collects/mzlib/private/match/simplify-patterns.ss diff --git a/collects/mzlib/private/match/match-error.ss b/collects/mzlib/private/match/match-error.ss index b0de1cb7de..f4e29e8a43 100644 --- a/collects/mzlib/private/match/match-error.ss +++ b/collects/mzlib/private/match/match-error.ss @@ -38,6 +38,9 @@ obj detail))) + (define (match:internal-err obj msg . detail) + (apply raise-syntax-error '|internal match error| msg obj detail)) + ;;!(function unreachable diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index 26da29af66..ca8fcaee53 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -166,12 +166,6 @@ ;; underscore is reserved to match nothing (_ '()) ;(ks sf bv let-bound)) - ;; plain identifiers expand into (var) patterns - (pt - (and (pattern-var? (syntax pt)) - (not (stx-dot-dot-k? (syntax pt)))) - (render-test-list #'(var pt) ae cert stx)) - ;; for variable patterns, we do bindings, and check if we've seen this variable before ((var pt) (identifier? (syntax pt)) @@ -194,9 +188,7 @@ (ks sf (cons (cons (syntax pt) ae) bv))])))))) ;; Recognize the empty list - ((list) (emit-null ae)) - ('() (emit-null ae)) - + ((list) (emit-null ae)) ;; This recognizes constants such strings [pt @@ -220,9 +212,6 @@ ,(syntax-object->datum p)) ae (lambda (exp) #`(equal? #,exp #,p))))) - (`quasi-pat - (render-test-list (parse-quasi #'quasi-pat) ae cert stx)) - ;; check for predicate patterns ;; could we check to see if a predicate is a procedure here? ((? pred?) @@ -231,10 +220,6 @@ ,(syntax-object->datum ae)) ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) - ;; predicate patterns with binders are redundant with and patterns - [(? pred? pats ...) - (render-test-list #'(and (? pred?) pats ...) ae cert stx)] - ;; syntax checking ((? anything ...) (match:syntax-err diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss new file mode 100644 index 0000000000..f49592c77a --- /dev/null +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -0,0 +1,136 @@ +(module simplify-patterns mzscheme + + (require (lib "stx.ss" "syntax")) + (require (rename (lib "1.ss" "srfi") map-append append-map)) + + (require "match-error.ss" + "match-helper.ss" + "test-structure.scm" + "coupling-and-binding.scm" + "update-counts.scm" + "update-binding-counts.scm" + "reorder-tests.scm" + "match-expander-struct.ss" + "render-helpers.ss") + + (require "render-sigs.ss" + (lib "unitsig.ss")) + + (require-for-syntax "match-helper.ss" + "match-expander-struct.ss" + "test-no-order.ss") + + (require-for-template mzscheme + "match-error.ss" + "test-no-order.ss" + "match-helper.ss") + + (provide simplify) + + ;; simplifies patterns by removing syntactic sugar and expanding match-expanders + ;; simplify : syntax certifier-> syntax + (define (simplify stx cert) + (define (simplify/i stx) (simplify stx cert)) + (syntax-case* + stx + (_ list quote quasiquote vector box ? app and or not struct set! var + list-rest get! ... ___ unquote unquote-splicing cons + list-no-order hash-table regexp pregexp cons) stx-equal? + + ;; expand match-expanders + ;; this doesn't work because we need to keep the certifier around + [(expander args ...) + (and (identifier? #'expander) + (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) + (let* ([expander (syntax-local-value (cert #'expander))] + [transformer (match-expander-plt-match-xform expander)]) + (unless transformer + (match:syntax-err #'expander + "This expander only works with the match.ss library.")) + (let* ([introducer (make-syntax-introducer)] + [certifier (match-expander-certifier expander)] + [result (introducer (transformer (introducer stx)))] + [cert* (lambda (id) (certifier (cert id) #f introducer))]) + (simplify result cert*)))] + + ;; label variable patterns + [id + (and (pattern-var? #'id) (not (stx-dot-dot-k? #'id))) + #'(var id)] + + ;; match the empty list + ['() (syntax/loc stx (list))] + + ;; other quoted data is untransformed + [(quote data) stx] + + ;; transform quasi-patterns into regular patterns + [`quasi-pat (simplify (parse-quasi #'quasi-pat))] + + ;; predicate patterns with binders are redundant with and patterns + [(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))] + [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] + + ;; regexp patterns - FIXME: abstract here + [(regexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))] + [(pregexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))] + [(regexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))] + [(pregexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))] + [(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")] + [(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")] + + + ;; cons is just list-rest with 2 arguments + [(cons p1 p2) (simplify (syntax/loc stx (list-rest p1 p2)))] + [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")] + + ;; aggregates + [(kw pats ...) + (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) + (quasisyntax/loc stx (kw #,@(syntax-map simplify #'(pats ...))))] + [(kw pats ... . rest) + (match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))] + + ;; hash table patterns have their own syntax + [(hash-table (pat1 pat2) ...) + (with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] + [(pat2* ...) (syntax-map simplify #'(pat2 ...))]) + (syntax/loc stx (hash-table (pat1* pat2*) ...)))] + [(hash-table (pat1 pat2) ... ooo) + (stx-dot-dot-k? #'ooo) + (with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] + [(pat2* ...) (syntax-map simplify #'(pat2 ...))]) + (syntax/loc stx (hash-table (pat1* pat2*) ... ooo)))] + [(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")] + + ;; struct patterns + [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify #'(pats ...))] + [st* (cert #'st)]) + (syntax/loc stx (struct st* (pats* ...))))] + [(struct . rest) (match:syntax-err stx "syntax error in struct pattern")] + + [(box pat) (quasisyntax/loc stx (box #,(simplify #'pat)))] + [(box . rest) (match:syntax-err stx "syntax error in box pattern")] + + [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify #'pat)))] + [(app . rest) (match:syntax-err stx "syntax error in app pattern")] + + [(set! id) + (identifier? #'id) + stx] + [(set! . rest) (match:syntax-err stx "set! pattern must have one identifier")] + + [(get! id) + (identifier? #'id) + stx] + [(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")] + + [(var . rest) (match:internal-err stx "var pattern found before simplification!")] + + [_ stx]) + + + ) + + + ) \ No newline at end of file From 6034e5e0d5d146f95ef8b185e135f162cf1fde30 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 6 Sep 2006 14:26:19 -0400 Subject: [PATCH 05/14] fix bug with list-rest in quasi-patterns --- collects/mzlib/private/match/parse-quasi.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/match/parse-quasi.scm b/collects/mzlib/private/match/parse-quasi.scm index a779045a8e..2bae2443f3 100644 --- a/collects/mzlib/private/match/parse-quasi.scm +++ b/collects/mzlib/private/match/parse-quasi.scm @@ -72,7 +72,7 @@ "unquote-splicing not followed by list")))] [,@p (if (and (stx-list? (syntax p)) - (eq? (syntax-e (car (syntax->list #'p))) 'list)) + (memq (syntax-e (car (syntax->list #'p))) '(list list-rest))) (cdr (syntax->list (syntax p))) (begin ; (write (syntax-e (syntax p))) (q-error (syntax ,@p) From 506c154ea825a5acc1368576347acb696cdcd057 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 7 Sep 2006 12:02:41 -0400 Subject: [PATCH 06/14] Add new simplification pass before render-test-list. Simplification expands match expanders and removes syntactic sugar. Also, syntax errors are checked in the simplification phase, so better error messages can be given. --- collects/mzlib/private/match/gen-match.ss | 6 +- .../private/match/render-test-list-impl.ss | 54 ++----------- .../mzlib/private/match/simplify-patterns.ss | 76 +++++++++++++------ 3 files changed, 65 insertions(+), 71 deletions(-) diff --git a/collects/mzlib/private/match/gen-match.ss b/collects/mzlib/private/match/gen-match.ss index cbb13ae19d..73ab83d566 100644 --- a/collects/mzlib/private/match/gen-match.ss +++ b/collects/mzlib/private/match/gen-match.ss @@ -13,6 +13,7 @@ "render-helpers.ss" "reorder-tests.scm" "tag-negate-tests.scm" + "simplify-patterns.ss" "convert-pat.ss") (require-for-template mzscheme @@ -85,7 +86,10 @@ let-bound))) bv))) (success-func sf bv))))) - (define test-list (render-test-list pat exp (lambda (x) x) stx)) + (define test-list + (let* ([cert (lambda (x) x)] + [simplified-pat (simplify pat cert)]) + (render-test-list simplified-pat exp cert stx))) (cons test-list success)) ;; gen-match : syntax list list syntax success-func -> syntax diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index ca8fcaee53..13a815fcd6 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -220,34 +220,10 @@ ,(syntax-object->datum ae)) ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) - ;; syntax checking - ((? anything ...) - (match:syntax-err - p - (if (zero? (length (syntax-e #'(anything ...)))) - "a predicate pattern must have a predicate following the ?" - "syntax error in predicate pattern"))) - - ((regexp reg-exp) - (regexp-matcher ae stx #'(? (lambda (x) (regexp-match reg-exp x))) cert)) - ((pregexp reg-exp) - (regexp-matcher ae stx #'(? (lambda (x) (pregexp-match-with-error reg-exp x))) cert)) - ((regexp reg-exp pat) - (regexp-matcher ae stx #'(app (lambda (x) (regexp-match reg-exp x)) pat) cert)) - ((pregexp reg-exp pat) - (regexp-matcher ae stx #'(app (lambda (x) (pregexp-match-with-error reg-exp x)) pat) cert)) - ;; app patterns just apply their operation. ((app op pat) (render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx)) - ;; syntax checking - ((app . op) - (match:syntax-err - p - (if (zero? (length (syntax-e #'op))) - "an operation pattern must have a procedure following the app" - "there should be one pattern following the operator"))) [(and . pats) (map-append (lambda (pat) (render-test-list pat ae cert stx)) (syntax->list #'pats))] @@ -271,9 +247,6 @@ ;; swap success and fail (next-outer #'pat ae sf bv let-bound ks kf cert)))))) - ;; (cons a b) == (list-rest a b) - [(cons p1 p2) (render-test-list #'(list-rest p1 p2) ae cert stx)] - ;; could try to catch syntax local value error and rethrow syntax error ((list-no-order pats ...) (if (stx-null? (syntax (pats ...))) @@ -340,26 +313,18 @@ ((hash-table pats ...) ;; must check the structure - (proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) + #;(proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) (list (shape-test `(hash-table? ,(syntax-object->datum ae)) ae (lambda (exp) #`(hash-table? #,exp))) - (let ((mod-pat + (let ([mod-pat (lambda (pat) - (syntax-case pat () - ((key value) (syntax (list key value))) - (ddk - (stx-dot-dot-k? (syntax ddk)) - (syntax ddk)) - (id - (and (pattern-var? (syntax id)) - (not (stx-dot-dot-k? (syntax id)))) - (syntax id)) - (p (match:syntax-err - (syntax/loc stx p) - "poorly formed hash-table pattern")))))) + (syntax-case* pat (var) stx-equal? + [(var id) pat] + [(keypat valpat) (syntax/loc pat (list keypat valpat))] + [_ pat]))]) (make-act 'hash-table-pat ae @@ -370,7 +335,7 @@ (hash-table-map #,(subst-bindings ae let-bound) (lambda (k v) (list k v))))) - #,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...))))) + #,(next-outer #`(list-no-order #,@(syntax-map mod-pat #'(pats ...))) #`#,hash-name sf ;; these tests have to be true @@ -385,11 +350,6 @@ ks cert))))))))) - ((hash-table . pats) - (match:syntax-err - p - "improperly formed hash table pattern")) - ((struct struct-name (fields ...)) (identifier? (syntax struct-name)) (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))] diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss index f49592c77a..9afce7f0e9 100644 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -27,10 +27,21 @@ (provide simplify) + ;; simplifies patterns by removing syntactic sugar and expanding match-expanders ;; simplify : syntax certifier-> syntax - (define (simplify stx cert) + (define (simplify stx cert) + + ;; convert and check sub patterns for hash-table patterns + (define (convert-hash-table-pat pat) + (syntax-case pat () + [(p1 p2) #`(#,(simplify/i #'p1) #,(simplify/i #'p2))] + [i (and (identifier? #'i) (not (stx-dot-dot-k? #'i))) #'(var i)] + [_ (match:syntax-err pat "hash table subpattern must contain either two patterns or an identifier")])) + + ;; simple one-arg version, just passes the cert along (define (simplify/i stx) (simplify stx cert)) + (syntax-case* stx (_ list quote quasiquote vector box ? app and or not struct set! var @@ -65,54 +76,69 @@ [(quote data) stx] ;; transform quasi-patterns into regular patterns - [`quasi-pat (simplify (parse-quasi #'quasi-pat))] + [`quasi-pat (simplify/i (parse-quasi #'quasi-pat))] ;; predicate patterns with binders are redundant with and patterns [(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))] [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] + [(? . anything) + (match:syntax-err + stx + (if (null? (syntax-e #'anything)) + "a predicate pattern must have a predicate following the ?" + "syntax error in predicate pattern"))] ;; regexp patterns - FIXME: abstract here - [(regexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))] - [(pregexp re) (simplify (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))] - [(regexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))] - [(pregexp re pat) (simplify (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))] + [(regexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))] + [(pregexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))] + [(regexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))] + [(pregexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))] [(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")] [(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")] ;; cons is just list-rest with 2 arguments - [(cons p1 p2) (simplify (syntax/loc stx (list-rest p1 p2)))] + [(cons p1 p2) (simplify/i (syntax/loc stx (list-rest p1 p2)))] [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")] ;; aggregates - [(kw pats ...) + [(kw pats ...) (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) - (quasisyntax/loc stx (kw #,@(syntax-map simplify #'(pats ...))))] + (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]) + (syntax/loc stx (kw pats* ...)))] [(kw pats ... . rest) (match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))] ;; hash table patterns have their own syntax - [(hash-table (pat1 pat2) ...) - (with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] - [(pat2* ...) (syntax-map simplify #'(pat2 ...))]) - (syntax/loc stx (hash-table (pat1* pat2*) ...)))] - [(hash-table (pat1 pat2) ... ooo) + [(hash-table pats ... ooo) (stx-dot-dot-k? #'ooo) - (with-syntax ([(pat1* ...) (syntax-map simplify #'(pat1 ...))] - [(pat2* ...) (syntax-map simplify #'(pat2 ...))]) - (syntax/loc stx (hash-table (pat1* pat2*) ... ooo)))] + (with-syntax + ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))]) + (syntax/loc stx (hash-table pats* ... ooo)))] + [(hash-table pats ...) + (with-syntax + ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))]) + (syntax/loc stx (hash-table pats* ...)))] [(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")] ;; struct patterns - [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify #'(pats ...))] + [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))] [st* (cert #'st)]) (syntax/loc stx (struct st* (pats* ...))))] - [(struct . rest) (match:syntax-err stx "syntax error in struct pattern")] + [(struct . rest) + (match:syntax-err + stx + (if (null? (syntax-e #'rest)) + (format "~a~n~a~n~a" + "a structure pattern must have the name " + "of a defined structure followed by a list of patterns " + "to match each field of that structure") + "syntax error in structure pattern"))] - [(box pat) (quasisyntax/loc stx (box #,(simplify #'pat)))] + [(box pat) (quasisyntax/loc stx (box #,(simplify/i #'pat)))] [(box . rest) (match:syntax-err stx "syntax error in box pattern")] - [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify #'pat)))] + [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify/i #'pat)))] [(app . rest) (match:syntax-err stx "syntax error in app pattern")] [(set! id) @@ -125,9 +151,13 @@ stx] [(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")] - [(var . rest) (match:internal-err stx "var pattern found before simplification!")] + [(var id) + (identifier? #'id) + stx] + [(var . rest) + (match:syntax-err stx "var pattern must have one identifier")] - [_ stx]) + [__ stx]) ) From 34aa12ddac0be5e9730b9a8293e199dadb7b68aa Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 10 Sep 2006 21:24:35 -0400 Subject: [PATCH 07/14] Added expansion of match-expanders to macro-debugger. --- .../mzlib/private/match/simplify-patterns.ss | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss index 9afce7f0e9..77bf3c8ef7 100644 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -25,12 +25,53 @@ "test-no-order.ss" "match-helper.ss") + + (define current-expand-observe + (dynamic-require '#%expobs 'current-expand-observe)) + + (define (observe-step pre post) + (define (call-obs ev . args) + (let ([obs (current-expand-observe)]) + (if obs + (let ([evn (case ev + [(visit) 0] + [(enter-prim) 6] + [(prim-stop) 100] + [(exit-prim) 7] + [(return) 2] + [(macro-enter) 8] + [(macro-exit) 9] + [(macro-pre) 21] + [(macro-post) 22] + [(local-enter) 130] + [(local-exit) 131] + [(local-pre) 132] + [(local-post) 133])]) + (apply obs evn args))))) + + (call-obs 'local-enter pre) + (call-obs 'local-pre pre) + (call-obs 'visit pre) + (call-obs 'macro-enter pre) + (call-obs 'macro-pre pre) + (call-obs 'macro-post post) + (call-obs 'macro-exit post) + (call-obs 'visit post) + (call-obs 'enter-prim post) + (call-obs 'prim-stop #f) + (call-obs 'exit-prim post) + (call-obs 'return post) + (call-obs 'local-post post) + (call-obs 'local-exit post) + ) + (provide simplify) ;; simplifies patterns by removing syntactic sugar and expanding match-expanders ;; simplify : syntax certifier-> syntax (define (simplify stx cert) + ;; convert and check sub patterns for hash-table patterns (define (convert-hash-table-pat pat) @@ -62,6 +103,7 @@ [certifier (match-expander-certifier expander)] [result (introducer (transformer (introducer stx)))] [cert* (lambda (id) (certifier (cert id) #f introducer))]) + (observe-step stx result) (simplify result cert*)))] ;; label variable patterns From 7646ee635d75849153eb0319ea8f6abd6a89d172 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 11 Sep 2006 00:57:35 -0400 Subject: [PATCH 08/14] Show correctly marked results in stepper. --- collects/mzlib/private/match/simplify-patterns.ss | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss index 77bf3c8ef7..558e48f4aa 100644 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -29,7 +29,7 @@ (define current-expand-observe (dynamic-require '#%expobs 'current-expand-observe)) - (define (observe-step pre post) + (define (observe-step pre mpre mpost post) (define (call-obs ev . args) (let ([obs (current-expand-observe)]) (if obs @@ -53,8 +53,8 @@ (call-obs 'local-pre pre) (call-obs 'visit pre) (call-obs 'macro-enter pre) - (call-obs 'macro-pre pre) - (call-obs 'macro-post post) + (call-obs 'macro-pre mpre) + (call-obs 'macro-post mpost) (call-obs 'macro-exit post) (call-obs 'visit post) (call-obs 'enter-prim post) @@ -101,9 +101,11 @@ "This expander only works with the match.ss library.")) (let* ([introducer (make-syntax-introducer)] [certifier (match-expander-certifier expander)] - [result (introducer (transformer (introducer stx)))] + [mstx (introducer stx)] + [mresult (transformer mstx)] + [result (introducer mresult)] [cert* (lambda (id) (certifier (cert id) #f introducer))]) - (observe-step stx result) + (observe-step stx mstx mresult result) (simplify result cert*)))] ;; label variable patterns From ee63e4e80d6fd9f170a9cf32b9a10df15c94898e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 11 Sep 2006 15:43:50 -0400 Subject: [PATCH 09/14] Factor observe-step into separate file. Use observe step in match.ss match-expanders. --- collects/mzlib/private/match/convert-pat.ss | 19 ++++---- collects/mzlib/private/match/observe-step.ss | 43 +++++++++++++++++++ .../mzlib/private/match/simplify-patterns.ss | 41 +----------------- 3 files changed, 56 insertions(+), 47 deletions(-) create mode 100644 collects/mzlib/private/match/observe-step.ss diff --git a/collects/mzlib/private/match/convert-pat.ss b/collects/mzlib/private/match/convert-pat.ss index a3c1dceac2..49c092dce4 100644 --- a/collects/mzlib/private/match/convert-pat.ss +++ b/collects/mzlib/private/match/convert-pat.ss @@ -1,7 +1,8 @@ (module convert-pat mzscheme (require "match-error.ss" "match-helper.ss" - "match-expander-struct.ss") + "match-expander-struct.ss" + "observe-step.ss") (require-for-template mzscheme "match-error.ss") @@ -84,13 +85,15 @@ [xformer (match-expander-match-xform expander)]) (if (not xformer) (match:syntax-err #'expander - "This expander only works with plt-match.") - (let ([introducer (make-syntax-introducer)] - [certifier (match-expander-certifier expander)]) - (convert-pat/cert - (introducer (xformer (introducer stx))) - (lambda (id) - (certifier (cert id) #f introducer))))))] + "This expander only works with plt-match.ss.") + (let* ([introducer (make-syntax-introducer)] + [certifier (match-expander-certifier expander)] + [mstx (introducer stx)] + [mresult (xformer mstx)] + [result (introducer mresult)] + [cert* (lambda (id) (certifier (cert id) #f introducer))]) + (observe-step stx mstx mresult result) + (convert-pat/cert result cert*))))] [p (dot-dot-k? (syntax-object->datum #'p)) stx] diff --git a/collects/mzlib/private/match/observe-step.ss b/collects/mzlib/private/match/observe-step.ss new file mode 100644 index 0000000000..bb2cba7f0e --- /dev/null +++ b/collects/mzlib/private/match/observe-step.ss @@ -0,0 +1,43 @@ +(module observe-step mzscheme + (provide observe-step) + + (define current-expand-observe + (dynamic-require '#%expobs 'current-expand-observe)) + + (define (observe-step pre mpre mpost post) + (define (call-obs ev . args) + (let ([obs (current-expand-observe)]) + (if obs + (let ([evn (case ev + [(visit) 0] + [(enter-prim) 6] + [(prim-stop) 100] + [(exit-prim) 7] + [(return) 2] + [(macro-enter) 8] + [(macro-exit) 9] + [(macro-pre) 21] + [(macro-post) 22] + [(local-enter) 130] + [(local-exit) 131] + [(local-pre) 132] + [(local-post) 133])]) + (apply obs evn args))))) + + (call-obs 'local-enter pre) + (call-obs 'local-pre pre) + (call-obs 'visit pre) + (call-obs 'macro-enter pre) + (call-obs 'macro-pre mpre) + (call-obs 'macro-post mpost) + (call-obs 'macro-exit post) + (call-obs 'visit post) + (call-obs 'enter-prim post) + (call-obs 'prim-stop #f) + (call-obs 'exit-prim post) + (call-obs 'return post) + (call-obs 'local-post post) + (call-obs 'local-exit post) + ) + + ) \ No newline at end of file diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss index 558e48f4aa..fac49fa7d7 100644 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -11,7 +11,8 @@ "update-binding-counts.scm" "reorder-tests.scm" "match-expander-struct.ss" - "render-helpers.ss") + "render-helpers.ss" + "observe-step.ss") (require "render-sigs.ss" (lib "unitsig.ss")) @@ -26,44 +27,6 @@ "match-helper.ss") - (define current-expand-observe - (dynamic-require '#%expobs 'current-expand-observe)) - - (define (observe-step pre mpre mpost post) - (define (call-obs ev . args) - (let ([obs (current-expand-observe)]) - (if obs - (let ([evn (case ev - [(visit) 0] - [(enter-prim) 6] - [(prim-stop) 100] - [(exit-prim) 7] - [(return) 2] - [(macro-enter) 8] - [(macro-exit) 9] - [(macro-pre) 21] - [(macro-post) 22] - [(local-enter) 130] - [(local-exit) 131] - [(local-pre) 132] - [(local-post) 133])]) - (apply obs evn args))))) - - (call-obs 'local-enter pre) - (call-obs 'local-pre pre) - (call-obs 'visit pre) - (call-obs 'macro-enter pre) - (call-obs 'macro-pre mpre) - (call-obs 'macro-post mpost) - (call-obs 'macro-exit post) - (call-obs 'visit post) - (call-obs 'enter-prim post) - (call-obs 'prim-stop #f) - (call-obs 'exit-prim post) - (call-obs 'return post) - (call-obs 'local-post post) - (call-obs 'local-exit post) - ) (provide simplify) From b42e317e0c6da3870e598a0e99373a9c32c72d1a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 15 Sep 2006 12:12:10 -0400 Subject: [PATCH 10/14] Changed convert-pat to use syntax/loc. --- collects/mzlib/private/match/convert-pat.ss | 39 +++++++++++---------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/collects/mzlib/private/match/convert-pat.ss b/collects/mzlib/private/match/convert-pat.ss index 49c092dce4..a282bfa134 100644 --- a/collects/mzlib/private/match/convert-pat.ss +++ b/collects/mzlib/private/match/convert-pat.ss @@ -98,8 +98,8 @@ (dot-dot-k? (syntax-object->datum #'p)) stx] [_ stx] - [() #'(list)] - ['() #'(list)] + [() (syntax/loc stx (list))] + ['() (syntax/loc stx (list))] ['item stx] [p (let ((old-pat (syntax-e #'p))) @@ -108,40 +108,43 @@ (char? old-pat) (number? old-pat))) stx] - [(? pred) #`(? #,(cert #'pred))] + [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] [(? pred . a) (with-syntax ([pred (cert #'pred)] [pats (syntax-map convert-pat #'a)]) - #'(? pred . pats))] - [`pat #``#,(convert-quasi #'pat)] - [(= op pat) #`(app #,(cert #'op) #,(convert-pat #'pat))] + (syntax/loc stx (? pred . pats)))] + [`pat (quasisyntax/loc stx `#,(convert-quasi #'pat))] + [(= op pat) (quasisyntax/loc stx (app #,(cert #'op) #,(convert-pat #'pat)))] [(and . pats) (with-syntax ([new-pats (syntax-map convert-pat #'pats)]) - #'(and . new-pats))] + (syntax/loc stx (and . new-pats)))] [(or . pats) (with-syntax ([new-pats (syntax-map convert-pat #'pats)]) - #'(or . new-pats))] - [(not pat) #`(not #,(convert-pat #'pat))] + (syntax/loc stx (or . new-pats)))] + [(not . pats) + (with-syntax ([new-pats (syntax-map convert-pat #'pats)]) + (syntax/loc stx (not . new-pats)))] [($ struct-name . fields) (with-syntax ([struct-name (cert #'struct-name)] [new-fields (syntax-map convert-pat #'fields)]) - #'(struct struct-name new-fields))] + (syntax/loc stx (struct struct-name new-fields)))] [(get! id) (with-syntax ([id (cert #'id)]) - #'(get! id))] + (syntax/loc stx (get! id)))] [(set! id) (with-syntax ([id (cert #'id)]) - #'(set! id))] + (syntax/loc stx (set! id)))] [(quote p) stx] - [(car-pat . cdr-pat) - (let ([l (imp-list? (syntax-e stx) stx)]) - (if l #`(list-rest #,@(map convert-pat l)) - #`(list #,@(map convert-pat (syntax-e stx)))))] + ;; FIXME + [(elems ...) (quasisyntax/loc stx (list . #,(syntax-map convert-pat stx)))] + [(e elems ... . rest) + (quasisyntax/loc stx (list-rest #,@(syntax-map convert-pat #'(e elems ...)) + #,(convert-pat #'rest)))] [pt (vector? (syntax-e stx)) (with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))]) - #'(vector . new-pats))] + (syntax/loc stx (vector . new-pats)))] [pt (box? (syntax-e stx)) - #`(box #,(convert-pat (unbox (syntax-e stx))))] + (quasisyntax/loc stx (box #,(convert-pat (unbox (syntax-e stx)))))] [pt (identifier? stx) (cert stx)] From 086db937b823af89561089ba6ac87b5a94b5b8b7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 Sep 2006 13:01:04 -0400 Subject: [PATCH 11/14] pregexp can now return a regexp object. --- collects/mzlib/private/match/match-error.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mzlib/private/match/match-error.ss b/collects/mzlib/private/match/match-error.ss index f4e29e8a43..98bce3ea0c 100644 --- a/collects/mzlib/private/match/match-error.ss +++ b/collects/mzlib/private/match/match-error.ss @@ -67,6 +67,7 @@ ;; this makes pregexp errors a little more friendly (define (pregexp-match-with-error regex str) (if (or (string? regex) + (regexp? regex) (and (pair? regex) (equal? ':sub (car regex)))) (pregexp-match regex str) From a6f8fbe350bec4fa94184c7d4020a9b9bfe7a30a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 Sep 2006 14:31:17 -0400 Subject: [PATCH 12/14] Fix bug in conversion of dotted patterns. --- collects/mzlib/private/match/convert-pat.ss | 43 +++++++-------------- 1 file changed, 15 insertions(+), 28 deletions(-) diff --git a/collects/mzlib/private/match/convert-pat.ss b/collects/mzlib/private/match/convert-pat.ss index a282bfa134..07fe687d45 100644 --- a/collects/mzlib/private/match/convert-pat.ss +++ b/collects/mzlib/private/match/convert-pat.ss @@ -23,32 +23,20 @@ (with-syntax ([new-pats (syntax-map convert-pat stx)]) #'new-pats)) - (define (imp-list? x stx) + (define (imp-list? stx) + (define datum (syntax-e stx)) (define (keyword? x) - (member (syntax-object->datum x) - '( - quote - quasiquote - ? - = - and - or - not - $ - set! - get! - ;unquote - ;unquote-splicing - ))) + (memq (syntax-object->datum x) + '(quote quasiquote ? = and or not $ set! get!))) (let/ec out - (let loop ((x x)) - (cond ((null? x) (out #f)) - ((or (not (pair? x)) + (let loop ([x datum]) + (cond [(null? x) (out #f)] + [(or (not (pair? x)) (and (list? x) - (keyword? (car x)))) + (keyword? (car x)))) (list - (quasisyntax/loc stx #,x))) - (else (cons (car x) (loop (cdr x)))))))) + (quasisyntax/loc stx #,x))] + [else (cons (car x) (loop (cdr x)))])))) (define (convert-quasi stx) (syntax-case stx (unquote quasiquote unquote-splicing) @@ -133,12 +121,11 @@ [(set! id) (with-syntax ([id (cert #'id)]) (syntax/loc stx (set! id)))] [(quote p) stx] - ;; FIXME - [(elems ...) (quasisyntax/loc stx (list . #,(syntax-map convert-pat stx)))] - [(e elems ... . rest) - (quasisyntax/loc stx (list-rest #,@(syntax-map convert-pat #'(e elems ...)) - #,(convert-pat #'rest)))] - [pt + [(car-pat . cdr-pat) + (let ([l (imp-list? stx)]) + (if l (quasisyntax/loc stx (list-rest #,@(map convert-pat l))) + (quasisyntax/loc stx (list #,@(syntax-map convert-pat stx)))))] + [pt (vector? (syntax-e stx)) (with-syntax ([new-pats (map convert-pat (vector->list (syntax-e stx)))]) (syntax/loc stx (vector . new-pats)))] From 00383c4c5da9c04bc8f1797d48f9444e0ef08479 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 Sep 2006 11:02:15 -0400 Subject: [PATCH 13/14] convert-pat: - reformatting - use constant-data? render-test-list-impl: - reformatting - refactoring --- collects/mzlib/private/match/convert-pat.ss | 86 +++++++++---------- .../private/match/render-test-list-impl.ss | 71 +++++++-------- 2 files changed, 76 insertions(+), 81 deletions(-) diff --git a/collects/mzlib/private/match/convert-pat.ss b/collects/mzlib/private/match/convert-pat.ss index 07fe687d45..2f3938ac16 100644 --- a/collects/mzlib/private/match/convert-pat.ss +++ b/collects/mzlib/private/match/convert-pat.ss @@ -3,7 +3,7 @@ "match-helper.ss" "match-expander-struct.ss" "observe-step.ss") - + (require-for-template mzscheme "match-error.ss") @@ -11,61 +11,61 @@ ;; these functions convert the patterns from the old syntax ;; to the new syntax - + (define (handle-clause stx) (syntax-case stx () [(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))])) (define (handle-clauses stx) (syntax-map handle-clause stx)) - + (define (convert-pats stx) (with-syntax ([new-pats (syntax-map convert-pat stx)]) #'new-pats)) - (define (imp-list? stx) - (define datum (syntax-e stx)) - (define (keyword? x) - (memq (syntax-object->datum x) - '(quote quasiquote ? = and or not $ set! get!))) - (let/ec out - (let loop ([x datum]) - (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 (imp-list? stx) + (define datum (syntax-e stx)) + (define (keyword? x) + (memq (syntax-object->datum x) + '(quote quasiquote ? = and or not $ set! get!))) + (let/ec out + (let loop ([x datum]) + (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 (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])) - (define (convert-quasi stx) - (syntax-case stx (unquote quasiquote unquote-splicing) - [,pat #`,#,(convert-pat (syntax pat))] - [,@pat #`,@#,(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))) - (define (convert-pat stx) (convert-pat/cert stx (lambda (x) x))) - + (define (convert-pat/cert stx cert) (let ([convert-pat (lambda (x) (convert-pat/cert x cert))]) (syntax-case* stx - (_ ? = and or not $ set! get! quasiquote - quote unquote unquote-splicing) stx-equal? + (_ ? = and or not $ set! get! quasiquote + quote unquote unquote-splicing) stx-equal? [(expander . args) (and (identifier? #'expander) (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) @@ -89,13 +89,7 @@ [() (syntax/loc stx (list))] ['() (syntax/loc stx (list))] ['item stx] - [p - (let ((old-pat (syntax-e #'p))) - (or (string? old-pat) - (boolean? old-pat) - (char? old-pat) - (number? old-pat))) - stx] + [p (constant-data? (syntax-e stx)) stx] [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] [(? pred . a) (with-syntax ([pred (cert #'pred)] diff --git a/collects/mzlib/private/match/render-test-list-impl.ss b/collects/mzlib/private/match/render-test-list-impl.ss index 13a815fcd6..3a8759b99a 100644 --- a/collects/mzlib/private/match/render-test-list-impl.ss +++ b/collects/mzlib/private/match/render-test-list-impl.ss @@ -139,6 +139,7 @@ ;; then take the appropriate action. To understand this better take a ;; look at how proper and improper lists are handled. (define/opt (render-test-list p ae cert [stx #'here]) + (define ae-datum (syntax-object->datum ae)) (syntax-case* p (_ list quote quasiquote vector box ? app and or not struct set! var @@ -163,7 +164,7 @@ (certifier (cert id) #f introducer)) stx))))] - ;; underscore is reserved to match nothing + ;; underscore is reserved to match anything and bind nothing (_ '()) ;(ks sf bv let-bound)) ;; for variable patterns, we do bindings, and check if we've seen this variable before @@ -195,7 +196,7 @@ (constant-data? (syntax-e #'pt)) (list (reg-test - `(equal? ,(syntax-object->datum ae) + `(equal? ,ae-datum ,(syntax-object->datum (syntax pt))) ae (lambda (exp) #`(equal? #,exp pt))))] @@ -205,20 +206,20 @@ ;; match a quoted datum ;; this is very similar to the previous pattern, except for the second argument to equal? - ((quote item) + [(quote item) (list (reg-test - `(equal? ,(syntax-object->datum ae) + `(equal? ,ae-datum ,(syntax-object->datum p)) - ae (lambda (exp) #`(equal? #,exp #,p))))) + ae (lambda (exp) #`(equal? #,exp #,p))))] ;; check for predicate patterns ;; could we check to see if a predicate is a procedure here? - ((? pred?) + [(? pred?) (list (reg-test `(,(syntax-object->datum #'pred?) - ,(syntax-object->datum ae)) - ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))) + ,ae-datum) + ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))] ;; app patterns just apply their operation. ((app op pat) @@ -229,7 +230,7 @@ ((or . pats) (list (make-act - 'or-pat ;`(or-pat ,(syntax-object->datum ae)) + 'or-pat ;`(or-pat ,ae-datum) ae (lambda (ks kf let-bound) (lambda (sf bv) @@ -240,7 +241,7 @@ ((not pat) (list (make-act - 'not-pat ;`(not-pat ,(syntax-object->datum ae)) + 'not-pat ;`(not-pat ,ae-datum) ae (lambda (ks kf let-bound) (lambda (sf bv) @@ -266,7 +267,7 @@ (list (shape-test - `(list? ,(syntax-object->datum ae)) + `(list? ,ae-datum) ae (lambda (exp) #`(list? #,exp))) (make-act 'list-no-order @@ -316,7 +317,7 @@ #;(proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) (list (shape-test - `(hash-table? ,(syntax-object->datum ae)) + `(hash-table? ,ae-datum) ae (lambda (exp) #`(hash-table? #,exp))) (let ([mod-pat @@ -368,7 +369,7 @@ (shape-test `(struct-pred ,(syntax-object->datum pred) ,(map syntax-object->datum parental-chain) - ,(syntax-object->datum ae)) + ,ae-datum) ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp))) (map-append (lambda (cur-pat cur-mutator cur-accessor) @@ -384,7 +385,7 @@ (#,cur-accessor #,ae)))] [_ (render-test-list cur-pat - (quasisyntax/loc stx (#,cur-accessor #,ae)) + (quasisyntax/loc cur-pat (#,cur-accessor #,ae)) cert stx)])) field-pats mutators accessors)))) @@ -416,7 +417,7 @@ (stx-dot-dot-k? (syntax dot-dot-k))) (list (shape-test - `(list? ,(syntax-object->datum ae)) + `(list? ,ae-datum) ae (lambda (exp) #`(list? #,exp))) (make-act 'list-ddk-pat @@ -445,7 +446,7 @@ (stx-dot-dot-k? (syntax dot-dot-k))) (list (shape-test - `(pair? ,(syntax-object->datum ae)) + `(pair? ,ae-datum) ae (lambda (exp) #`(pair? #,exp))) (make-act 'list-ddk-pat @@ -471,7 +472,7 @@ (stx-dot-dot-k? (syntax car-pat)))) (cons (shape-test - `(pair? ,(syntax-object->datum ae)) + `(pair? ,ae-datum) ae (lambda (exp) #`(pair? #,exp))) (append (render-test-list (syntax car-pat) @@ -491,7 +492,7 @@ (stx-dot-dot-k? (syntax car-pat)))) (cons (shape-test - `(pair? ,(syntax-object->datum ae)) + `(pair? ,ae-datum) ae (lambda (exp) #`(pair? #,exp))) (append (render-test-list (syntax car-pat) @@ -511,7 +512,7 @@ (stx-dot-dot-k? (syntax car-pat)))) (cons (shape-test - `(pair? ,(syntax-object->datum ae)) + `(pair? ,ae-datum) ae (lambda (exp) #`(pair? #,exp))) (append (render-test-list (syntax car-pat) @@ -521,7 +522,7 @@ (if (stx-null? (syntax (cdr-pat ...))) (list (shape-test - `(null? (cdr ,(syntax-object->datum ae))) + `(null? (cdr ,ae-datum)) ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae))) (render-test-list (append-if-necc 'list (syntax (cdr-pat ...))) @@ -534,7 +535,7 @@ (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...)))) (list (shape-test - `(vector? ,(syntax-object->datum ae)) + `(vector? ,ae-datum) ae (lambda (exp) #`(vector? #,exp))) (make-act 'vec-ddk-pat @@ -546,7 +547,7 @@ cert))))) ;; vector pattern with ooo or ook, but not at end - ((vector pats ...) + [(vector pats ...) (let* ((temp (syntax-e (syntax (pats ...)))) (len (length temp))) (and (>= len 2) @@ -555,7 +556,7 @@ ;;(stx-dot-dot-k? (vector-ref temp (sub1 len)))))) (list (shape-test - `(vector? ,(syntax-object->datum ae)) + `(vector? ,ae-datum) ae (lambda (exp) #`(vector? #,exp))) ;; we have to look at the first pattern and see if a ddk follows it ;; if so handle that case else handle the pattern @@ -566,18 +567,18 @@ (handle-ddk-vector-inner ae kf ks #'#(pats ...) let-bound - cert))))) + cert))))] ;; plain old vector pattern - ((vector pats ...) - (let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...))))) - (vlen (vector-length syntax-vec))) + [(vector pats ...) + (let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))] + [vlen (vector-length syntax-vec)]) (list* (shape-test - `(vector? ,(syntax-object->datum ae)) ae + `(vector? ,ae-datum) ae (lambda (exp) #`(vector? #,exp))) (shape-test - `(equal? (vector-length ,(syntax-object->datum ae)) ,vlen) + `(equal? (vector-length ,ae-datum) ,vlen) ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen))) (let vloop ((n 0)) (if (= n vlen) @@ -588,21 +589,21 @@ #`(vector-ref #,ae #,n) cert stx) - (vloop (+ 1 n)))))))) + (vloop (+ 1 n)))))))] - ((box pat) + [(box pat) (cons (shape-test - `(box? ,(syntax-object->datum ae)) + `(box? ,ae-datum) ae (lambda (exp) #`(box? #,exp))) (render-test-list - #'pat #`(unbox #,ae) cert stx))) + #'pat #`(unbox #,ae) cert stx))] ;; This pattern wasn't a valid form. - (got-too-far + [got-too-far (match:syntax-err #'got-too-far - "syntax error in pattern")))) + "syntax error in pattern")])) ;; end of render-test-list@ )) From 0a5ff7fddd6dbbad9686396a53473d80067a5c53 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 Sep 2006 11:30:20 -0400 Subject: [PATCH 14/14] Fix bug in definition of match-define. --- collects/mzlib/private/match/match-internal-func.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/match/match-internal-func.ss b/collects/mzlib/private/match/match-internal-func.ss index 133961f8c7..ba119f7f0d 100644 --- a/collects/mzlib/private/match/match-internal-func.ss +++ b/collects/mzlib/private/match/match-internal-func.ss @@ -96,7 +96,7 @@ (set! **match-bound-vars** bv) (with-syntax ([((vars . vals) ...) (reverse bv)]) #'(begin (set! vars vals) ...))))] - [(vars ...) (reverse **match-bound-vars**)]) + [(vars ...) (map car (reverse **match-bound-vars**))]) #'(begin (define vars #f) ... (let ([the-exp exp])