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

Everything now compiles without names

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-04-19 18:42:25 -04:00
parent df1572231e
commit f57ef37a66
12 changed files with 86 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/typed-scheme/env/init-envs.ss vendored
View File

@ -39,9 +39,8 @@
[(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b))] [(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b))]
[(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b))] [(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b))]
[(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))] [(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))]
[(arr: dom rng rest drest kws names) [(arr: dom rng rest drest kws)
`(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws) `(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
(list ,@(for/list ([i names]) `(quote-syntax ,i))))]
[(TypeFilter: t p i) [(TypeFilter: t p i)
`(make-TypeFilter ,(sub t) ,(sub p) (quote-syntax ,i))] `(make-TypeFilter ,(sub t) ,(sub p) (quote-syntax ,i))]
[(NotTypeFilter: t p i) [(NotTypeFilter: t p i)

17
collects/typed-scheme/infer/infer-unit.ss
View File

@ -158,8 +158,8 @@
[ret-mapping (cg t s)]) [ret-mapping (cg t s)])
(cset-meet* (cset-meet*
(list arg-mapping ret-mapping)))] (list arg-mapping ret-mapping)))]
[((arr: ts t #f (cons dty dbound) '() names) [((arr: ts t #f (cons dty dbound) '())
(arr: ss s #f #f '() names*)) (arr: ss s #f #f '()))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(unless (<= (length ts) (length ss)) (unless (<= (length ts) (length ss))
@ -169,11 +169,10 @@
(gensym dbound))] (gensym dbound))]
[new-tys (for/list ([var vars]) [new-tys (for/list ([var vars])
(substitute (make-F var) dbound dty))] (substitute (make-F var) dbound dty))]
[new-names (generate-temporaries new-tys)] [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null) s-arr)])
[new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null (append names new-names)) s-arr)])
(move-vars-to-dmap new-cset dbound vars))] (move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f #f '()) [((arr: ts t #f #f '())
(arr: ss s #f (cons dty dbound) '() names*)) (arr: ss s #f (cons dty dbound) '()))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(unless (<= (length ss) (length ts)) (unless (<= (length ss) (length ts))
@ -183,8 +182,7 @@
(gensym dbound))] (gensym dbound))]
[new-tys (for/list ([var vars]) [new-tys (for/list ([var vars])
(substitute (make-F var) dbound dty))] (substitute (make-F var) dbound dty))]
[new-names (generate-temporaries new-tys)] [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null))])
[new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null (append names* new-names)))])
(move-vars-to-dmap new-cset dbound vars))] (move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f (cons t-dty dbound) '()) [((arr: ts t #f (cons t-dty dbound) '())
(arr: ss s #f (cons s-dty dbound) '())) (arr: ss s #f (cons s-dty dbound) '()))
@ -208,7 +206,7 @@
(cset-meet* (cset-meet*
(list arg-mapping darg-mapping ret-mapping)))] (list arg-mapping darg-mapping ret-mapping)))]
[((arr: ts t t-rest #f '()) [((arr: ts t t-rest #f '())
(arr: ss s #f (cons s-dty dbound) '() names*)) (arr: ss s #f (cons s-dty dbound) '()))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(if (<= (length ts) (length ss)) (if (<= (length ts) (length ss))
@ -223,9 +221,8 @@
(gensym dbound))] (gensym dbound))]
[new-tys (for/list ([var vars]) [new-tys (for/list ([var vars])
(substitute (make-F var) dbound s-dty))] (substitute (make-F var) dbound s-dty))]
[new-names (generate-temporaries new-tys)]
[new-cset (cgen/arr V (append vars X) t-arr [new-cset (cgen/arr V (append vars X) t-arr
(make-arr (append ss new-tys) s #f (cons s-dty dbound) null (append names* new-names)))]) (make-arr (append ss new-tys) s #f (cons s-dty dbound) null))])
(move-vars+rest-to-dmap new-cset dbound vars)))] (move-vars+rest-to-dmap new-cset dbound vars)))]
;; If dotted <: starred is correct, add it below. Not sure it is. ;; If dotted <: starred is correct, add it below. Not sure it is.
[((arr: ts t #f (cons t-dty dbound) '()) [((arr: ts t #f (cons t-dty dbound) '())

20
collects/typed-scheme/infer/promote-demote.ss
View File

@ -21,7 +21,7 @@
(define (var-promote T V) (define (var-promote T V)
(define (vp t) (var-promote t V)) (define (vp t) (var-promote t V))
(define (inv t) (if (V-in? V t) Univ t)) (define (inv t) (if (V-in? V t) Univ t))
(type-case (#:Type vp #:LatentFilter (sub-lf vp)) T (type-case (#:Type vp #:Filter (sub-f vp)) T
[#:F name (if (memq name V) Univ T)] [#:F name (if (memq name V) Univ T)]
[#:Vector t (make-Vector (inv t))] [#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))] [#:Box t (make-Box (inv t))]
@ -32,7 +32,7 @@
[#:Param in out [#:Param in out
(make-Param (var-demote in V) (make-Param (var-demote in V)
(vp out))] (vp out))]
[#:arr dom rng rest drest kws names [#:arr dom rng rest drest kws
(cond (cond
[(apply V-in? V (get-filters rng)) [(apply V-in? V (get-filters rng))
(make-top-arr)] (make-top-arr)]
@ -41,8 +41,7 @@
(vp rng) (vp rng)
(var-demote (car drest) V) (var-demote (car drest) V)
#f #f
(for/list ([k kws]) (var-demote k V)) (for/list ([k kws]) (var-demote k V)))]
names)]
[else [else
(make-arr (for/list ([d dom]) (var-demote d V)) (make-arr (for/list ([d dom]) (var-demote d V))
(vp rng) (vp rng)
@ -50,13 +49,12 @@
(and drest (and drest
(cons (var-demote (car drest) V) (cons (var-demote (car drest) V)
(cdr drest))) (cdr drest)))
(for/list ([k kws]) (var-demote k V)) (for/list ([k kws]) (var-demote k V)))])]))
names)])]))
(define (var-demote T V) (define (var-demote T V)
(define (vd t) (var-demote t V)) (define (vd t) (var-demote t V))
(define (inv t) (if (V-in? V t) (Un) t)) (define (inv t) (if (V-in? V t) (Un) t))
(type-case (#:Type vd #:LatentFilter (sub-lf vd)) T (type-case (#:Type vd #:Filter (sub-f vd)) T
[#:F name (if (memq name V) (Un) T)] [#:F name (if (memq name V) (Un) T)]
[#:Vector t (make-Vector (inv t))] [#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))] [#:Box t (make-Box (inv t))]
@ -67,7 +65,7 @@
[#:Param in out [#:Param in out
(make-Param (var-promote in V) (make-Param (var-promote in V)
(vd out))] (vd out))]
[#:arr dom rng rest drest kws names [#:arr dom rng rest drest kws
(cond (cond
[(apply V-in? V (get-filters rng)) [(apply V-in? V (get-filters rng))
(make-top-arr)] (make-top-arr)]
@ -76,8 +74,7 @@
(vd rng) (vd rng)
(var-promote (car drest) V) (var-promote (car drest) V)
#f #f
(for/list ([k kws]) (var-demote k V)) (for/list ([k kws]) (var-demote k V)))]
names)]
[else [else
(make-arr (for/list ([d dom]) (var-promote d V)) (make-arr (for/list ([d dom]) (var-promote d V))
(vd rng) (vd rng)
@ -85,5 +82,4 @@
(and drest (and drest
(cons (var-promote (car drest) V) (cons (var-promote (car drest) V)
(cdr drest))) (cdr drest)))
(for/list ([k kws]) (var-demote k V)) (for/list ([k kws]) (var-demote k V)))])]))
names)])]))

27
collects/typed-scheme/rep/filter-rep.ss
View File

@ -14,7 +14,7 @@
'FilterSet 'FilterSet
(λ (e) (or (FilterSet? e) (NoFilter? e))))) (λ (e) (or (FilterSet? e) (NoFilter? e)))))
(provide Filter/c FilterSet/c) (provide Filter/c FilterSet/c name-ref/c hash-name)
(define name-ref/c (or/c identifier? integer?)) (define name-ref/c (or/c identifier? integer?))
(define (hash-name v) (if (identifier? v) (hash-id v) v)) (define (hash-name v) (if (identifier? v) (hash-id v) v))
@ -48,18 +48,19 @@
(combine-frees (map free-idxs* fs))]) (combine-frees (map free-idxs* fs))])
(df FilterSet (thn els) (df FilterSet (thn els)
[#:contract (->d ([t (cond [(Bot? t) [#:contract (->d ([t (cond [(Bot? t)
Bot?] Bot?]
[(Bot? e) [(Bot? e)
Top?] Top?]
[else Filter/c])] [else Filter/c])]
[e (cond [(Bot? e) [e (cond [(Bot? e)
Bot?] Bot?]
[(Bot? t) [(Bot? t)
Top?] Top?]
[else Filter/c])]) [else Filter/c])])
(#:syntax [stx #f]) (#:syntax [stx #f])
[result FilterSet?])]) [result FilterSet?])]
[#:fold-rhs (*FilterSet (filter-rec-id thn) (filter-rec-id els))])
;; represents no info about the filters of this expression ;; represents no info about the filters of this expression
;; should only be used for parsing type annotations and expected types ;; should only be used for parsing type annotations and expected types

4
collects/typed-scheme/rep/object-rep.ss
View File

@ -12,8 +12,8 @@
(do Empty () [#:fold-rhs #:base]) (do Empty () [#:fold-rhs #:base])
(do Path ([p (listof PathElem?)] [v identifier?]) (do Path ([p (listof PathElem?)] [v name-ref/c])
[#:intern (list p (hash-id v))] [#:intern (list p (hash-name v))]
[#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))]
[#:fold-rhs (*Path (map pathelem-rec-id p) v)]) [#:fold-rhs (*Path (map pathelem-rec-id p) v)])

8
collects/typed-scheme/rep/rep-utils.ss
View File

@ -181,13 +181,15 @@
#`[#,rec-id #,(hash-ref (attribute recs.mapping) k #`[#,rec-id #,(hash-ref (attribute recs.mapping) k
#'values)])] #'values)])]
[(match-clauses ...) [(match-clauses ...)
(hash-map new-ht gen-clause)]) (hash-map new-ht gen-clause)]
[error-msg (quasisyntax/loc stx (error 'tc "no pattern for ~a" #,fold-target))])
#`(let (let-clauses ... #`(let (let-clauses ...
[#,fold-target ty]) [#,fold-target ty])
;; then generate the fold ;; then generate the fold
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(match #,fold-target (match #,fold-target
match-clauses ...))))]))) match-clauses ...
[_ error-msg]))))])))
(define-syntax (make-prim-type stx) (define-syntax (make-prim-type stx)
@ -237,9 +239,7 @@
(make-prim-type [Type #:key #:d dt] (make-prim-type [Type #:key #:d dt]
[Filter #:d df] [Filter #:d df]
[LatentFilter #:d dlf]
[Object #:d do] [Object #:d do]
[LatentObject #:d dlo]
[PathElem #:d dpe]) [PathElem #:d dpe])
(provide PathElem? (rename-out [Rep-seq Type-seq] (provide PathElem? (rename-out [Rep-seq Type-seq]

39
collects/typed-scheme/rep/type-rep.ss
View File

@ -4,7 +4,7 @@
(require (utils tc-utils) (require (utils tc-utils)
"rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss" "rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss"
mzlib/trace scheme/match mzlib/trace scheme/match
scheme/contract scheme/contract unstable/debug
(for-syntax scheme/base syntax/parse)) (for-syntax scheme/base syntax/parse))
(define name-table (make-weak-hasheq)) (define name-table (make-weak-hasheq))
@ -380,16 +380,16 @@
[(type<? s t) 1] [(type<? s t) 1]
[else -1])) [else -1]))
(define ((sub-lf st) e) (define ((sub-f st) e)
(latentfilter-case (#:Type st (filter-case (#:Type st
#:LatentFilter (sub-lf st)) #:Filter (sub-f st))
e)) e))
(define ((sub-lo st) e) (define ((sub-o st) e)
(latentobject-case (#:Type st (object-case (#:Type st
#:LatentObject (sub-lo st) #:Object (sub-o st)
#:PathElem (sub-pe st)) #:PathElem (sub-pe st))
e)) e))
(define ((sub-pe st) e) (define ((sub-pe st) e)
(pathelem-case (#:Type st (pathelem-case (#:Type st
@ -402,9 +402,8 @@
(define (nameTo name count type) (define (nameTo name count type)
(let loop ([outer 0] [ty type]) (let loop ([outer 0] [ty type])
(define (sb t) (loop outer t)) (define (sb t) (loop outer t))
(define slf (sub-lf sb))
(type-case (type-case
(#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb)) (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
ty ty
[#:F name* (if (eq? name name*) (*B (+ count outer)) ty)] [#:F name* (if (eq? name name*) (*B (+ count outer)) ty)]
;; necessary to avoid infinite loops ;; necessary to avoid infinite loops
@ -418,8 +417,7 @@
(cons (sb (car drest)) (cons (sb (car drest))
(if (eq? (cdr drest) name) (+ count outer) (cdr drest))) (if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
#f) #f)
(map sb kws) (map sb kws))]
names)]
[#:ValuesDots rs dty dbound [#:ValuesDots rs dty dbound
(*ValuesDots (map sb rs) (*ValuesDots (map sb rs)
(sb dty) (sb dty)
@ -439,6 +437,7 @@
(cdr names) (cdr names)
(sub1 count)))))) (sub1 count))))))
;; instantiate-many : List[Type] Scope^n -> Type ;; instantiate-many : List[Type] Scope^n -> Type
;; where n is the length of types ;; where n is the length of types
;; all of the types MUST be Fs ;; all of the types MUST be Fs
@ -446,9 +445,9 @@
(define (replace image count type) (define (replace image count type)
(let loop ([outer 0] [ty type]) (let loop ([outer 0] [ty type])
(define (sb t) (loop outer t)) (define (sb t) (loop outer t))
(define slf (sub-lf sb)) (define sf (sub-f sb))
(type-case (type-case
(#:Type sb #:LatentFilter slf #:LatentObject (sub-lo sb)) (#:Type sb #:Filter sf #:Object (sub-o sb))
ty ty
[#:B idx (if (= (+ count outer) idx) [#:B idx (if (= (+ count outer) idx)
image image
@ -622,10 +621,8 @@
(define-match-expander arr:* (define-match-expander arr:*
(lambda (stx) (lambda (stx)
(syntax-parse stx (syntax-parse stx
[(_ dom rng rest drest kws names)
(syntax/loc stx (arr: dom rng rest drest kws names))]
[(_ dom rng rest drest kws) [(_ dom rng rest drest kws)
(syntax/loc stx (arr: dom rng rest drest kws _))]))) (syntax/loc stx (arr: dom rng rest drest kws))])))
;(trace subst subst-all) ;(trace subst subst-all)
(provide (provide
@ -637,14 +634,14 @@
Mu? Poly? PolyDots? Mu? Poly? PolyDots?
arr arr
arr? arr?
Type? Filter? LatentFilter? Object? LatentObject? Type? Filter? Object?
Type/c Type/c
Poly-n Poly-n
PolyDots-n PolyDots-n
free-vars* free-vars*
type-compare type<? type-compare type<?
remove-dups remove-dups
sub-lf sub-lo sub-pe sub-f sub-o sub-pe
Values: Values? Values-rs Values: Values? Values-rs
(rename-out [Mu:* Mu:] (rename-out [Mu:* Mu:]
[Poly:* Poly:] [Poly:* Poly:]

6
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -731,8 +731,7 @@
;(printf "got to here 0~a~n" args-stx) ;(printf "got to here 0~a~n" args-stx)
(match* (ftype0 argtys) (match* (ftype0 argtys)
;; we check that all kw args are optional ;; we check that all kw args are optional
[((arr: dom (Values: (list (Result: t-r f-r o-r) ...)) rest #f (list (Keyword: _ _ #f) ...) [((arr: dom (Values: (list (Result: t-r f-r o-r) ...)) rest #f (list (Keyword: _ _ #f) ...))
names)
(list (tc-result1: t-a phi-a o-a) ...)) (list (tc-result1: t-a phi-a o-a) ...))
;(printf "got to here 1~a~n" args-stx) ;(printf "got to here 1~a~n" args-stx)
(when check? (when check?
@ -748,8 +747,7 @@
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
;(printf "got to here 2 ~a ~a ~a ~n" dom names o-a) ;(printf "got to here 2 ~a ~a ~a ~n" dom names o-a)
(let-values ([(names o-a) (let-values ([(names o-a)
(for/lists (n o) ([d (in-list dom)] (for/lists (n o) ([(d nm) (in-indexed (in-list dom))]
[nm (in-list names)]
[oa (in-list o-a)]) [oa (in-list o-a)])
(values nm oa))]) (values nm oa))])
;(printf "got to here 3~a~n" args-stx) ;(printf "got to here 3~a~n" args-stx)

31
collects/typed-scheme/types/abbrev.ss
View File

@ -182,24 +182,18 @@
(d/c (make-arr* dom rng (d/c (make-arr* dom rng
#:rest [rest #f] #:drest [drest #f] #:kws [kws null] #:rest [rest #f] #:drest [drest #f] #:kws [kws null]
#:filters [filters -no-filter] #:object [obj -no-obj] #:filters [filters -no-filter] #:object [obj -no-obj])
#:names [names (append
(generate-temporaries dom)
(if (or drest rest) (list (generate-temporary)) null)
(generate-temporaries kws))])
(c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c)) (c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c))
(#:rest (or/c #f Type/c) (#:rest (or/c #f Type/c)
#:drest (or/c #f (cons/c Type/c symbol?)) #:drest (or/c #f (cons/c Type/c symbol?))
#:kws (listof Keyword?) #:kws (listof Keyword?)
#:filters FilterSet? #:filters FilterSet?
#:object Object? #:object Object?)
#:names (listof identifier?))
arr?) arr?)
(make-arr dom (if (or (Values? rng) (ValuesDots? rng)) (make-arr dom (if (or (Values? rng) (ValuesDots? rng))
rng rng
(make-Values (list (-result rng filters obj)))) (make-Values (list (-result rng filters obj))))
rest drest (sort #:key Keyword-kw kws keyword<?) rest drest (sort #:key Keyword-kw kws keyword<?)))
names))
(define-syntax (->* stx) (define-syntax (->* stx)
(define-syntax-class c (define-syntax-class c
@ -241,12 +235,10 @@
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))])) (make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))]))
(define (->acc dom rng path) (define (->acc dom rng path)
(define x (generate-temporary 'x)) (make-Function (list (make-arr* dom rng
(make-Function (list (make-arr* dom rng #:filters (-FS (-not-filter (-val #f) 0 path)
#:names (list x) (-filter (-val #f) 0 path))
#:filters (-FS (-not-filter (-val #f) x path) #:object (make-Path path 0)))))
(-filter (-val #f) x path))
#:object (make-Path path x)))))
(define (cl->* . args) (define (cl->* . args)
(define (funty-arities f) (define (funty-arities f)
@ -275,7 +267,7 @@
(make-Struct name parent flds proc poly pred cert accs constructor)) (make-Struct name parent flds proc poly pred cert accs constructor))
(d/c (-filter t i [p null]) (d/c (-filter t i [p null])
(c:->* (Type/c identifier?) ((listof PathElem?)) Filter/c) (c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c)
(make-TypeFilter t p i)) (make-TypeFilter t p i))
(define (-filter-at t o) (define (-filter-at t o)
@ -329,7 +321,7 @@
[t (loop (cdr fs) (cons t result))])))) [t (loop (cdr fs) (cons t result))]))))
(d/c (-not-filter t i [p null]) (d/c (-not-filter t i [p null])
(c:->* (Type/c identifier?) ((listof PathElem?)) Filter/c) (c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c)
(make-NotTypeFilter t p i)) (make-NotTypeFilter t p i))
(define-syntax-rule (with-names (vars ...) . e) (define-syntax-rule (with-names (vars ...) . e)
@ -337,7 +329,7 @@
. e)) . e))
(define-syntax-rule (asym-pred (var) dom rng filter) (define-syntax-rule (asym-pred (var) dom rng filter)
(with-names (var) (make-Function (list (make-arr* (list dom) rng #:names (list var) #:filters filter))))) (with-names (var) (make-Function (list (make-arr* (list dom) rng #:filters filter)))))
(d/c make-pred-ty (d/c make-pred-ty
(case-> (c:-> Type/c Type/c) (case-> (c:-> Type/c Type/c)
@ -346,12 +338,11 @@
(c:-> (listof Type/c) Type/c Type/c integer? (listof PathElem?) Type/c)) (c:-> (listof Type/c) Type/c Type/c integer? (listof PathElem?) Type/c))
(case-lambda (case-lambda
[(in out t n p) [(in out t n p)
(define xs (generate-temporaries in)) (define xs (for/list ([(_ i) (in-indexed (in-list in))]) i))
(make-Function (make-Function
(list (list
(make-arr* (make-arr*
in out in out
#:names xs
#:filters (-FS (-filter t (list-ref xs n) p) (-not-filter t (list-ref xs n) p)))))] #:filters (-FS (-filter t (list-ref xs n) p) (-not-filter t (list-ref xs n) p)))))]
[(in out t n) [(in out t n)
(make-pred-ty in out t n null)] (make-pred-ty in out t n null)]

10
collects/typed-scheme/types/printer.ss
View File

@ -34,10 +34,10 @@
(match c (match c
[(FilterSet: thn els) (fp "(~a | ~a)" thn els)] [(FilterSet: thn els) (fp "(~a | ~a)" thn els)]
[(NoFilter:) (fp "-")] [(NoFilter:) (fp "-")]
[(NotTypeFilter: type (list) id) (fp "(! ~a @ ~a)" type (syntax-e id))] [(NotTypeFilter: type (list) id) (fp "(! ~a @ ~a)" type id)]
[(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))] [(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path id)]
[(TypeFilter: type (list) id) (fp "(~a @ ~a)" type (syntax-e id))] [(TypeFilter: type (list) id) (fp "(~a @ ~a)" type id)]
[(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path (syntax-e id))] [(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path id)]
[(Bot:) (fp "Bot")] [(Bot:) (fp "Bot")]
[(Top:) (fp "Top")] [(Top:) (fp "Top")]
[(ImpFilter: a c) (fp "(ImpFilter ~a ~a)" a c)] [(ImpFilter: a c) (fp "(ImpFilter ~a ~a)" a c)]
@ -58,7 +58,7 @@
(match c (match c
[(NoObject:) (fp "-")] [(NoObject:) (fp "-")]
[(Empty:) (fp "")] [(Empty:) (fp "")]
[(Path: pes i) (fp "~a" (append pes (list (syntax-e i))))] [(Path: pes i) (fp "~a" (append pes (list i)))]
[else (fp "(Unknown Object: ~a)" (struct->vector c))])) [else (fp "(Unknown Object: ~a)" (struct->vector c))]))
;; print out a type ;; print out a type

6
collects/typed-scheme/types/subtype.ss
View File

@ -184,13 +184,13 @@
(d/c (combine-arrs arrs) (d/c (combine-arrs arrs)
(c-> (listof arr?) (or/c #f arr?)) (c-> (listof arr?) (or/c #f arr?))
(match arrs (match arrs
[(list (and a1 (arr: dom1 rng1 #f #f '() names)) (arr: dom rng #f #f '()) ...) [(list (and a1 (arr: dom1 rng1 #f #f '())) (arr: dom rng #f #f '()) ...)
(cond (cond
[(null? dom) (make-arr dom1 rng1 #f #f '() names)] [(null? dom) (make-arr dom1 rng1 #f #f '())]
[(not (apply = (length dom1) (map length dom))) #f] [(not (apply = (length dom1) (map length dom))) #f]
[(not (for/and ([rng2 (in-list rng)]) (type-equal? rng1 rng2))) [(not (for/and ([rng2 (in-list rng)]) (type-equal? rng1 rng2)))
#f] #f]
[else (make-arr (apply map (lambda args (make-Union (sort args type<?))) (cons dom1 dom)) rng1 #f #f '() names)])] [else (make-arr (apply map (lambda args (make-Union (sort args type<?))) (cons dom1 dom)) rng1 #f #f '())])]
[_ #f])) [_ #f]))

24
collects/typed-scheme/types/utils.ss
View File

@ -39,11 +39,11 @@
(define (substitute image name target #:Un [Un (get-union-maker)]) (define (substitute image name target #:Un [Un (get-union-maker)])
(define (sb t) (substitute image name t)) (define (sb t) (substitute image name t))
(if (hash-ref (free-vars* target) name #f) (if (hash-ref (free-vars* target) name #f)
(type-case (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb)) (type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
target target
[#:Union tys (Un (map sb tys))] [#:Union tys (Un (map sb tys))]
[#:F name* (if (eq? name* name) image target)] [#:F name* (if (eq? name* name) image target)]
[#:arr dom rng rest drest kws names [#:arr dom rng rest drest kws
(begin (begin
(when (and (pair? drest) (when (and (pair? drest)
(eq? name (cdr drest)) (eq? name (cdr drest))
@ -53,8 +53,7 @@
(sb rng) (sb rng)
(and rest (sb rest)) (and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest))) (and drest (cons (sb (car drest)) (cdr drest)))
(map sb kws) (map sb kws)))]
names))]
[#:ValuesDots types dty dbound [#:ValuesDots types dty dbound
(begin (begin
(when (eq? name dbound) (when (eq? name dbound)
@ -66,7 +65,7 @@
(define (substitute-dots images rimage name target) (define (substitute-dots images rimage name target)
(define (sb t) (substitute-dots images rimage name t)) (define (sb t) (substitute-dots images rimage name t))
(if (hash-ref (free-vars* target) name #f) (if (hash-ref (free-vars* target) name #f)
(type-case (#:Type sb #:LatentFilter (sub-lf sb)) target (type-case (#:Type sb #:Filter (sub-f sb)) target
[#:ValuesDots types dty dbound [#:ValuesDots types dty dbound
(if (eq? name dbound) (if (eq? name dbound)
(make-Values (make-Values
@ -80,7 +79,7 @@
(make-FilterSet (make-Top) (make-Top)) (make-FilterSet (make-Top) (make-Top))
(make-Empty)))))) (make-Empty))))))
(make-ValuesDots (map sb types) (sb dty) dbound))] (make-ValuesDots (map sb types) (sb dty) dbound))]
[#:arr dom rng rest drest kws names [#:arr dom rng rest drest kws
(if (and (pair? drest) (if (and (pair? drest)
(eq? name (cdr drest))) (eq? name (cdr drest)))
(make-arr (append (make-arr (append
@ -91,14 +90,12 @@
(sb rng) (sb rng)
rimage rimage
#f #f
(map sb kws) (map sb kws))
names)
(make-arr (map sb dom) (make-arr (map sb dom)
(sb rng) (sb rng)
(and rest (sb rest)) (and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest))) (and drest (cons (sb (car drest)) (cdr drest)))
(map sb kws) (map sb kws)))])
names))])
target)) target))
;; implements sd from the formalism ;; implements sd from the formalism
@ -106,7 +103,7 @@
(define (substitute-dotted image image-bound name target) (define (substitute-dotted image image-bound name target)
(define (sb t) (substitute-dotted image image-bound name t)) (define (sb t) (substitute-dotted image image-bound name t))
(if (hash-ref (free-vars* target) name #f) (if (hash-ref (free-vars* target) name #f)
(type-case (#:Type sb #:LatentFilter (sub-lf sb)) (type-case (#:Type sb #:Filter (sub-f sb))
target target
[#:ValuesDots types dty dbound [#:ValuesDots types dty dbound
(make-ValuesDots (map sb types) (make-ValuesDots (map sb types)
@ -116,15 +113,14 @@
(if (eq? name* name) (if (eq? name* name)
image image
target)] target)]
[#:arr dom rng rest drest kws names [#:arr dom rng rest drest kws
(make-arr (map sb dom) (make-arr (map sb dom)
(sb rng) (sb rng)
(and rest (sb rest)) (and rest (sb rest))
(and drest (and drest
(cons (sb (car drest)) (cons (sb (car drest))
(if (eq? name (cdr drest)) image-bound (cdr drest)))) (if (eq? name (cdr drest)) image-bound (cdr drest))))
(map sb kws) (map sb kws))])
names)])
target)) target))
;; substitute many variables ;; substitute many variables