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

Checkpoint.

Browse Source 
original commit: dfdfae95d7d16ef3fa97503cfa0156101dc275b3
This commit is contained in:
Sam Tobin-Hochstadt 2008-06-17 18:10:17 -04:00
parent 4853428482
commit 4271f734a6
3 changed files with 18 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/typed-scheme/private/parse-type.ss
View File

@ -73,7 +73,7 @@
(make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty)))]
[(dom ... rest ::: -> rng)
(and (eq? (syntax-e #'->) '->)
(symbolic-identifier=? #'::: (quote-syntax *)))
(eq? (syntax-e #':::) '*))
(begin
(add-type-name-reference #'->)
(->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-type #'rng)))]
@ -106,17 +106,12 @@
(-values (map parse-type (syntax->list #'(tys ...))))]
[(case-lambda tys ...)
(eq? (syntax-e #'case-lambda) 'case-lambda)
(make-Function (map (lambda (ty)
(syntax-case* ty (->) symbolic-identifier=?
[(dom ... -> rng)
(make-arr
(map parse-type (syntax->list #'(dom ...)))
(parse-type #'rng))]))
(syntax->list #'(tys ...))))]
;; I wish I could write this
#;[(case-lambda ([dom ... -> rng] ...)) (make-funty (list (make-arr (list (parse-type #'dom) ...) (parse-type #'rng)) ...))]
#;[(list-of t) (make-lst (parse-type #'t))]
#;[(Listof t) (make-lst (parse-type #'t))]
(make-Function
(for/list ([ty (syntax->list #'(tys ...))])
(let ([t (parse-type ty)])
(match t
[(Function: (list arr)) arr]
[_ (tc-error/stx ty "Component of case-lambda type was not a function clause")]))))]
[(Vectorof t)
(eq? (syntax-e #'Vectorof) 'Vectorof)
(begin

3
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -249,8 +249,5 @@
(exit t)))]
[_ (exit t)]))))
(define (tc-error/expr msg #:return [return (Un)] #:stx [stx (current-orig-stx)] . rest)
(tc-error/delayed #:stx stx (apply format msg rest))
return)

13
collects/typed-scheme/private/type-utils.ss
View File

@ -23,7 +23,9 @@
unfold
(struct-out Dotted)
(struct-out DottedBoth)
just-Dotted?)
just-Dotted?
tc-error/expr
lookup-fail)
;; substitute : Type Name Type -> Type
@ -139,4 +141,11 @@
(define (just-Dotted? S)
(and (Dotted? S)
(not (DottedBoth? S))))
(not (DottedBoth? S))))
(define (tc-error/expr msg #:return [return (make-Union null)] #:stx [stx (current-orig-stx)] . rest)
(tc-error/delayed #:stx stx (apply format msg rest))
return)
;; error for unbound variables
(define (lookup-fail e) (tc-error/expr "unbound identifier ~a" e))