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

progress

Browse Source 
original commit: 85a0fa22d10e17df8a9d0dc1dcff56c2cc9a43a2
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-02 20:25:23 -04:00
parent 7b3ad3a27f
commit aa2a031828
9 changed files with 72 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/base-env.ss
View File

@ -555,6 +555,8 @@
[values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
[call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
[foo (make-Function (list (make-arr (list N) B #f #f (list (cons '#:bar B)) null null)))]
)
(begin-for-syntax

2
collects/typed-scheme/private/check-subforms-unit.ss
View File

@ -21,7 +21,7 @@
(define body-ty #f)
(define (get-result-ty t)
(match t
[(Function: (list (arr: _ rngs #f _ _ _) ...)) (apply Un rngs)]
[(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)]
[_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)]))
(let loop ([form form])
(parameterize ([current-orig-stx form])

7
collects/typed-scheme/private/extra-procs.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base
(provide assert call-with-values* values*)
(provide assert call-with-values* values* foo)
(define (assert v)
(unless v
@ -15,4 +15,7 @@
(car as) (map car bss))))
(define call-with-values* call-with-values)
(define values* values)
(define values* values)
(define (foo x #:bar [bar #f])
bar)

6
collects/typed-scheme/private/infer-unit.ss
View File

@ -146,7 +146,7 @@
(gensym dbound))]
[new-tys (for/list ([var vars])
(substitute (make-F var) dbound dty))]
[new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)])
[new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)])
(move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f #f '() t-thn-eff t-els-eff)
(arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff))
@ -159,7 +159,7 @@
(gensym dbound))]
[new-tys (for/list ([var vars])
(substitute (make-F var) dbound dty))]
[new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))])
[new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))])
(move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
@ -205,7 +205,7 @@
[new-tys (for/list ([var vars])
(substitute (make-F var) dbound s-dty))]
[new-cset (cgen/arr V (append vars X) t-arr
(make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))])
(make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))])
(move-vars+rest-to-dmap new-cset dbound vars)))]
;; If dotted <: starred is correct, add it below. Not sure it is.
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)

