From d1628d623897acc07bb14d01507f4539849e907a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 26 May 2008 19:51:06 +0000 Subject: [PATCH] fix some phase issues in 'match' implementation svn: r9963 --- collects/mzlib/private/unit-runtime.ss | 24 ++++++++--------- collects/mzlib/unit.ss | 32 ++++++++++++----------- collects/parser-tools/private-lex/re.ss | 4 +-- collects/scheme/match/compiler.ss | 2 +- collects/scheme/match/gen-match.ss | 2 +- collects/scheme/match/legacy-match.ss | 4 +-- collects/scheme/match/match-expander.ss | 4 +-- collects/scheme/match/match.ss | 4 +-- collects/scheme/match/parse-helper.ss | 6 +---- collects/scheme/match/parse.ss | 8 +++--- collects/scheme/match/patterns.ss | 18 +------------ collects/scheme/match/runtime.ss | 29 ++++++++++++++++++++ collects/typed-scheme/private/base-env.ss | 2 +- 13 files changed, 73 insertions(+), 66 deletions(-) create mode 100644 collects/scheme/match/runtime.ss diff --git a/collects/mzlib/private/unit-runtime.ss b/collects/mzlib/private/unit-runtime.ss index 3e99c7cf69..c9c2010ece 100644 --- a/collects/mzlib/private/unit-runtime.ss +++ b/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))) - (when r - (raise - (make-exn:fail:contract - (if (car dep) - (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)) - (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a" - name (car r) (cdr r))) - (current-continuation-marks))))) + (let ([r (hash-table-get dep-table dep #f)]) + (when r + (raise + (make-exn:fail:contract + (if (car dep) + (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)) + (format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a" + name (car r) (cdr r))) + (current-continuation-marks)))))) (unit-deps unit))) ;; check-no-imports : unit symbol -> diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index ff1d6347c6..11ef796fb2 100644 --- a/collects/mzlib/unit.ss +++ b/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 - ((cons 'fdep-tag fdep-rtime) - (cons 'fsig-name 'flnk-name)) - ...)] - [rht (hash-table 'equal - ((cons 'rdep-tag rdep-rtime) - #t) - ...)]) + (let ([fht (equal-hash-table + ((cons 'fdep-tag fdep-rtime) + (cons 'fsig-name 'flnk-name)) + ...)] + [rht (equal-hash-table + ((cons 'rdep-tag rdep-rtime) + #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))] diff --git a/collects/parser-tools/private-lex/re.ss b/collects/parser-tools/private-lex/re.ss index 2400933ccb..3eaf3a73fe 100644 --- a/collects/parser-tools/private-lex/re.ss +++ b/collects/parser-tools/private-lex/re.ss @@ -1,6 +1,6 @@ (module re mzscheme - (require mzlib/match - mzlib/list + (require mzlib/list + scheme/match (prefix is: mzlib/integer-set) "util.ss") diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss index e586f1f68f..1b44b510f5 100644 --- a/collects/scheme/match/compiler.ss +++ b/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" diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss index e121a8a184..6dfdc2a4f0 100644 --- a/collects/scheme/match/gen-match.ss +++ b/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) diff --git a/collects/scheme/match/legacy-match.ss b/collects/scheme/match/legacy-match.ss index cbd9540797..e8e0bf2ef6 100644 --- a/collects/scheme/match/legacy-match.ss +++ b/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?) diff --git a/collects/scheme/match/match-expander.ss b/collects/scheme/match/match-expander.ss index 9477148a66..54221b18c5 100644 --- a/collects/scheme/match/match-expander.ss +++ b/collects/scheme/match/match-expander.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require (for-syntax scheme/base) - (for-syntax "patterns.ss")) +(require (for-syntax scheme/base + "patterns.ss")) (provide define-match-expander) diff --git a/collects/scheme/match/match.ss b/collects/scheme/match/match.ss index 9e050a6bb3..f7323367ba 100644 --- a/collects/scheme/match/match.ss +++ b/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?) diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss index 2c8304f8cd..73eb8c705c 100644 --- a/collects/scheme/match/parse-helper.ss +++ b/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)) diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss index 78d376b9be..468d0d9366 100644 --- a/collects/scheme/match/parse.ss +++ b/collects/scheme/match/parse.ss @@ -1,15 +1,15 @@ #lang scheme/base -(require (for-template scheme/base "parse-helper.ss") - syntax/boundmap +(require 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) diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss index e0ae6be6a1..4ddbb9916d 100644 --- a/collects/scheme/match/patterns.ss +++ b/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 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))) + (struct-out Row))) (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))) diff --git a/collects/scheme/match/runtime.ss b/collects/scheme/match/runtime.ss new file mode 100644 index 0000000000..dc121ee2a2 --- /dev/null +++ b/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))) + diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 0d11d6a6a6..c6136b75c9 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/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