diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index ad372fa7..92054adb 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -510,10 +510,11 @@ ;; just return a boolean result (define (infer X Y S T R must-vars must-idxs [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) - (let ([cs (cgen/list null X Y S T)]) - (if (not expected) - (subst-gen cs R (append must-vars must-idxs)) - (subst-gen (cset-meet cs (cgen null X Y R expected)) R must-vars))))) + (let* ([cs (cgen/list null (append X Y) S T)] + [cs* (if expected + (cset-meet cs (cgen null (append X Y) R expected)) + cs)]) + (subst-gen cs* R (append must-vars must-idxs))))) ;; like infer, but T-var is the vararg type: (define (infer/vararg X Y S T T-var R must-vars must-idxs [expected #f]) diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-scheme/infer/restrict.rkt index 6e45ac59..9779332f 100644 --- a/collects/typed-scheme/infer/restrict.rkt +++ b/collects/typed-scheme/infer/restrict.rkt @@ -23,7 +23,7 @@ [(subtype t1 t2) t1] ;; already a subtype [(match t2 [(Poly: vars t) - (let ([subst (infer vars (list t1) (list t) t1 vars)]) + (let ([subst (infer vars null (list t1) (list t) t1 (fv t1) (fi t1))]) (and subst (restrict* t1 (subst-all subst t1))))] [_ #f])] [(Union? t1) (union-map (lambda (e) (restrict* e t2)) t1)] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 87fa124a..11cdf7f3 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -319,26 +319,28 @@ (not tail-bound) (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg vars null (cons tail-ty arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) + (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg vars null (cons (make-Listof tail-ty) arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) + (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg [(and (car drests*) @@ -346,7 +348,8 @@ (eq? tail-bound (cdr (car drests*))) (= (length (car doms*)) (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + (infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) + (car rngs*) (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] @@ -373,26 +376,26 @@ (not tail-bound) (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg fixed-vars (list dotted-var) (cons tail-ty arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg fixed-vars (list dotted-var) (cons (make-Listof tail-ty) arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, same bound on ... @@ -401,7 +404,11 @@ (eq? tail-bound (cdr (car drests*))) (= (length (car doms*)) (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + (infer fixed-vars (list dotted-var) + (cons tail-ty arg-tys) + (cons (car (car drests*)) (car doms*)) + (car rngs*) + (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, different bound on ... @@ -413,7 +420,11 @@ (extend-tvars (list tail-bound (cdr (car drests*))) (extend-indexes (cdr (car drests*)) ;; don't need to add tail-bound - it must already be an index - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))) + (infer fixed-vars (list dotted-var) + (cons tail-ty arg-tys) + (cons (car (car drests*)) (car doms*)) + (car rngs*) + (fv (car rngs*)) (fi (car rngs*)))))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) (do-ret (substitute-dotted (cadr (assq drest-bound substitution)) @@ -610,7 +621,7 @@ (fail)) (match (map single-value (syntax->list #'pos-args)) [(list (tc-result1: argtys-t) ...) - (let* ([subst (infer vars argtys-t dom rng (fv rng) (and expected (tc-results->values expected)))]) + (let* ([subst (infer vars null argtys-t dom rng (fv rng) (fi rng) (and expected (tc-results->values expected)))]) (tc-keywords form (list (subst-all subst ar)) (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] [(tc-result1: (Function: arities)) @@ -843,7 +854,7 @@ (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest a) (infer/vararg vars argtys-t dom rest rng (fv rng) (and expected (tc-results->values expected)))) + (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (fv rng) (fi rng) (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _ _))) _)