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

revert all of the interning changes since they didn't work

Browse Source 
svn: r17262

original commit: 16c152e5a4ca1797f20c127d443e4689e292e55f
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-10 17:15:17 +00:00
parent b68c553664
commit 1261ce2cdb
15 changed files with 185 additions and 244 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,28 +22,27 @@
(define (gen-constructor sym)
(string->symbol (string-append "make-" (substring (symbol->string sym) 7))))
(match v
[(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq) ',(Type-name v))]
[(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt) ',(Type-name v))]
[(Name: stx) `(make-Name (quote-syntax ,stx) ',(Type-name v))]
[(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
[(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
[(Name: stx) `(make-Name (quote-syntax ,stx))]
[(Struct: name parent flds proc poly? pred-id cert)
`(make-Struct ,(sub name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) (quote-syntax ,pred-id) (syntax-local-certifier) ',(Type-name v))]
[(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx) ',(Type-name v))]
[(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier) ',(Type-name v))]
`(make-Struct ,(sub name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) (quote-syntax ,pred-id) (syntax-local-certifier))]
[(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))]
[(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))]
[(Refinement: parent pred cert) `(make-Refinement ,(sub parent)
(quote-syntax ,pred)
(syntax-local-certifier)
',(Type-name v))]
[(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b) ',(Type-name v))]
[(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b) ',(Type-name v))]
[(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b) ',(Type-name v))]
(syntax-local-certifier))]
[(Mu-name: n b) `(make-Mu ,(sub n) ,(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))]
[(? (lambda (e) (or (LatentFilter? e)
(LatentObject? e)
(PathElem? e)))
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq vals)))
`(,(gen-constructor tag) ,@(map sub vals))]
[(? (lambda (e) (or (Type? e)))
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq name vals)))
`(,(gen-constructor tag) ,@(map sub vals) ',name)]
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals)))
`(,(gen-constructor tag) ,@(map sub vals))]
[_ (basic v)]))
(define (bound-in-this-module id)

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

@ -1,7 +1,7 @@
#lang scheme/unit
(require "../utils/utils.ss")
(require (rep type-rep)
(require (rep type-rep rep-utils)
(types convenience union utils)
"signatures.ss"
scheme/list scheme/match)

4
collects/typed-scheme/private/parse-type.ss
View File

@ -260,12 +260,12 @@
(lambda (t)
;(printf "found a type alias ~a~n" #'id)
(add-type-name-reference #'id)
t #;(add-name t (syntax-e #'id)))]
t)]
;; if it's a type name, we just use the name
[(lookup-type-name #'id (lambda () #f))
(add-type-name-reference #'id)
;(printf "found a type name ~a~n" #'id)
(add-name (make-Name #'id) (syntax-e #'id))]
(make-Name #'id)]
[(free-identifier=? #'id #'t:->)
(tc-error/delayed "Incorrect use of -> type constructor")
Err]

103
collects/typed-scheme/rep/free-variance.ss
View File

@ -1 +1,104 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (for-syntax scheme/base)
(utils tc-utils)
mzlib/etc)
;; this file contains support for calculating the free variables/indexes of types
;; actual computation is done in rep-utils.ss and type-rep.ss
(define-values (Covariant Contravariant Invariant Constant Dotted)
(let ()
(define-struct Variance () #:inspector #f)
(define-struct (Covariant Variance) () #:inspector #f)
(define-struct (Contravariant Variance) () #:inspector #f)
(define-struct (Invariant Variance) () #:inspector #f)
(define-struct (Constant Variance) () #:inspector #f)
;; not really a variance, but is disjoint with the others
(define-struct (Dotted Variance) () #:inspector #f)
(values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
(provide Covariant Contravariant Invariant Constant Dotted)
;; hashtables for keeping track of free variables and indexes
(define index-table (make-weak-hasheq))
;; maps Type to List[Cons[Number,Variance]]
(define var-table (make-weak-hasheq))
;; maps Type to List[Cons[Symbol,Variance]]
(define (free-idxs* t) (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" (syntax-e t)))))
(define (free-vars* t) (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" (syntax-e t)))))
(define empty-hash-table (make-immutable-hasheq null))
(provide free-vars* free-idxs* empty-hash-table make-invariant)
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
;; (listof frees) -> frees
(define (combine-frees freess)
(define ht (make-hasheq))
(define (combine-var v w)
(cond
[(eq? v w) v]
[(eq? v Dotted) w]
[(eq? w Dotted) v]
[(eq? v Constant) w]
[(eq? w Constant) v]
[else Invariant]))
(for* ([old-ht (in-list freess)]
[(sym var) (in-hash old-ht)])
(let* ([sym-var (hash-ref ht sym (lambda () #f))])
(if sym-var
(hash-set! ht sym (combine-var var sym-var))
(hash-set! ht sym var))))
ht)
;; given a set of free variables, change bound to ...
;; (if bound wasn't free, this will add it as Dotted
;; appropriately so that things that expect to see
;; it as "free" will -- fixes the case where the
;; dotted pre-type base doesn't use the bound).
(define (fix-bound vs bound)
(define vs* (hash-map* (lambda (k v) v) vs))
(hash-set! vs* bound Dotted)
vs*)
;; frees -> frees
(define (flip-variances vs)
(hash-map*
(lambda (k v)
(evcase
v
[Covariant Contravariant]
[Contravariant Covariant]
[v v]))
vs))
(define (make-invariant vs)
(hash-map*
(lambda (k v) Invariant)
vs))
(define (hash-map* f ht)
(define new-ht (make-hasheq))
(for ([(k v) (in-hash ht)])
(hash-set! new-ht k (f k v)))
new-ht)
(define (without-below n frees)
(define new-ht (make-hasheq))
(for ([(k v) (in-hash frees)])
(when (>= k n) (hash-set! new-ht k v)))
new-ht)
(provide combine-frees flip-variances without-below unless-in-table var-table index-table empty-hash-table
fix-bound)
(define-syntax (unless-in-table stx)
(syntax-case stx ()
[(_ table val . body)
(quasisyntax/loc stx
(hash-ref table val #,(syntax/loc #'body (lambda () . body))))]))

9
collects/typed-scheme/rep/interning.ss
View File

@ -14,9 +14,12 @@
#'(define *name
(let ([table (make-ht)])
(lambda (arg ...)
(let* ([key key-expr]
[new-seq (hash-ref table key count!)])
(make-name new-seq e ... arg ...)))))]))
(let ([key key-expr])
(hash-ref table key
(lambda ()
(let ([new (make-name (count!) e ... arg ...)])
(hash-set! table key new)
new)))))))]))
(define (make-count!)
(let ([state 0])

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

@ -2,8 +2,9 @@
(require "../utils/utils.ss")
(require mzlib/struct
scheme/match scheme/list
scheme/match
syntax/boundmap
"free-variance.ss"
"interning.ss"
unstable/syntax unstable/match
mzlib/etc
@ -24,11 +25,9 @@
(provide == defintern hash-id (for-syntax fold-target))
(define-for-syntax fold-target #'fold-target)
(define-for-syntax (mk par ht-stx key? name?)
(define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id
#:attributes (i cnt)
(pattern i:id
@ -68,8 +67,6 @@
#:with e fold-target)
(pattern ex:expr
#:with e #'#'ex))
(unless (equal? key? name?)
(error "key? not name"))
(lambda (stx)
(syntax-parse stx
[(dform nm:id flds:idlist (~or
@ -88,7 +85,7 @@
[*maker (format-id #'nm "*~a" #'nm)]
[**maker (format-id #'nm "**~a" #'nm)]
[*maker-cnt (if enable-contracts?
(or (attribute cnt) #`((flds.cnt ...) #,(if name? #'(any/c) #'()) . ->* . pred))
(or (attribute cnt) #'(flds.cnt ... . -> . pred))
#'any/c)]
[ht-stx ht-stx]
[bfs-fold-rhs (cond [(attribute fold-rhs)
@ -108,30 +105,26 @@
(p/c (rename *maker maker *maker-cnt))))]
[intern
(let ([mk (lambda (int)
(if (and key? name?)
#`(defintern (**maker name-val . flds.fs) maker #,int #:extra-arg #,(attribute key-expr))
#`(defintern (**maker . flds.fs) maker #,int)))])
(syntax-parse #'flds.fs
[_ #:fail-unless (attribute intern?) #f
(mk #'intern?)]
[() (mk #'#f)]
[(f) (mk #'f)]
[_ (mk #'(list . flds.fs))]))]
[(ign-pats ...) (if (and name? key?) #'(_ _ _) #'(_))]
(if key?
#`(defintern (**maker . flds.fs) maker #,int #:extra-arg #,(attribute key-expr))
#`(defintern (**maker . flds.fs) maker #,int)))])
(syntax-parse #'flds.fs
[_ #:fail-unless (attribute intern?) #f
(mk #'intern?)]
[() (mk #'#f)]
[(f) (mk #'f)]
[_ (mk #'(list . flds.fs))]))]
[(ign-pats ...) (if key? #'(_ _) #'(_))]
[frees-def (if (attribute frees) #'frees.def #'(begin))]
[frees
(with-syntax ([(f1 f2) (if (attribute frees)
#'(frees.f1 frees.f2)
(list (combiner #'free-vars* #'flds.fs)
(combiner #'free-idxs* #'flds.fs)))]
[(fs ...) #'flds.fs]
[name-val-formal
(if name? #'([name-val #f]) #'())]
[name-val-expr (if name? #'(name-val) #'())])
(combiner #'free-idxs* #'flds.fs)))])
(quasisyntax/loc stx
(w/c nm ([*maker *maker-cnt])
(define (*maker fs ... #,@#'name-val-formal)
(define v (**maker #,@#'name-val-expr fs ...))
(define (*maker . flds.fs)
(define v (**maker . flds.fs))
frees-def
(unless-in-table
var-table v
@ -235,29 +228,23 @@
(define-syntax (make-prim-type stx)
(define default-flds #'(seq))
(define-syntax-class type-name-base
#:attributes (i lower-s first-letter key? (fld-names 1) name?)
#:attributes (i lower-s first-letter key? (fld-names 1))
#:transparent
(pattern i:id
#:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with (fld-names ...) default-flds
#:with key? #'#f
#:with name? #'#f
#:attr first-letter (string-ref (attribute lower-s) 0))
(pattern [i:id #:d d-name:id]
#:with (fld-names ...) default-flds
#:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with key? #'#f
#:with name? #'#f
#:attr first-letter (symbol->string (attribute d-name.datum)))
(pattern [i:id #:key (~optional (~and name-kw #:name))]
(pattern [i:id #:key]
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(list #'key)
(if (attribute name-kw)
(list #'name)
null)))
(syntax->list #'(key))))
#:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with key? #'#t
#:with name? (if (attribute name-kw) #'#t #'#f)
#:attr first-letter (string-ref (attribute lower-s) 0)))
(define-syntax-class type-name
#:transparent
@ -271,7 +258,7 @@
#:with ht (format-id #'i "~a-name-ht" (attribute lower-s))
#:with rec-id (format-id #'i "~a-rec-id" (attribute lower-s))
#:with d-id (format-id #'i "d~a" (attribute first-letter))
#:with (_ _ pred? seq-acc accs ...)
#:with (_ _ pred? accs ...)
(datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
(syntax-parse stx
[(_ i:type-name ...)
@ -280,15 +267,11 @@
[fresh-ids-list #'(fresh-ids ...)]
[(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)])
#'(begin
(provide i.d-id ... i.printer ... i.name ... i.pred? ... i.seq-acc ... i.accs ... ...
(provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
(for-syntax i.ht ... i.rec-id ...))
(define-syntax i.d-id (mk #'i.name #'i.ht i.key? i.name?)) ...
(define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
(define-for-syntax i.ht (make-hasheq)) ...
(define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))
[prop:equal+hash (list (lambda (a b rec)
(eq? (i.seq-acc a) (i.seq-acc b)))
(lambda (a rec) (i.seq-acc a))
(lambda (a secondary) (secondary a)))]) ...
(define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
(define-for-syntax i.rec-id #'i.rec-id) ...
(provide i.case ...)
(define-syntaxes (i.case ...)
@ -301,139 +284,9 @@
'(i.keyword ...)))
(list i.ht ...)))))))]))
(make-prim-type [Type #:key #:name]
(make-prim-type [Type #:key]
Filter
[LatentFilter #:d lf]
Object
[LatentObject #:d lo]
[PathElem #:d pe])
;; free-variance.ss starts here:
(require "../utils/utils.ss")
(require (for-syntax scheme/base)
(utils tc-utils)
scheme/contract
mzlib/etc)
;; this file contains support for calculating the free variables/indexes of types
;; actual computation is done in rep-utils.ss and type-rep.ss
(define-values (Covariant Contravariant Invariant Constant Dotted)
(let ()
(define-struct Variance () #:inspector #f)
(define-struct (Covariant Variance) () #:inspector #f)
(define-struct (Contravariant Variance) () #:inspector #f)
(define-struct (Invariant Variance) () #:inspector #f)
(define-struct (Constant Variance) () #:inspector #f)
;; not really a variance, but is disjoint with the others
(define-struct (Dotted Variance) () #:inspector #f)
(values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
(define (variance? e)
(memq e (list Covariant Contravariant Invariant Constant Dotted)))
(provide Covariant Contravariant Invariant Constant Dotted)
;; hashtables for keeping track of free variables and indexes
(define index-table (make-weak-hash))
;; maps Type to List[Cons[Number,Variance]]
(define var-table (make-weak-hash))
;; maps Type to List[Cons[Symbol,Variance]]
(define input/c (or/c Type? Filter? LatentFilter? Object? LatentObject? PathElem?))
(d/c (free-idxs* t)
(-> input/c (hash/c integer? variance?))
(hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t))))
(d/c (free-vars* t)
(-> input/c (hash/c symbol? variance?))
(hash-ref var-table t (lambda _ (int-err "type ~a not in var-table ~a" t (take (reverse (hash-map var-table list)) 20)))))
(define empty-hash-table (make-immutable-hasheq null))
;; Type? is not available here! grrr
(p/c
[free-vars* (-> input/c (hash/c symbol? variance?))]
[free-idxs* (-> input/c (hash/c integer? variance?))])
(provide empty-hash-table)
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
;; (listof frees) -> frees
(define (combine-frees freess)
(define ht (make-hasheq))
(define (combine-var v w)
(cond
[(eq? v w) v]
[(eq? v Dotted) w]
[(eq? w Dotted) v]
[(eq? v Constant) w]
[(eq? w Constant) v]
[else Invariant]))
(for* ([old-ht (in-list freess)]
[(sym var) (in-hash old-ht)])
(let* ([sym-var (hash-ref ht sym (lambda () #f))])
(if sym-var
(hash-set! ht sym (combine-var var sym-var))
(hash-set! ht sym var))))
ht)
;; given a set of free variables, change bound to ...
;; (if bound wasn't free, this will add it as Dotted
;; appropriately so that things that expect to see
;; it as "free" will -- fixes the case where the
;; dotted pre-type base doesn't use the bound).
(define (fix-bound vs bound)
(define vs* (hash-map* (lambda (k v) v) vs))
(hash-set! vs* bound Dotted)
vs*)
;; frees -> frees
(define (flip-variances vs)
(hash-map*
(lambda (k v)
(evcase
v
[Covariant Contravariant]
[Contravariant Covariant]
[v v]))
vs))
(define (make-invariant vs)
(hash-map*
(lambda (k v) Invariant)
vs))
(define (hash-map* f ht)
(define new-ht (make-hasheq))
(for ([(k v) (in-hash ht)])
(hash-set! new-ht k (f k v)))
new-ht)
(define (without-below n frees)
(define new-ht (make-hasheq))
(for ([(k v) (in-hash frees)])
(when (>= k n) (hash-set! new-ht k v)))
new-ht)
(define table/c (hash/c (or/c integer? symbol?) variance?))
(p/c [combine-frees (-> (listof table/c) table/c)]
[flip-variances (-> table/c table/c)]
[make-invariant (-> table/c table/c)]
[without-below (-> integer? table/c table/c)])
(provide unless-in-table var-table index-table empty-hash-table fix-bound)
(define-syntax (unless-in-table stx)
(syntax-case stx ()
[(_ table val . body)
(quasisyntax/loc stx
(hash-ref table val #,(syntax/loc #'body (lambda () . body))))]))
;; free-variance.ss ends here

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

@ -28,8 +28,6 @@
;; t must be a Type
(dt Scope ([t (or/c Type/c Scope?)]) [#:key (Type-key t)])
(define (scope-depth k)
(flat-named-contract
(format "Scope of depth ~a" k)
@ -102,7 +100,7 @@
(dt Poly (n body) #:no-provide
[#:contract (->d ([n natural-number/c]
[body (scope-depth n)])
([_ any/c])
()
[result Poly?])]
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
[#:fold-rhs (let ([body* (remove-scopes n body)])
@ -115,7 +113,7 @@
(dt PolyDots (n body) #:no-provide
[#:contract (->d ([n natural-number/c]
[body (scope-depth n)])
([_ any/c])
()
[result PolyDots?])]
[#:key (Type-key body)]
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
@ -231,21 +229,17 @@
;; elems : Listof[Type]
(dt Union ([elems (and/c (listof Type/c)
(flat-named-contract
'sorted-types
(lambda (es)
(let-values ([(sorted? k)
(for/fold ([sorted? #t]
[last -1])
([e es])
(let ([seq (Type-seq e)])
(values
(and sorted?
(< last seq))
seq)))])
(unless sorted?
(printf "seqs ~a~n" (map Type-seq es)))
sorted?))))])
(lambda (es)
(let-values ([(sorted? k)
(for/fold ([sorted? #t]
[last -1])
([e es])
(let ([seq (Type-seq e)])
(values
(and sorted?
(< last seq))
seq)))])
sorted?)))])
[#:frees (combine-frees (map free-vars* elems))
(combine-frees (map free-idxs* elems))]
[#:fold-rhs ((get-union-maker) (map type-rec-id elems))]
@ -347,7 +341,7 @@
[_ (int-err "Tried to remove too many scopes: ~a" sc)])))
;; type equality
(define (type-equal? t1 t2) (eq? (Type-seq t1) (Type-seq t2)))
(define type-equal? eq?)
;; inequality - good
@ -471,8 +465,8 @@
#;(trace instantiate-many abstract-many)
;; the 'smart' constructor
(define (Mu* name body [print-name #f])
(let ([v (*Mu (abstract name body) print-name)])
(define (Mu* name body)
(let ([v (*Mu (abstract name body))])
(hash-set! name-table v name)
v))
@ -483,9 +477,9 @@
(instantiate (*F name) scope)]))
;; the 'smart' constructor
(define (Poly* names body [print-name #f])
(define (Poly* names body)
(if (null? names) body
(let ([v (*Poly (length names) (abstract-many names body) print-name)])
(let ([v (*Poly (length names) (abstract-many names body))])
(hash-set! name-table v names)
v)))
@ -498,9 +492,9 @@
(instantiate-many (map *F names) scope)]))
;; the 'smart' constructor
(define (PolyDots* names body [print-name #f])
(define (PolyDots* names body)
(if (null? names) body
(let ([v (*PolyDots (length names) (abstract-many names body) print-name)])
(let ([v (*PolyDots (length names) (abstract-many names body))])
(hash-set! name-table v names)
v)))
@ -616,7 +610,6 @@
remove-dups
sub-lf sub-lo sub-pe
Values: Values? Values-rs
Type-key Type-seq Type-name type-case
(rename-out [Mu:* Mu:]
[Poly:* Poly:]
[PolyDots:* PolyDots:]

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

@ -2,7 +2,7 @@
(require "../utils/utils.ss")
(require (except-in (rep type-rep object-rep filter-rep rep-utils) Dotted)
(require (rep type-rep object-rep filter-rep)
"printer.ss" "utils.ss"
(utils tc-utils)
scheme/list
@ -15,18 +15,9 @@
(provide (all-defined-out)
(rename-out [make-Listof -lst]))
(define (add-name type name)
(define-values (struct-type skipped?) (struct-info type))
(define mk (struct-type-make-constructor struct-type))
(define flds (vector->list (struct->vector type)))
(when skipped?
(error "shouldn't skip"))
(match flds
[(list* _ fld1 fld2 old-name flds)
(apply mk fld1 fld2 (or old-name name) flds)]))
;; convenient constructors
(define -App make-App)
(define -pair make-Pair)
(define -mpair make-MPair)
@ -130,7 +121,7 @@
(define -Zero (-val 0))
(define -Real (*Un -Flonum -ExactRational))
(define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero))
(define -ExactNonnegativeInteger (*Un -Zero -ExactPositiveInteger))
(define -Nat -ExactNonnegativeInteger)
(define -Byte -Number)

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

@ -46,19 +46,19 @@
(define In-Syntax
(-mu e
(*Un -Boolean -Symbol -String -Keyword -Char -Number
(*Un -Number -Boolean -Symbol -String -Keyword -Char
(make-Vector (-Syntax e))
(make-Box (-Syntax e))
(-mu list
(*Un (-val '())
(-pair (-Syntax e)
(*Un list (-Syntax e))))))))
(*Un (-Syntax e) list)))))))
(define Any-Syntax (-Syntax In-Syntax))
(define (-Sexpof t)
(-mu sexp
(Un -Boolean -Symbol -String -Keyword -Char -Number
(Un -Number -Boolean -Symbol -String -Keyword -Char
(-val '())
(-pair sexp sexp)
(make-Vector sexp)

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

@ -131,7 +131,6 @@
[(Value: '()) null]))
(match c
[(Univ:) (fp "Any")]
[(? Type-name) (fp "~a" (Type-name c))]
[(? has-name?) (fp "~a" (has-name? c))]
;; names are just the printed as the original syntax
[(Name: stx) (fp "~a" (syntax-e stx))]

3
collects/typed-scheme/types/remove-intersect.ss
View File

@ -1,8 +1,7 @@
#lang scheme/base
(require "../utils/utils.ss"
(rep type-rep)
(only-in (rep rep-utils) Type-key)
(rep type-rep rep-utils)
(types union subtype resolve convenience utils)
scheme/match mzlib/trace)

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

@ -1,6 +1,6 @@
#lang scheme/base
(require "../utils/utils.ss"
(except-in (rep type-rep filter-rep object-rep rep-utils) Dotted)
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
(types utils comparison resolve abbrev)
(env type-name-env)

2
collects/typed-scheme/types/union.ss
View File

@ -2,7 +2,7 @@
(require "../utils/utils.ss")
(require (rep type-rep)
(require (rep type-rep rep-utils)
(utils tc-utils)
(types utils subtype abbrev printer comparison)
scheme/match mzlib/trace)

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

@ -2,8 +2,9 @@
(require "../utils/utils.ss")
(require (except-in (rep type-rep filter-rep object-rep rep-utils) Dotted)
(require (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
(only-in (rep free-variance) combine-frees)
scheme/match
scheme/list
mzlib/trace

10
collects/typed-scheme/utils/utils.ss
View File

@ -145,7 +145,7 @@ at least theoretically.
;; - 1 printers have to be defined at the same time as the structs
;; - 2 we want to support things printing corectly even when the custom printer is off
(define-for-syntax printing? #f)
(define-for-syntax printing? #t)
(define-syntax-rule (defprinter t ...)
(begin
@ -170,16 +170,16 @@ at least theoretically.
(define-syntax (define-struct/printer stx)
(syntax-case stx ()
[(form name (flds ...) printer . props)
[(form name (flds ...) printer)
#`(define-struct/properties name (flds ...)
#,(if printing?
#'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))] . props)
#'([prop:custom-write pseudo-printer] . props))
#'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))])
#'([prop:custom-write pseudo-printer]))
#f)]))
;; turn contracts on and off - off by default for performance.
(define-for-syntax enable-contracts? #t)
(define-for-syntax enable-contracts? #f)
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
;; these are versions of the contract forms conditionalized by `enable-contracts?'