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

Allow filters/objects to be provided to untyped code.

Browse Source 
svn: r15706
This commit is contained in:
Sam Tobin-Hochstadt 2009-08-11 21:00:57 +00:00
parent c27783830a
commit 50545830f2
2 changed files with 6 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/private/type-contract.ss
View File

@ -48,7 +48,7 @@
(= (length l) (length (remove-duplicates l)))) (= (length l) (length (remove-duplicates l))))
(define (type->contract ty fail) (define (type->contract ty fail #:out [out? #f])
(define vars (make-parameter '())) (define vars (make-parameter '()))
(let/ec exit (let/ec exit
(let loop ([ty ty] [pos? #t]) (let loop ([ty ty] [pos? #t])
@ -78,6 +78,10 @@
(match a (match a
[(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '()) [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '())
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))]
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
(if (and out? pos?)
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))
(exit (fail)))]
[_ (exit (fail))])) [_ (exit (fail))]))
(trace f) (trace f)
(with-syntax (with-syntax

2
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -53,7 +53,7 @@
(lambda (b) (lambda (b)
(with-syntax ([id internal-id] (with-syntax ([id internal-id]
[out-id external-id]) [out-id external-id])
(cond [(type->contract (def-binding-ty b) (lambda () #f)) (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
=> =>
(lambda (cnt) (lambda (cnt)
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]) (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))])