diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 59708588..7f1ba924 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/check-subforms-unit.ss b/collects/typed-scheme/private/check-subforms-unit.ss index 1658e455..554bbea1 100644 --- a/collects/typed-scheme/private/check-subforms-unit.ss +++ b/collects/typed-scheme/private/check-subforms-unit.ss @@ -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]) diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index 83aa9c40..b5cd5378 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/infer-unit.ss b/collects/typed-scheme/private/infer-unit.ss index d04d5b36..b9590895 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -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) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index b1758d54..06b372ab 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -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 diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss index feb7129a..163fa343 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 69709e3e..3e44382e 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 dbbf0ec3..a4771751 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 19c9c9cb..2eb33e21 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)