73
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -159,7 +159,7 @@
(define-values (fixed-args tail) (split (syntax->list args)))
(match f-ty
[(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...)))
[(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...)))
(when (null? doms)
(tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply"))
@ -204,7 +204,7 @@
(printf/log "Non-poly apply, ... arg\n")
(ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1))))
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
@ -214,7 +214,7 @@
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1))))
[(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
@ -259,14 +259,14 @@
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1))))
(Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1))))
[(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
@ -378,8 +378,8 @@
(define (poly-fail t argtypes #:name [name #f])
(match t
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))))
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))))
(let ([fcn-string (if name
(format "function ~a (over ~~a)" (syntax->datum name))
"function over ~a")])
@ -429,7 +429,8 @@
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtypes))])]
;; single clause functions
[(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs))))
;; FIXME - error on non-optional keywords
[(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs))))
thn-eff els-eff)
(let-values ([(thn-eff els-eff)
(tc-args argtypes arg-thn-effs arg-els-effs dom rest
@ -437,7 +438,7 @@
(syntax->list args))])
(ret rng thn-eff els-eff))]
;; non-polymorphic case-lambda functions
[(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1)))
[(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1)))
thn-eff els-eff)
(let loop ([doms* doms] [rngs rngs] [rests* rests])
(cond [(null? doms*)
@ -453,19 +454,19 @@
;; simple polymorphic functions, no rest arguments
[(tc-result: (and t
(or (Poly: vars
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))
(PolyDots: (list vars ... _)
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))))))
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))))))
(handle-clauses (doms rngs) f-stx
(lambda (dom _) (= (length dom) (length argtypes)))
(lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected))
t argtypes expected)]
;; polymorphic varargs
[(tc-result: (and t
(or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))
(or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))
;; we want to infer the dotted-var here as well, and we don't use these separately
;; so we can just use "vars" instead of (list fixed-vars ... dotted-var)
(PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))))))
(PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))))))
(printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms rests rngs) f-stx
(lambda (dom rest rng) (<= (length dom) (length argtypes)))
@ -474,7 +475,7 @@
;; polymorphic ... type
[(tc-result: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...)))))
(Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...)))))
(printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms dtys dbounds rngs) f-stx
(lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes))
@ -566,6 +567,32 @@
[(tc-result: t)
(tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
(define (tc-keywords form arities kws kw-args pos-args expected)
(match arities
[(list (arr: dom rng rest #f (list (and ktys (cons formal-kws formal-kw-tys)) ...) _ _))
(for ([k kws]
[ty (map tc-expr/t (syntax->list kw-args))])
(cond [(assq k ktys)
=>
(match-lambda [(cons k kty)
(unless (subtype ty kty)
(tc-error/delayed
#:stx form
"Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
kty ty k))])]
[else
(tc-error/expr #:return (ret (Un))
"function does not accept keyword argument ~a" k)]))
(tc/funapp #'form #'form (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)]
[_ (int-err "case-lambda w/ keywords not supported")]))
(define (type->list t)
(match t
[(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))]
[(Value: '()) null]
[_ (int-err "bad value in type->list: ~a" t)]))
(define (tc/app/internal form expected)
(kernel-syntax-case* form #f
(values apply not list list* call-with-values do-make-object make-object cons
@ -585,7 +612,7 @@
[(Values: ts) ts]
[_ (list t)]))
(match prod-t
[(Function: (list (arr: (list) vals _ #f _ _)))
[(Function: (list (arr: (list) vals _ #f '() _ _)))
(tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
[_ (tc-error/expr #:return (ret (Un))
"First argument to call with values must be a function that can accept no arguments, got: ~a"
@ -621,11 +648,23 @@
[(tc-result: t thn-eff els-eff)
(ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
;; special case for `apply'
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
;; special case for keywords
[(#%plain-app
(#%plain-app kpe kws num fn)
kw-list
(#%plain-app list . kw-arg-list)
. pos-args)
(eq? (syntax-e #'kpe) 'keyword-procedure-extract)
(match (tc-expr #'fn)
[(tc-result: (Function: arities))
(tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
[t (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" t)])]
;; even more special case for match
[(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
(and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))
(let-loop-check #'form #'lp #'actuals #'args #'body expected)]
(let-loop-check form #'lp #'actuals #'args #'body expected)]
;; or/andmap of ... argument
[(#%plain-app or/andmap f arg)
(and

2
collects/typed-scheme/private/tc-expr-unit.ss
View File

@ -41,7 +41,7 @@
[(null? v) (-val null)]
[(symbol? v) (-val v)]
[(string? v) -String]
[(keyword? v) -Keyword]
[(keyword? v) (-val v)]
[(bytes? v) -Bytes]
[(list? v) (-Tuple (map tc-literal v))]
[(vector? v) (make-Vector (types-of-literals (vector->list v)))]

2
collects/typed-scheme/private/tc-utils.ss
View File

@ -70,7 +70,7 @@
(unless (null? stxs)
(raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))]))
(define delay-errors? (make-parameter #t))
(define delay-errors? (make-parameter #f))
(define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest)
(let ([stx (locate-stx stx*)])

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

@ -82,7 +82,8 @@
(case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))]
[(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
[(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
[(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]))
[(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]
[(dom rng rest drest kws eff1 eff2) (make-arr dom rng rest drest kws eff1 eff2)]))
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #f (cons dty dbound) null null))

2
collects/typed-scheme/typed-scheme.ss
View File

@ -31,7 +31,7 @@
(provide (rename-out [module-begin #%module-begin]
[top-interaction #%top-interaction]
[#%plain-lambda lambda]
[#%plain-app #%app]
[#%app #%app]
[require require]))
(define-for-syntax catch-errors? #f)