fix some phase issues in 'match' implementation
svn: r9963
This commit is contained in:
Matthew Flatt
parent
00a5391be2
commit
d1628d6238
|
|
@ -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,7 +107,7 @@
|
|||
(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
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
|
|
@ -116,7 +116,7 @@
|
|||
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)))))
|
||||
(current-continuation-marks))))))
|
||||
(unit-deps unit)))
|
||||
|
||||
;; check-no-imports : unit symbol ->
|
||||
|
|
|
|||
|
|
@ -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 'fsig-name 'flnk-name))
|
||||
...)]
|
||||
[rht (hash-table 'equal
|
||||
[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))]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(module re mzscheme
|
||||
(require mzlib/match
|
||||
mzlib/list
|
||||
(require mzlib/list
|
||||
scheme/match
|
||||
(prefix is: mzlib/integer-set)
|
||||
"util.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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
29
collects/scheme/match/runtime.ss
Normal file
29
collects/scheme/match/runtime.ss
Normal file
|
|
@ -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)))
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user