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

Generate -> instead of ->* when required by case->.

Browse Source 
Closes PR 10977.
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-13 14:50:33 -04:00
parent d4d286d31d
commit cf5c74a2ca
3 changed files with 20 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/fail/all-bad-syntax.rkt
View File

@ -1,5 +1,5 @@
#; #;
(exn-pred 1) (exn-pred 2)
#lang typed-scheme #lang typed-scheme
(require scheme/list) (require scheme/list)

8
collects/tests/typed-scheme/succeed/provide-case-rest.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/racket
(provide foo)
(define foo
(case-lambda:
(((x : Number)) x)
(((x : Number) (y : Number) z : Number *) y)))

13
collects/typed-scheme/private/type-contract.rkt
View File

@ -64,7 +64,7 @@
[(Function: arrs) [(Function: arrs)
(when flat? (exit (fail))) (when flat? (exit (fail)))
(let () (let ()
(define (f a) (define ((f [case-> #f]) a)
(define-values (dom* opt-dom* rngs* rst) (define-values (dom* opt-dom* rngs* rst)
(match a (match a
;; functions with no filters or objects ;; functions with no filters or objects
@ -91,16 +91,21 @@
[(list r) r] [(list r) r]
[_ #`(values #,@rngs*)])] [_ #`(values #,@rngs*)])]
[rst* rst]) [rst* rst])
;; Garr, I hate case->!
(if (and (pair? (syntax-e #'(opt-dom* ...))) case->)
(exit (fail))
(if (or rst (pair? (syntax-e #'(opt-dom* ...)))) (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
#'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*) (if case->
#'(dom* ... . -> . rng*)))) #'(dom* ... #:rest (listof rst*) . -> . rng*)
#'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*))
#'(dom* ... . -> . rng*)))))
(unless (no-duplicates (for/list ([t arrs]) (unless (no-duplicates (for/list ([t arrs])
(match t (match t
[(arr: dom _ _ _ _) (length dom)] [(arr: dom _ _ _ _) (length dom)]
;; is there something more sensible here? ;; is there something more sensible here?
[(top-arr:) (int-err "got top-arr")]))) [(top-arr:) (int-err "got top-arr")])))
(exit (fail))) (exit (fail)))
(match (map f arrs) (match (map (f (not (= 1 (length arrs)))) arrs)
[(list e) e] [(list e) e]
[l #`(case-> #,@l)]))] [l #`(case-> #,@l)]))]
[_ (int-err "not a function" f)])) [_ (int-err "not a function" f)]))