From a6cd9ea2cdeb082c5da286e2ec8478380fdf4956 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 20 Jun 2008 14:48:47 -0400 Subject: [PATCH] * Fixed calls to infer that didn't give must-vars argument * Fixed promote/demote so they check the dotted bound, not free vars of type * Stopped promote/demote from promoting/demoting away dotted bound * Stopped promotion/demotion of dotted bound in cgen/arr * Improved debug macro --- collects/typed-scheme/private/infer-dummy.ss | 2 +- collects/typed-scheme/private/infer-unit.ss | 19 +++++----------- .../typed-scheme/private/promote-demote.ss | 12 +++++----- collects/typed-scheme/private/restrict.ss | 2 +- collects/typed-scheme/private/tc-app-unit.ss | 4 ++-- collects/typed-scheme/private/utils.ss | 22 ++++++++++++++----- 6 files changed, 32 insertions(+), 29 deletions(-) diff --git a/collects/typed-scheme/private/infer-dummy.ss b/collects/typed-scheme/private/infer-dummy.ss index b009ab3a24..8645a31435 100644 --- a/collects/typed-scheme/private/infer-dummy.ss +++ b/collects/typed-scheme/private/infer-dummy.ss @@ -3,5 +3,5 @@ (require "type-rep.ss") (define infer-param (make-parameter (lambda e (error 'infer "not initialized")))) -(define (unify X S T) ((infer-param) X S T (make-Univ))) +(define (unify X S T) ((infer-param) X S T (make-Univ) null)) (provide unify infer-param) \ 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 8e3c591684..382fd6d7ca 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -86,16 +86,7 @@ (hash-ref cmap v (lambda () (int-err "No constraint for new var ~a" v)))) (hash-ref cmap dbound - (lambda () (int-err "No constraint for bound ~a" dbound))))))) - - -;; ss and ts have the same length -(define (cgen-union V X ss ts) - ;; first, we remove common elements of ss and ts - (let-values ([(ss* ts*) - (values (filter (lambda (se) (not (ormap (lambda (t) (type-equal? t se)) ts))) ss) - (filter (lambda (te) (not (ormap (lambda (s) (type-equal? s te)) ss))) ts))]) - (cgen/list V X ss* ts*))) + (lambda () (int-err "No constraint for bound ~a" dbound))))))) ;; t and s must be *latent* effects (define (cgen/eff V X t s) @@ -171,7 +162,7 @@ (when (memq dbound X) (fail! S T)) (let* ([arg-mapping (cgen/list X V ss ts)] - [darg-mapping (cgen (cons dbound V) X s-dty t-dty)] + [darg-mapping (cgen V X s-dty t-dty)] [ret-mapping (cg t s)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping @@ -195,7 +186,7 @@ (if (<= (length ts) (length ss)) ;; the simple case (let* ([arg-mapping (cgen/list X V ss (extend ss ts t-rest))] - [darg-mapping (move-rest-to-dmap (cgen (cons dbound V) X s-dty t-rest) dbound)] + [darg-mapping (move-rest-to-dmap (cgen V X s-dty t-rest) dbound)] [ret-mapping (cg t s)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) @@ -227,7 +218,7 @@ (move-vars+rest-to-dmap new-cset dbound vars #:exact #t)) ;; the simple case (let* ([arg-mapping (cgen/list X V (extend ts ss s-rest) ts)] - [darg-mapping (move-rest-to-dmap (cgen (cons dbound V) X s-rest t-dty) dbound #:exact #t)] + [darg-mapping (move-rest-to-dmap (cgen V X s-rest t-dty) dbound #:exact #t)] [ret-mapping (cg t s)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) @@ -425,3 +416,5 @@ (define (i s t r) (infer/simple (list s) (list t) r)) + +;(trace cgen/arr) \ No newline at end of file diff --git a/collects/typed-scheme/private/promote-demote.ss b/collects/typed-scheme/private/promote-demote.ss index 4ec9cf8504..bbb1d7b229 100644 --- a/collects/typed-scheme/private/promote-demote.ss +++ b/collects/typed-scheme/private/promote-demote.ss @@ -30,7 +30,7 @@ (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] - [(and drest (V-in? V (car drest))) + [(and drest (memq (cdr drest) V)) (make-arr (for/list ([d dom]) (var-demote d V)) (vp rng) (var-demote (car drest) V) @@ -42,8 +42,7 @@ (vp rng) (and rest (var-demote rest V)) (and drest - (cons (var-demote (car drest) - (cons (cdr drest) V)) + (cons (var-demote (car drest) V) (cdr drest))) thn els)])])) @@ -66,7 +65,7 @@ (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] - [(and drest (V-in? V (car drest))) + [(and drest (memq (cdr drest) V)) (make-arr (for/list ([d dom]) (var-promote d V)) (vd rng) (var-promote (car drest) V) @@ -78,8 +77,7 @@ (vd rng) (and rest (var-promote rest V)) (and drest - (cons (var-promote (car drest) - (cons (cdr drest) V)) + (cons (var-promote (car drest) V) (cdr drest))) thn - els)])])) \ No newline at end of file + els)])])) diff --git a/collects/typed-scheme/private/restrict.ss b/collects/typed-scheme/private/restrict.ss index b16542a36b..2c86a687b7 100644 --- a/collects/typed-scheme/private/restrict.ss +++ b/collects/typed-scheme/private/restrict.ss @@ -24,7 +24,7 @@ [(subtype t1 t2) t1] ;; already a subtype [(match t2 [(Poly: vars t) - (let ([subst (infer vars (list t1) (list t) t1)]) + (let ([subst (infer vars (list t1) (list t) t1 vars)]) (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/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index 1ae43acd43..9d24547a32 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -138,8 +138,8 @@ (stringify-domain (car doms) (car rests) (car drests)) (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))] [else - (format "Domains:~nArguments: ~a~n" - (stringify (map stringify-domain doms rests drests) "~n~t") + (format "Domains: ~a~nArguments: ~a~n" + (stringify (map stringify-domain doms rests drests) "~n\t") (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))])) (define (tc/apply f args) diff --git a/collects/typed-scheme/private/utils.ss b/collects/typed-scheme/private/utils.ss index c17417fec5..a56591409d 100644 --- a/collects/typed-scheme/private/utils.ss +++ b/collects/typed-scheme/private/utils.ss @@ -17,11 +17,23 @@ extend debug) -(define-syntax-rule (debug args) - (begin (printf "starting ~a~n" 'args) - (let ([e args]) - (printf "result was ~a~n" e) - e))) +(define-syntax debug + (syntax-rules () + [(_ (f . args)) + (begin (printf "starting ~a~n" 'f) + (let ([l (list . args)]) + (printf "arguments are:~n") + (for/list ([arg 'args] + [val l]) + (printf "\t~a: ~a~n" arg val)) + (let ([e (apply f l)]) + (printf "result was ~a~n" e) + e)))] + [(_ . args) + (begin (printf "starting ~a~n" 'args) + (let ([e args]) + (printf "result was ~a~n" e) + e))])) (define-syntax (with-syntax* stx) (syntax-case stx ()