suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

match phase clean-up and minor contract-expansion improvement

Browse Source 
svn: r232

original commit: e4a71a9b3c0975ce37000e7c971a143379b72182
This commit is contained in:
Matthew Flatt 2005-06-22 21:31:11 +00:00
parent 1d2fedc05a
commit a4bc5b8995
3 changed files with 29 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mzlib/contract.ss
View File

@ -2516,17 +2516,18 @@ add struct contracts for immutable structs?
(define-syntax (coerce/select-contract stx)
(syntax-case stx ()
[(_ name val)
(syntax
(let ([x val])
(cond
[(contract? x)
(contract-proc x)]
[(and (procedure? x) (procedure-arity-includes? x 1))
(contract-proc (flat-contract x))]
[else
(error 'name
"expected contract or procedure of arity 1, got ~e"
x)])))]))
(syntax (coerce/select-contract/proc 'name val))]))
(define (coerce/select-contract/proc name x)
(cond
[(contract? x)
(contract-proc x)]
[(and (procedure? x) (procedure-arity-includes? x 1))
(contract-proc (flat-contract x))]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
;; coerce-contract : id (union contract? procedure-arity-1) -> contract
;; contract-proc = sym sym stx -> alpha -> alpha
@ -2535,17 +2536,17 @@ add struct contracts for immutable structs?
(define-syntax (coerce-contract stx)
(syntax-case stx ()
[(_ name val)
(syntax
(let ([x val])
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
[else
(error 'name
"expected contract or procedure of arity 1, got ~e"
x)])))]))
(syntax (coerce-contract/proc 'name val))]))
(define (coerce-contract/proc name x)
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
;
;

11
collects/mzlib/match.ss
View File

@ -130,15 +130,16 @@
exn:misc:match-value
define-match-expander)
;; FIXME: match-helper and match-error should each be split
;; into a compile-time part and a run-time part.
(require-for-syntax "private/convert-pat.ss"
"private/match-helper.ss")
(require-for-template mzscheme (prefix plt: "private/match-internal-func.ss"))
(require (prefix plt: "private/match-internal-func.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
(define-syntax (match-lambda stx)
(syntax-case stx ()

4
collects/mzlib/plt-match.ss
View File

@ -138,7 +138,6 @@
match-let*
match-letrec
match-define
match:test-no-order
pregexp-match-with-error
exn:misc:match?
exn:misc:match-value
@ -148,8 +147,7 @@
(require "private/match-internal-func.ss"
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss"
"private/render-helpers.ss")
"private/match-error.ss")
)