fix some phase issues in 'match' implementation

svn: r9963

collects/mzlib/private/unit-runtime.ss

@@ -58,7 +58,7 @@
             (when (>= j 0)
               (let ([vj (vector-ref v j)])
                 (hash-table-put! t vj
-                                 (if (hash-table-get t vj (λ () #f))
+                                 (if (hash-table-get t vj #f)
                                      'amb
                                      #t)))
               (loop (sub1 j)))))
@@ -66,7 +66,7 @@
     (let loop ([i (sub1 (vector-length super-sig))])
       (when (>= i 0)
         (let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)]
-               [r (hash-table-get t v0 (λ () #f))])
+               [r (hash-table-get t v0 #f)])
           (when (or (eq? r 'amb) (not r))
             (let ([tag (if (pair? v0) (car v0) #f)]
                   [sub-name (car (vector-ref super-sig i))]
@@ -107,16 +107,16 @@
   (define (check-deps dep-table unit name)
     (for-each
      (λ (dep)
-       (define r (hash-table-get dep-table dep (λ () #f)))
+        (let ([r (hash-table-get dep-table dep #f)])
-       (when r
+          (when r
-         (raise
+            (raise
-          (make-exn:fail:contract
+             (make-exn:fail:contract
-           (if (car dep)
+              (if (car dep)
-             (format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
+                  (format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
-                     name (car r) (car dep) (cdr r))
+                          name (car r) (car dep) (cdr r))
-             (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
+                  (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
-                     name (car r) (cdr r)))
+                          name (car r) (cdr r)))
-           (current-continuation-marks)))))
+              (current-continuation-marks))))))
      (unit-deps unit)))
   
   ;; check-no-imports : unit symbol ->

collects/mzlib/unit.ss

@@ -344,6 +344,8 @@
         ((= n 0) acc)
         (else (loop (sub1 n) (cons (sub1 n) acc))))))
   
+  (define-syntax-rule (equal-hash-table [k v] ...)
+    (make-immutable-hash-table (list (cons k v) ...) 'equal))
 
   (define-syntax (unit-export stx)
     (syntax-case stx ()
@@ -356,7 +358,7 @@
                            (syntax->list esigs)))
                         (syntax->list #'((esig ...) ...))
                         (syntax->list #'(elocs ...)))))
-         #'(hash-table 'equal kv ... ...)))))
+         #'(equal-hash-table kv ... ...)))))
   
   ;; build-key : (or symbol #f) identifier -> syntax-object
   (define-for-syntax (build-key tag i)
@@ -379,7 +381,7 @@
      (lambda (tinfo s)
        (define key (cons (car tinfo)
                          (car (siginfo-ctime-ids (cdr tinfo)))))
-       (when (hash-table-get import-idx key (lambda () #f))
+       (when (hash-table-get import-idx key #f)
          (raise-stx-err "duplicate import signature" s))
        (hash-table-put! import-idx key #t))
      tagged-siginfos
@@ -389,7 +391,7 @@
        (unless (hash-table-get import-idx
                                (cons (car dep)
                                      (car (siginfo-ctime-ids (cdr dep))))
-                               (lambda () #f))
+                               #f)
          (raise-stx-err "initialization dependency on unknown import" s)))
      tagged-deps
      dsources))
@@ -1087,18 +1089,18 @@
                                                               (vector-immutable sub-out-key ...))
                                                         ...)
                                                        'form))
-                                       (let ([fht (hash-table 'equal
+                                       (let ([fht (equal-hash-table
-                                                              ((cons 'fdep-tag fdep-rtime)
+                                                   ((cons 'fdep-tag fdep-rtime)
-                                                               (cons 'fsig-name 'flnk-name))
+                                                    (cons 'fsig-name 'flnk-name))
-                                                              ...)]
+                                                   ...)]
-                                             [rht (hash-table 'equal
+                                             [rht (equal-hash-table
-                                                              ((cons 'rdep-tag rdep-rtime)
+                                                   ((cons 'rdep-tag rdep-rtime)
-                                                               #t)
+                                                    #t)
-                                                              ...)])
+                                                   ...)])
                                          #,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form))
                                          (for-each
                                           (lambda (dep)
-                                            (when (hash-table-get rht dep (lambda () #f))
+                                            (when (hash-table-get rht dep #f)
                                               (set! deps (cons dep deps))))
                                           (unit-deps sub-tmp)))))))
                              (syntax->list #'((sub-exp
@@ -1137,7 +1139,7 @@
                                     ...)
                          (values (lambda (import-table-id)
                                    (void)
-                                   (sub-tmp (hash-table 'equal sub-in-key-code-workaround ...))
+                                   (sub-tmp (equal-hash-table sub-in-key-code-workaround ...))
                                    ...)
                                  (unit-export ((export-key ...) export-code) ...)))))))
                 (map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))
@@ -1478,7 +1480,7 @@
           (lambda (b)
             (for-each
              (lambda (cid)
-               (define there? (hash-table-get sig-table cid (lambda () #f)))
+               (define there? (hash-table-get sig-table cid #f))
                (hash-table-put! sig-table cid (if there? 'duplicate (link-record-linkid b))))
              (siginfo-ctime-ids (link-record-siginfo b))))
           link-defs)
@@ -1529,7 +1531,7 @@
                       (let ([lnkid (hash-table-get
                                     sig-table
                                     (car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid)))))
-                                    (lambda () #f))])
+                                    #f)])
                         (cond
                           [(not lnkid)
                            (raise-stx-err "no sub unit exports this signature" (cdr tid))]

collects/parser-tools/private-lex/re.ss

@@ -1,6 +1,6 @@
 (module re mzscheme
-  (require mzlib/match
+  (require mzlib/list
-           mzlib/list
+           scheme/match
            (prefix is: mzlib/integer-set)
            "util.ss")
   

collects/scheme/match/compiler.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require (for-template scheme/base "patterns.ss" scheme/stxparam)
+(require (for-template scheme/base "runtime.ss" scheme/stxparam)
          syntax/boundmap
          syntax/stx
          "patterns.ss"

collects/scheme/match/gen-match.ss

@@ -2,7 +2,7 @@
 
 (require "patterns.ss" "compiler.ss"
          syntax/stx scheme/nest
-         (for-template scheme/base (only-in "patterns.ss" match:error)))
+         (for-template scheme/base (only-in "runtime.ss" match:error)))
 
 (provide go)
 

collects/scheme/match/legacy-match.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
 
-(require (only-in "patterns.ss"
+(require (only-in "runtime.ss"
                   match-equality-test
-                  match-...-nesting
                   exn:misc:match?)
          (only-in "match-expander.ss"
                   define-match-expander)
@@ -13,7 +12,6 @@
 
 (provide (for-syntax match-...-nesting)
          match-equality-test
-         match-...-nesting
          define-match-expander
          exn:misc:match?)
 

collects/scheme/match/match-expander.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require (for-syntax scheme/base)
+(require (for-syntax scheme/base
-         (for-syntax "patterns.ss"))
+                     "patterns.ss"))
 
 (provide define-match-expander)
 

collects/scheme/match/match.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
 
-(require (only-in "patterns.ss"
+(require (only-in "runtime.ss"
                   match-equality-test
-                  match-...-nesting
                   exn:misc:match?)
          (only-in "match-expander.ss"
                   define-match-expander)
@@ -13,7 +12,6 @@
 
 (provide (for-syntax match-...-nesting)
          match-equality-test
-         match-...-nesting
          define-match-expander
          exn:misc:match?)
 

collects/scheme/match/parse-helper.ss

@@ -9,7 +9,7 @@
          (only-in srfi/1 delete-duplicates))
 
 (provide ddk? parse-literal all-vars pattern-var? match:syntax-err
-         match-expander-transform matchable? trans-match parse-struct
+         match-expander-transform trans-match parse-struct
          dd-parse parse-quote parse-id)
 
 ;; parse x as a match variable
@@ -138,10 +138,6 @@
            [cert* (lambda (id) (certifier (cert id) #f introducer))])
       (parse/cert result cert*))))
 
-;; can we pass this value to regexp-match?
-(define (matchable? e)
-  (or (string? e) (bytes? e)))
-
 ;; raise an error, blaming stx
 (define (match:syntax-err stx msg)
   (raise-syntax-error #f msg stx))

collects/scheme/match/parse.ss

@@ -1,15 +1,15 @@
 #lang scheme/base
 
-(require (for-template scheme/base "parse-helper.ss")
+(require syntax/boundmap
-         syntax/boundmap
          syntax/stx
          scheme/struct-info
          "patterns.ss"
          "compiler.ss"
          "parse-helper.ss"
          "parse-quasi.ss"
-         "match-expander.ss"
+         (only-in srfi/1 delete-duplicates)
-         (only-in srfi/1 delete-duplicates))
+         (for-template (only-in "runtime.ss" matchable?)
+                       scheme/base))
 
 (provide parse/cert)
 

collects/scheme/match/patterns.ss

@@ -1,23 +1,13 @@
 #lang scheme/base
 
 (require syntax/boundmap
-         scheme/stxparam
          scheme/contract
          (for-syntax scheme/base))
 
 (provide (except-out (all-defined-out)
                      struct-key-ht
                      get-key
-                     (struct-out Row)
+                     (struct-out Row)))
-                     (struct-out exn:misc:match))
-         exn:misc:match?)
-
-(define-struct (exn:misc:match exn:fail) (value))
-
-(define (match:error val)
-  (raise (make-exn:misc:match (format "match: no matching clause for ~e" val)
-                              (current-continuation-marks)
-                              val)))
 
 (define orig-stx (make-parameter #f))
 
@@ -186,12 +176,6 @@
     [else (error 'match "bad pattern: ~a" p)]))
 
 (define match-...-nesting (make-parameter 0))
-(define match-equality-test (make-parameter equal?))
-
-(define-syntax-parameter fail
-  (lambda (stx)
-    (raise-syntax-error
-     #f "used out of context: not in match pattern" stx)))
 
 (define current-renaming (make-parameter (make-free-identifier-mapping)))
 

collects/scheme/match/runtime.ss

@@ -0,0 +1,29 @@
+#lang scheme/base
+
+(require scheme/stxparam
+         (for-syntax scheme/base))
+
+(provide match-equality-test
+         exn:misc:match?
+         match:error
+         fail
+         matchable?)
+
+(define match-equality-test (make-parameter equal?))
+
+(define-struct (exn:misc:match exn:fail) (value))
+
+(define (match:error val)
+  (raise (make-exn:misc:match (format "match: no matching clause for ~e" val)
+                              (current-continuation-marks)
+                              val)))
+
+(define-syntax-parameter fail
+  (lambda (stx)
+    (raise-syntax-error
+     #f "used out of context: not in match pattern" stx)))
+
+;; can we pass this value to regexp-match?
+(define (matchable? e)
+  (or (string? e) (bytes? e)))
+

collects/typed-scheme/private/base-env.ss

@@ -5,7 +5,7 @@
  "extra-procs.ss"
  (only-in scheme/list cons? take drop add-between last)
  '#%paramz
- (only-in scheme/match/patterns match:error))
+ (only-in scheme/match/runtime match:error))
 
 ;; these are all for constructing the types given to variables
 (require (for-syntax