From 85a0fa22d10e17df8a9d0dc1dcff56c2cc9a43a2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 2 Sep 2008 20:25:23 -0400 Subject: [PATCH] progress --- collects/typed-scheme/private/base-env.ss | 2 + collects/typed-scheme/private/extra-procs.ss | 7 ++- collects/typed-scheme/private/tc-app-unit.ss | 45 +++++++++++++++++-- collects/typed-scheme/private/tc-expr-unit.ss | 2 +- collects/typed-scheme/private/tc-utils.ss | 2 +- .../private/type-effect-convenience.ss | 3 +- collects/typed-scheme/typed-scheme.ss | 2 +- 7 files changed, 54 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 59708588b1..7f1ba92449 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -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 diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index 83aa9c4036..b5cd5378db 100644 --- a/collects/typed-scheme/private/extra-procs.ss +++ b/collects/typed-scheme/private/extra-procs.ss @@ -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) \ No newline at end of file +(define values* values) + +(define (foo x #:bar [bar #f]) + bar) \ No newline at end of file diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index 7451dd5cad..06b372ab90 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -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 @@ -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 @@ -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 diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss index feb7129a36..163fa34362 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/private/tc-expr-unit.ss @@ -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)))] diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss index 69709e3e46..3e44382e72 100644 --- a/collects/typed-scheme/private/tc-utils.ss +++ b/collects/typed-scheme/private/tc-utils.ss @@ -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*)]) diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index dbbf0ec393..a47717511a 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -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)) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 19c9c9cb7d..2eb33e2187 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -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)