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

* Fixed calls to infer that didn't give must-vars argument

Browse Source 
* 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
This commit is contained in:
Sam Tobin-Hochstadt 2008-06-20 14:48:47 -04:00
parent 6296ffbfcf
commit a6cd9ea2cd
6 changed files with 32 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/infer-dummy.ss
View File

@ -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)

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

@ -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)

12
collects/typed-scheme/private/promote-demote.ss
View File

@ -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)])]))
els)])]))

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

@ -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)]

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

@ -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)

22
collects/typed-scheme/private/utils.ss
View File

@ -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 ()