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

most of the way to real printing

Browse Source 
svn: r17935

original commit: 8b120675bc02d0ad4396cc3a5ece7b5b19613972
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-02 01:24:06 +00:00
parent 879e22a666
commit cec76e7ad4
8 changed files with 98 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require "../utils/utils.ss" (rep type-rep) scheme/contract)
(require "../utils/utils.ss" (rep type-rep) scheme/contract scheme/match (for-syntax scheme/base syntax/parse))
;; S, T types
;; X a var
@ -29,7 +29,13 @@
;; don't want to rule them out too early
(define-struct cset (maps) #:prefab)
(p/c (struct c ([S Type?] [X symbol?] [T Type?]))
(define-match-expander c:
(lambda (stx)
(syntax-parse stx
[(_ s x t)
#'(struct c ((app (lambda (v) (if (Type? v) v (Un))) s) x (app (lambda (v) (if (Type? v) v Univ)) t)))])))
(p/c (struct c ([S (or/c boolean? Type?)] [X symbol?] [T (or/c boolean? Type?)]))
(struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
(struct dcon-exact ([fixed (listof c?)] [rest c?]))
(struct dcon-dotted ([type c?] [bound symbol?]))

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

@ -428,7 +428,7 @@
(match v
[(struct c (S X T))
(let ([var (hash-ref (free-vars* R) (or variable X) Constant)])
;(printf "variance was: ~a~nR was ~a~nX was ~a~n" var R (or variable X))
;(printf "variance was: ~a~nR was ~a~nX was ~a~nS T ~a ~a~n" var R (or variable X) S T)
(evcase var
[Constant S]
[Covariant S]
@ -440,7 +440,7 @@
(check-vars
must-vars
(append
(for/list ([(k dc) dm])
(for/list ([(k dc) (in-hash dm)])
(match dc
[(struct dcon (fixed rest))
(list k
@ -452,7 +452,7 @@
(for/list ([f fixed])
(constraint->type f #:variable k))
(constraint->type rest))]))
(for/list ([(k v) cmap])
(for/list ([(k v) (in-hash cmap)])
(list k (constraint->type v)))))]))
(define (cgen/list V X S T)

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

@ -50,7 +50,7 @@
[(ormap Bot? t)
(flat-named-contract "t was Bot" (list/c))]
[else (listof Filter/c)])])
()
(#:syntax [stx #f])
[result FilterSet?])])
;; represents no info about the filters of this expression
@ -89,7 +89,7 @@
[(ormap LBot? t)
(flat-named-contract "t was LBot" (list/c))]
[else (listof LatentFilter/c)])])
()
(#:syntax [stx #f])
[result LFilterSet?])])
(define FilterSet/c

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

@ -4,9 +4,12 @@
(utils tc-utils) scheme/list
mzlib/etc scheme/contract)
(provide Covariant Contravariant Invariant Constant Dotted
combine-frees flip-variances without-below unless-in-table empty-hash-table
fix-bound make-invariant variance?)
;; 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)
@ -19,31 +22,11 @@
(values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
(provide Covariant Contravariant Invariant Constant Dotted)
(define (variance? e)
(memq e (list 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 tbl) val) (hash-ref tbl val #f))
#;
(define (free-idxs* t) #;(Type-free-idxs t)
(hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t))))
#;
(define (free-vars* t) #;(Type-free-vars t)
(hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" t))))
(define empty-hash-table (make-immutable-hasheq null))
(provide empty-hash-table make-invariant input/c variance?)
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
;; (listof frees) -> frees
(define (combine-frees freess)
@ -78,8 +61,7 @@
(define (flip-variances vs)
(hash-map*
(lambda (k v)
(evcase
v
(evcase v
[Covariant Contravariant]
[Contravariant Covariant]
[v v]))
@ -102,9 +84,6 @@
(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)

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

@ -5,19 +5,27 @@
(provide defintern hash-id)
(define-syntax (defintern stx)
(define-splicing-syntax-class extra-kw-spec
(pattern (~seq kw:keyword [name:id default:expr])
#:with formal #'(kw [name default])))
(define-splicing-syntax-class extra-spec
(pattern ek:extra-kw-spec
#:with e #'ek.name)
(pattern e:expr))
(syntax-parse stx
[(_ name+args make-name key #:extra-args e:expr ...)
[(_ name+args make-name key #:extra-args e ...)
#'(defintern name+args (lambda () (make-hash)) make-name key #:extra-args e ...)]
[(_ (*name:id arg:id ...) make-ht make-name key-expr #:extra-args e:expr ...)
#'(define *name
(let ([table (make-ht)])
(lambda (arg ...)
(let ([key key-expr])
(hash-ref table key
(lambda ()
(let ([new (make-name (count!) e ... arg ...)])
(hash-set! table key new)
new)))))))]))
[(_ (*name:id arg:id ...) make-ht make-name key-expr #:extra-args . (~and ((~seq es:extra-spec) ...) ((~or (~seq ek:extra-kw-spec) e:expr) ...)))
(with-syntax ([((extra-formals ...) ...) #'(ek.formal ...)])
#'(define *name
(let ([table (make-ht)])
(lambda (arg ... extra-formals ... ...)
(let ([key key-expr])
(hash-ref table key
(lambda ()
(let ([new (make-name (count!) es.e ... arg ...)])
(hash-set! table key new)
new))))))))]))
(define (make-count!)
(let ([state 0])

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

@ -25,27 +25,26 @@
(provide == defintern hash-id (for-syntax fold-target))
(define-struct Rep (seq
free-vars
free-idxs))
(define-struct Rep (seq free-vars free-idxs stx))
(define-for-syntax fold-target #'fold-target)
(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs))
(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs #'stx))
(define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id
#:attributes (i cnt)
(pattern i:id
#:with cnt #'any/c)
(pattern [i:id cnt]))
(define-syntax-class no-provide-kw
(pattern #:no-provide))
(define-syntax-class idlist
#:attributes ((i 1) (cnt 1) fs)
(pattern [i:id cnt]))
;; fields
(define-syntax-class (idlist name)
#:attributes ((i 1) (cnt 1) fs maker pred (acc 1))
(pattern (oci:opt-cnt-id ...)
#:with (i ...) #'(oci.i ...)
#:with (cnt ...) #'(oci.cnt ...)
#:with fs #'(i ...)))
#:with fs #'(i ...)
#:with (_ maker pred acc ...) (build-struct-names name (syntax->list #'fs) #f #t name)))
(define (combiner f flds)
(syntax-parse flds
[() #'empty-hash-table]
@ -53,15 +52,12 @@
[(e ...) #`(combine-frees (list (#,f e) ...))]))
(define-splicing-syntax-class frees-pat
#:transparent
#:attributes (f1 f2 def)
(pattern (~seq f1:expr f2:expr)
#:with def #'(begin))
#:attributes (f1 f2)
(pattern (~seq f1:expr f2:expr))
(pattern #f
#:with f1 #'empty-hash-table
#:with f2 #'empty-hash-table
#:with def #'(begin))
#:with f2 #'empty-hash-table)
(pattern e:expr
#:with def #'(begin)
#:with f1 #'(e Rep-free-vars)
#:with f2 #'(e Rep-free-idxs)))
(define-syntax-class (fold-pat fold-name)
@ -85,39 +81,40 @@
#:with *maker (format-id #'nm "*~a" #'nm)))
(lambda (stx)
(syntax-parse stx
[(dform nm:form-nm flds:idlist (~or
(~optional (~and (~fail #:unless key? "#:key not allowed")
[#:key key-expr:expr])
#:defaults ([key-expr #'#f]))
(~optional [#:intern intern?:expr]
#:defaults
([intern? (syntax-parse #'flds.fs
[() #'#f]
[(f) #'f]
[(fs ...) #'(list fs ...)])]))
(~optional [#:frees frees:frees-pat]
#:defaults
([frees.def #'(begin)]
[frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
[frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
(~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
#:defaults
([fold-rhs.proc
#'(procedure-rename
(lambda ()
#`(nm.*maker (#,type-rec-id flds.i) ...))
'nm.fold)]))
(~optional [#:contract cnt:expr])
(~optional no-provide?:no-provide-kw)) ...)
(with-syntax*
([(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
[*maker-cnt (or (attribute cnt) #'(flds.cnt ... . -> . pred))]
[(dform nm:form-nm
(~var flds (idlist #'nm))
(~or
(~optional (~and (~fail #:unless key? "#:key not allowed")
[#:key key-expr:expr])
#:defaults ([key-expr #'#f]))
(~optional [#:intern intern?:expr]
#:defaults
([intern? (syntax-parse #'flds.fs
[() #'#f]
[(f) #'f]
[(fs ...) #'(list fs ...)])]))
(~optional [#:frees frees:frees-pat]
#:defaults
([frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
[frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
(~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
#:defaults
([fold-rhs.proc
#'(procedure-rename
(lambda ()
#`(nm.*maker (#,type-rec-id flds.i) ...))
'nm.fold)]))
(~optional [#:contract cnt:expr]
#:defaults ([cnt #'((flds.cnt ...) (#:syntax (or/c syntax? #f)) . ->* . flds.pred)]))
(~optional (~and #:no-provide no-provide?))) ...)
(with-syntax
([(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))]
;; has to be down here to refer to #'cnt
[provides (if (attribute no-provide?)
#'(begin)
#`(begin
(provide nm.ex pred acc ...)
(p/c (rename nm.*maker maker *maker-cnt))))]
[(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))])
#'(begin)
#'(begin
(provide nm.ex flds.pred flds.acc ...)
(p/c (rename nm.*maker flds.maker cnt))))])
#`(begin
(define-struct (nm #,par) flds.fs #:inspector #f)
(define-match-expander nm.ex
@ -129,13 +126,12 @@
(begin-for-syntax
(hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f)))
#,(quasisyntax/loc stx
(w/c nm ([nm.*maker *maker-cnt])
(w/c nm ([nm.*maker cnt])
#,(quasisyntax/loc #'nm
(defintern (nm.*maker . flds.fs) maker intern?
(defintern (nm.*maker . flds.fs) flds.maker intern?
#:extra-args
frees.f1 frees.f2
#,@(begin
(if key? (list #'key-expr) null))))))
frees.f1 frees.f2 #:syntax [orig-stx #f]
#,@(if key? (list #'key-expr) null)))))
provides))])))
(define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
@ -252,4 +248,5 @@
(p/c (struct Rep ([seq integer?]
[free-vars (hash/c symbol? variance?)]
[free-idxs (hash/c exact-nonnegative-integer? variance?)])))
[free-idxs (hash/c exact-nonnegative-integer? variance?)]
[stx (or/c #f syntax?)])))

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

@ -100,7 +100,7 @@
(dt Poly (n body) #:no-provide
[#:contract (->d ([n natural-number/c]
[body (scope-depth n)])
()
(#:syntax [stx (or/c #f syntax?)])
[result Poly?])]
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
[#:fold-rhs (let ([body* (remove-scopes n body)])
@ -113,7 +113,7 @@
(dt PolyDots (n body) #:no-provide
[#:contract (->d ([n natural-number/c]
[body (scope-depth n)])
()
(#:syntax [stx (or/c #f syntax?)])
[result PolyDots?])]
[#:key (Type-key body)]
[#:frees (free-vars* body) (without-below n (free-idxs* body))]

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

@ -511,13 +511,13 @@
[(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...))
(check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
;; ormap/andmap of ... argument
[(#%plain-app or/andmap:id f arg)
#:fail-unless (or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap)) #f
#:fail-unless (with-handlers ([exn:fail? (lambda _ #f)])
(tc/dots #'arg)
#t) #f
(let-values ([(ty bound) (tc/dots #'arg)])
[(#%plain-app (~or (~literal andmap) (~literal ormap)) f arg)
#:attr ty+bound
(with-handlers ([exn:fail? (lambda _ #f)])
(let-values ([(ty bound) (tc/dots #'arg)])
(list ty bound)))
#:when (attribute ty+bound)
(match-let ([(list ty bound) (attribute ty+bound)])
(parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound)))
(current-tvars))])
@ -677,6 +677,7 @@
(and vars (list fixed-vars ... dotted-var))
(Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))))
(list (tc-result1: argtys-t) ...))
(printf "poly clause 1~n")
(handle-clauses (doms rngs rests drests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
(lambda (dom _ rest drest a)