From 00383c4c5da9c04bc8f1797d48f9444e0ef08479 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 Sep 2006 11:02:15 -0400 Subject: [PATCH] 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@ ))