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

New representation for free variables, now stored in struct.

Browse Source 
Interning now merely used to create key, eq? not = for types.

svn: r18107
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-17 00:09:38 +00:00
parent 0920b493c8
commit 1039e68e03
18 changed files with 274 additions and 303 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 #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 ;; S, T types
;; X a var ;; X a var
@ -29,7 +29,13 @@
;; don't want to rule them out too early ;; don't want to rule them out too early
(define-struct cset (maps) #:prefab) (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 ([fixed (listof c?)] [rest (or/c c? false/c)]))
(struct dcon-exact ([fixed (listof c?)] [rest c?])) (struct dcon-exact ([fixed (listof c?)] [rest c?]))
(struct dcon-dotted ([type c?] [bound symbol?])) (struct dcon-dotted ([type c?] [bound symbol?]))

2
collects/typed-scheme/infer/constraints.ss
View File

@ -13,7 +13,7 @@
(define-values (fail-sym exn:infer?) (define-values (fail-sym exn:infer?)
(let ([sym (gensym)]) (let ([sym (gensym 'infer-fail)])
(values sym (lambda (s) (eq? s sym))))) (values sym (lambda (s) (eq? s sym)))))
;; why does this have to be duplicated? ;; why does this have to be duplicated?

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

@ -12,7 +12,7 @@
scheme/match scheme/match
mzlib/etc mzlib/etc
mzlib/trace mzlib/trace
unstable/sequence unstable/list unstable/sequence unstable/list unstable/debug
scheme/list) scheme/list)
(import dmap^ constraints^ promote-demote^) (import dmap^ constraints^ promote-demote^)
@ -254,7 +254,7 @@
(insert empty X S T)) (insert empty X S T))
(if (seen? S T) (if (seen? S T)
empty empty
(parameterize ([match-equality-test type-equal?] (parameterize ([match-equality-test (lambda (a b) (if (and (Rep? a) (Rep? b)) (type-equal? a b) (equal? a b)))]
[current-seen (remember S T (current-seen))]) [current-seen (remember S T (current-seen))])
(match* (match*
(S T) (S T)
@ -428,7 +428,7 @@
(match v (match v
[(struct c (S X T)) [(struct c (S X T))
(let ([var (hash-ref (free-vars* R) (or variable X) Constant)]) (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 (evcase var
[Constant S] [Constant S]
[Covariant S] [Covariant S]
@ -440,7 +440,7 @@
(check-vars (check-vars
must-vars must-vars
(append (append
(for/list ([(k dc) dm]) (for/list ([(k dc) (in-hash dm)])
(match dc (match dc
[(struct dcon (fixed rest)) [(struct dcon (fixed rest))
(list k (list k
@ -452,7 +452,7 @@
(for/list ([f fixed]) (for/list ([f fixed])
(constraint->type f #:variable k)) (constraint->type f #:variable k))
(constraint->type rest))])) (constraint->type rest))]))
(for/list ([(k v) cmap]) (for/list ([(k v) (in-hash cmap)])
(list k (constraint->type v)))))])) (list k (constraint->type v)))))]))
(define (cgen/list V X S T) (define (cgen/list V X S T)

12
collects/typed-scheme/private/base-env-indexing-abs.ss
View File

@ -44,6 +44,18 @@
(-StrRx -String [N ?N ?outp] . ->opt . (optlist -String)) (-StrRx -String [N ?N ?outp] . ->opt . (optlist -String))
(-BtsRx -String [N ?N ?outp] . ->opt . (optlist -Bytes)) (-BtsRx -String [N ?N ?outp] . ->opt . (optlist -Bytes))
(-Pattern -InpBts [N ?N ?outp] . ->opt . (optlist -Bytes))))] (-Pattern -InpBts [N ?N ?outp] . ->opt . (optlist -Bytes))))]
[regexp-match?
(let ([?outp (-opt -Output-Port)]
[N -Nat]
[?N (-opt -Nat)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (Un -String -Regexp -PRegexp)]
[-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (Un -Input-Port -Bytes)])
(cl->*
(-StrRx -String [N ?N ?outp] . ->opt . -Boolean)
(-BtsRx -String [N ?N ?outp] . ->opt . -Boolean)
(-Pattern -InpBts [N ?N ?outp] . ->opt . -Boolean)))]
[regexp-match* [regexp-match*
(let ([N -Nat] (let ([N -Nat]
[?N (-opt -Nat)] [?N (-opt -Nat)]

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

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

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

@ -4,9 +4,12 @@
(utils tc-utils) scheme/list (utils tc-utils) scheme/list
mzlib/etc scheme/contract) 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 ;; this file contains support for calculating the free variables/indexes of types
;; actual computation is done in rep-utils.ss and type-rep.ss ;; actual computation is done in rep-utils.ss and type-rep.ss
(define-values (Covariant Contravariant Invariant Constant Dotted) (define-values (Covariant Contravariant Invariant Constant Dotted)
(let () (let ()
(define-struct Variance () #:inspector #f) (define-struct Variance () #:inspector #f)
@ -19,31 +22,11 @@
(values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted)))) (values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
(provide Covariant Contravariant Invariant Constant Dotted)
(define (variance? e) (define (variance? e)
(memq e (list Covariant Contravariant Invariant Constant Dotted))) (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)
(hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" t))))
(define (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)) (define empty-hash-table (make-immutable-hasheq null))
(p/c [free-vars* (-> (input/c var-table) (hash/c symbol? variance?))]
[free-idxs* (-> (input/c index-table) (hash/c exact-nonnegative-integer? variance?))])
(provide empty-hash-table make-invariant)
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
;; (listof frees) -> frees ;; (listof frees) -> frees
(define (combine-frees freess) (define (combine-frees freess)
@ -78,8 +61,7 @@
(define (flip-variances vs) (define (flip-variances vs)
(hash-map* (hash-map*
(lambda (k v) (lambda (k v)
(evcase (evcase v
v
[Covariant Contravariant] [Covariant Contravariant]
[Contravariant Covariant] [Contravariant Covariant]
[v v])) [v v]))
@ -102,9 +84,6 @@
(when (>= k n) (hash-set! new-ht k v))) (when (>= k n) (hash-set! new-ht k v)))
new-ht) 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) (define-syntax (unless-in-table stx)
(syntax-case stx () (syntax-case stx ()
[(_ table val . body) [(_ table val . body)

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

@ -5,21 +5,27 @@
(provide defintern hash-id) (provide defintern hash-id)
(define-syntax (defintern stx) (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 (syntax-parse stx
[(_ name+args make-name key (~optional (~seq #:extra-arg e:expr)) ...) [(_ name+args make-name key #:extra-args e ...)
(if (attribute e) #'(defintern name+args (lambda () (make-hash)) make-name key #:extra-args e ...)]
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e) [(_ (*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) ...)))
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))] (with-syntax ([((extra-formals ...) ...) #'(ek.formal ...)])
[(_ (*name:id arg:id ...) make-ht make-name key-expr (~seq #:extra-arg e:expr) ...) #'(define *name
#'(define *name (let ([table (make-ht)])
(let ([table (make-ht)]) (lambda (arg ... extra-formals ... ...)
(lambda (arg ...) (let ([key key-expr])
(let ([key key-expr]) (hash-ref table key
(hash-ref table key (lambda ()
(lambda () (let ([new (make-name (count!) es.e ... arg ...)])
(let ([new (make-name (count!) e ... arg ...)]) (hash-set! table key new)
(hash-set! table key new) new))))))))]))
new)))))))]))
(define (make-count!) (define (make-count!)
(let ([state 0]) (let ([state 0])

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

@ -25,7 +25,10 @@
(provide == defintern hash-id (for-syntax fold-target)) (provide == defintern hash-id (for-syntax fold-target))
(define-struct Rep (seq free-vars free-idxs stx))
(define-for-syntax fold-target #'fold-target) (define-for-syntax fold-target #'fold-target)
(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs #'stx))
(define-for-syntax (mk par ht-stx key?) (define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id (define-syntax-class opt-cnt-id
@ -33,14 +36,15 @@
(pattern i:id (pattern i:id
#:with cnt #'any/c) #:with cnt #'any/c)
(pattern [i:id cnt])) (pattern [i:id cnt]))
(define-syntax-class no-provide-kw ;; fields
(pattern #:no-provide)) (define-syntax-class (idlist name)
(define-syntax-class idlist #:attributes ((i 1) (cnt 1) fs maker pred (acc 1))
#:attributes ((i 1) (cnt 1) fs)
(pattern (oci:opt-cnt-id ...) (pattern (oci:opt-cnt-id ...)
#:with (i ...) #'(oci.i ...) #:with (i ...) #'(oci.i ...)
#:with (cnt ...) #'(oci.cnt ...) #: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) (define (combiner f flds)
(syntax-parse flds (syntax-parse flds
[() #'empty-hash-table] [() #'empty-hash-table]
@ -48,130 +52,91 @@
[(e ...) #`(combine-frees (list (#,f e) ...))])) [(e ...) #`(combine-frees (list (#,f e) ...))]))
(define-splicing-syntax-class frees-pat (define-splicing-syntax-class frees-pat
#:transparent #:transparent
#:attributes (f1 f2 def) #:attributes (f1 f2)
(pattern (~seq f1:expr f2:expr) (pattern (~seq f1:expr f2:expr))
#:with def #'(begin))
(pattern #f (pattern #f
#:with f1 #'empty-hash-table #:with f1 #'empty-hash-table
#:with f2 #'empty-hash-table #:with f2 #'empty-hash-table)
#:with def #'(begin))
(pattern e:expr (pattern e:expr
#:with id (generate-temporary) #:with f1 #'(e Rep-free-vars)
#:with def #'(define id e) #:with f2 #'(e Rep-free-idxs)))
#:with f1 #'(id free-vars*) (define-syntax-class (fold-pat fold-name)
#:with f2 #'(id free-idxs*)))
(define-syntax-class fold-pat
#:transparent #:transparent
#:attributes (e) #:attributes (e proc)
(pattern #:base (pattern #:base
#:with e fold-target) #:with e fold-target
#:with proc #`(procedure-rename
(lambda () #,fold-target)
'#,fold-name))
(pattern ex:expr (pattern ex:expr
#:with e #'#'ex)) #:with e #'#'ex
#:with proc #`(procedure-rename
(lambda () #'ex)
'#,fold-name)))
(define-syntax-class form-nm
(pattern nm:id
#:with ex (format-id #'nm "~a:" #'nm)
#:with fold (format-id #f "~a-fold" #'nm)
#:with kw (string->keyword (symbol->string (syntax-e #'nm)))
#:with *maker (format-id #'nm "*~a" #'nm)))
(lambda (stx) (lambda (stx)
(syntax-parse stx (syntax-parse stx
[(dform nm:id flds:idlist (~or [(dform nm:form-nm
(~optional [#:key key-expr:expr]) (~var flds (idlist #'nm))
(~optional [#:intern intern?:expr]) (~or
(~optional [#:frees frees:frees-pat]) (~optional (~and (~fail #:unless key? "#:key not allowed")
(~optional [#:fold-rhs fold-rhs:fold-pat]) [#:key key-expr:expr])
(~optional [#:contract cnt:expr]) #:defaults ([key-expr #'#f]))
(~optional no-provide?:no-provide-kw)) ...) (~optional [#:intern intern?:expr]
(with-syntax* #:defaults
([ex (format-id #'nm "~a:" #'nm)] ([intern? (syntax-parse #'flds.fs
[fold-name (format-id #f "~a-fold" #'nm)] [() #'#f]
[kw-stx (string->keyword (symbol->string (attribute nm.datum)))] [(f) #'f]
[parent par] [(fs ...) #'(list fs ...)])]))
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] (~optional [#:frees frees:frees-pat]
[*maker (format-id #'nm "*~a" #'nm)] #:defaults
[**maker (format-id #'nm "**~a" #'nm)] ([frees.f1 (combiner #'Rep-free-vars #'flds.fs)]
[*maker-cnt (if enable-contracts? [frees.f2 (combiner #'Rep-free-idxs #'flds.fs)]))
(or (attribute cnt) #'(flds.cnt ... . -> . pred)) (~optional [#:fold-rhs (~var fold-rhs (fold-pat #'nm.fold))]
#'any/c)] #:defaults
[ht-stx ht-stx] ([fold-rhs.proc
[bfs-fold-rhs (cond [(attribute fold-rhs) #'(procedure-rename
#`(procedure-rename (lambda ()
(lambda () #,#'fold-rhs.e) #`(nm.*maker (#,type-rec-id flds.i) ...))
'fold-name)] 'nm.fold)]))
;; otherwise we assume that everything is a type, (~optional [#:contract cnt:expr]
;; and recur on all the arguments #:defaults ([cnt #'((flds.cnt ...) (#:syntax (or/c syntax? #f)) . ->* . flds.pred)]))
[else #'(procedure-rename (~optional (~and #:no-provide no-provide?))) ...)
(lambda () (with-syntax
#`(*maker (#,type-rec-id flds.i) ...)) ([(ign-pats ...) (append (map (lambda (x) #'_) default-fields) (if key? (list #'_) (list)))]
'fold-name)])] ;; has to be down here to refer to #'cnt
[provides (if (attribute no-provide?) [provides (if (attribute no-provide?)
#'(begin) #'(begin)
#`(begin #'(begin
(provide #;nm ex pred acc ...) (provide nm.ex flds.pred flds.acc ...)
(p/c (rename *maker maker *maker-cnt))))] (p/c (rename nm.*maker flds.maker cnt))))])
[intern
(let ([mk (lambda (int)
(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)))])
(quasisyntax/loc stx
(w/c nm ([*maker *maker-cnt])
(define (*maker . flds.fs)
(define v (**maker . flds.fs))
frees-def
(unless-in-table
var-table v
(define fvs f1)
(define fis f2)
(hash-set! var-table v fvs)
(hash-set! index-table v fis))
v))))])
#`(begin #`(begin
(define-struct (nm parent) flds.fs #:inspector #f) (define-struct (nm #,par) flds.fs #:inspector #f)
(define-match-expander ex (define-match-expander nm.ex
(lambda (s) (lambda (s)
(syntax-parse s (syntax-parse s
[(_ . fs) [(_ . fs)
#:with pat (syntax/loc s (ign-pats ... . fs)) #:with pat (syntax/loc s (ign-pats ... . fs))
(syntax/loc s (struct nm pat))]))) (syntax/loc s (struct nm pat))])))
(begin-for-syntax (begin-for-syntax
(hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx))) (hash-set! #,ht-stx 'nm.kw (list #'nm.ex #'flds.fs fold-rhs.proc #f)))
(w/c nm () #,(quasisyntax/loc stx
intern (w/c nm ([nm.*maker cnt])
frees) #,(quasisyntax/loc #'nm
provides))]))) (defintern (nm.*maker . flds.fs) flds.maker intern?
#:extra-args
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) (define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
(lambda (stx) (lambda (stx)
(define new-ht (hash-copy ht)) (define new-ht (hash-copy ht))
(define (mk-matcher kw)
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
(define/contract (put k lst)
(keyword? (list/c syntax?
syntax?
(-> syntax?)
syntax?)
. -> . void?)
(hash-set! new-ht k lst))
(define (add-clause cl)
(syntax-parse cl
[(kw:keyword #:matcher mtch pats ... expr)
(put (syntax-e #'kw) (list #'mtch
(syntax/loc cl (pats ...))
(lambda () #'expr)
cl))]
[(kw:keyword pats ... expr)
(put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
(syntax/loc cl (pats ...))
(lambda () #'expr)
cl))]))
(define-syntax-class clause (define-syntax-class clause
(pattern (pattern
(k:keyword #:matcher mtch pats ... e:expr) (k:keyword #:matcher mtch pats ... e:expr)
@ -183,111 +148,105 @@
(pattern (pattern
(k:keyword pats ... e:expr) (k:keyword pats ... e:expr)
#:attr kw (syntax-e #'k) #:attr kw (syntax-e #'k)
#:attr val (list (mk-matcher (attribute kw)) #:attr val (list (format-id stx "~a:" (attribute kw))
(syntax/loc this-syntax (pats ...)) (syntax/loc this-syntax (pats ...))
(lambda () #'e) (lambda () #'e)
this-syntax))) this-syntax)))
(define (gen-clause k v) (define (gen-clause k v)
(match v (match v
[(list match-ex pats body-f src) [(list match-ex pats body-f src)
(let ([pat (quasisyntax/loc src (#,match-ex . #,pats))]) (let ([pat (quasisyntax/loc (or stx stx) (#,match-ex . #,pats))])
(quasisyntax/loc src (#,pat #,(body-f))))])) (quasisyntax/loc (or src stx) (#,pat #,(body-f))))]))
(define-syntax-class (keyword-in kws) (define-syntax-class (keyword-in kws)
#:attributes (datum) #:attributes (datum)
(pattern k:keyword (pattern k:keyword
#:fail-unless (memq (attribute k.datum) kws) #f #:fail-unless (memq (attribute k.datum) kws) (format "expected keyword in ~a" kws)
#:attr datum (attribute k.datum))) #:attr datum (attribute k.datum)))
(define-syntax-class (sized-list kws) (define-syntax-class (sized-list kws)
#:description (format "keyword expr pairs matching with keywords in the list ~a" kws) #:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
(pattern ((~or (~seq k e:expr)) ...) (pattern ((~or (~seq (~var k (keyword-in kws)) e:expr)) ...)
#:declare k (keyword-in kws) #:when (equal? (length (attribute k.datum))
#:fail-unless (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum)))) #f (length (remove-duplicates (attribute k.datum))))
#:attr mapping (for/hash ([k* (attribute k.datum)] #:attr mapping (for/hash ([k* (attribute k.datum)]
[e* (attribute e)]) [e* (attribute e)])
(values k* e*)) (values k* e*))))
))
(syntax-parse stx (syntax-parse stx
[(tc recs ty clauses:clause ...) [(tc (~var recs (sized-list kws)) ty clauses:clause ...)
#:declare recs (sized-list kws) (for ([k (attribute clauses.kw)]
(begin [v (attribute clauses.val)])
(for ([k (attribute clauses.kw)] (hash-set! new-ht k v))
[v (attribute clauses.val)]) (with-syntax ([(let-clauses ...)
(put k v)) (for/list ([rec-id rec-ids]
(with-syntax ([(let-clauses ...) [k kws])
(for/list ([rec-id rec-ids] #`[#,rec-id #,(hash-ref (attribute recs.mapping) k
[k kws]) #'values)])]
#`[#,rec-id #,(hash-ref (attribute recs.mapping) k [(match-clauses ...)
#'values)])]) (hash-map new-ht gen-clause)])
#`(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
#,@(hash-map new-ht gen-clause))))))]))) match-clauses ...))))])))
(define-syntax (make-prim-type stx) (define-syntax (make-prim-type stx)
(define default-flds #'(seq))
(define-syntax-class type-name-base (define-syntax-class type-name-base
#:attributes (i lower-s first-letter key? (fld-names 1)) #:attributes (i d-id key? (fld-names 1))
#:transparent #:transparent
(pattern i:id (pattern [i:id (~optional (~and #:key
#:attr lower-s (string-downcase (symbol->string (attribute i.datum))) (~bind [key? #'#t]
#:with (fld-names ...) default-flds [(fld-names 1) (list #'key)]))
#:with key? #'#f #:defaults ([key? #'#f]
#:attr first-letter (string-ref (attribute lower-s) 0)) [(fld-names 1) null]))
(pattern [i:id #:d d-name:id] #:d d-id:id]))
#:with (fld-names ...) default-flds
#:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with key? #'#f
#:attr first-letter (symbol->string (attribute d-name.datum)))
(pattern [i:id #:key]
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(syntax->list #'(key))))
#:attr lower-s (string-downcase (symbol->string (attribute i.datum)))
#:with key? #'#t
#:attr first-letter (string-ref (attribute lower-s) 0)))
(define-syntax-class type-name (define-syntax-class type-name
#:transparent #:transparent
#:auto-nested-attributes #:auto-nested-attributes
(pattern :type-name-base (pattern :type-name-base
#:with lower-s (string->symbol (string-downcase (symbol->string (syntax-e #'i))))
#:with name #'i #:with name #'i
#:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i)))) #:with keyword (string->keyword (symbol->string (syntax-e #'i)))
#:with tmp-rec-id (generate-temporary) #:with tmp-rec-id (generate-temporary)
#:with case (format-id #'i "~a-case" (attribute lower-s)) #:with case (format-id #'i "~a-case" #'lower-s)
#:with printer (format-id #'i "print-~a*" (attribute lower-s)) #:with printer (format-id #'i "print-~a*" #'lower-s)
#:with ht (format-id #'i "~a-name-ht" (attribute lower-s)) #:with ht (format-id #'i "~a-name-ht" #'lower-s)
#:with rec-id (format-id #'i "~a-rec-id" (attribute lower-s)) #:with rec-id (format-id #'i "~a-rec-id" #'lower-s)
#:with d-id (format-id #'i "d~a" (attribute first-letter))
#:with (_ _ pred? accs ...) #:with (_ _ pred? accs ...)
(datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))) (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))
(syntax-parse stx (syntax-parse stx
[(_ i:type-name ...) [(_ i:type-name ...)
(with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))] #'(begin
[(default-ids ...) (generate-temporaries #'(i.name ...))] (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
[fresh-ids-list #'(fresh-ids ...)] (for-syntax i.ht ... i.rec-id ...))
[(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)]) (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
#'(begin (define-for-syntax i.ht (make-hasheq)) ...
(provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ... (define-struct/printer (i.name Rep) (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
(for-syntax i.ht ... i.rec-id ...)) (define-for-syntax i.rec-id #'i.rec-id) ...
(define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ... (provide i.case ...)
(define-for-syntax i.ht (make-hasheq)) ... (define-syntaxes (i.case ...)
(define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ... (let ()
(define-for-syntax i.rec-id #'i.rec-id) ... (apply values
(provide i.case ...) (map (lambda (ht)
(define-syntaxes (i.case ...) (define rec-ids (list i.rec-id ...))
(let () (mk-fold ht
(apply values (car rec-ids)
(map (lambda (ht) rec-ids
(mk-fold ht '(i.keyword ...)))
(car (list #'i.rec-id ...)) (list i.ht ...))))))]))
(list #'i.rec-id ...)
'(i.keyword ...)))
(list i.ht ...)))))))]))
(make-prim-type [Type #:key] (make-prim-type [Type #:key #:d dt]
Filter [Filter #:d df]
[LatentFilter #:d lf] [LatentFilter #:d dlf]
Object [Object #:d do]
[LatentObject #:d lo] [LatentObject #:d dlo]
[PathElem #:d pe]) [PathElem #:d dpe])
(provide PathElem? (rename-out [Rep-seq Type-seq]
[Rep-free-vars free-vars*]
[Rep-free-idxs free-idxs*]))
(p/c (struct Rep ([seq exact-nonnegative-integer?]
[free-vars (hash/c symbol? variance?)]
[free-idxs (hash/c exact-nonnegative-integer? variance?)]
[stx (or/c #f syntax?)])))

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

@ -100,7 +100,7 @@
(dt Poly (n body) #:no-provide (dt Poly (n body) #:no-provide
[#:contract (->d ([n natural-number/c] [#:contract (->d ([n natural-number/c]
[body (scope-depth n)]) [body (scope-depth n)])
() (#:syntax [stx (or/c #f syntax?)])
[result Poly?])] [result Poly?])]
[#:frees (free-vars* body) (without-below n (free-idxs* body))] [#:frees (free-vars* body) (without-below n (free-idxs* body))]
[#:fold-rhs (let ([body* (remove-scopes n body)]) [#:fold-rhs (let ([body* (remove-scopes n body)])
@ -113,7 +113,7 @@
(dt PolyDots (n body) #:no-provide (dt PolyDots (n body) #:no-provide
[#:contract (->d ([n natural-number/c] [#:contract (->d ([n natural-number/c]
[body (scope-depth n)]) [body (scope-depth n)])
() (#:syntax [stx (or/c #f syntax?)])
[result PolyDots?])] [result PolyDots?])]
[#:key (Type-key body)] [#:key (Type-key body)]
[#:frees (free-vars* body) (without-below n (free-idxs* body))] [#:frees (free-vars* body) (without-below n (free-idxs* body))]
@ -238,25 +238,24 @@
;; elems : Listof[Type] ;; elems : Listof[Type]
(dt Union ([elems (and/c (listof Type/c) (dt Union ([elems (and/c (listof Type/c)
(lambda (es) (lambda (es)
(let-values ([(sorted? k) (or (null? es)
(for/fold ([sorted? #t] (let-values ([(sorted? k)
[last -1]) (for/fold ([sorted? #t]
([e es]) [last (car es)])
(let ([seq (Type-seq e)]) ([e (cdr es)])
(values (values
(and sorted? (and sorted? (type<? last e))
(< last seq)) e))])
seq)))]) sorted?))))])
sorted?)))])
[#:frees (combine-frees (map free-vars* elems)) [#:frees (combine-frees (map free-vars* elems))
(combine-frees (map free-idxs* elems))] (combine-frees (map free-idxs* elems))]
[#:fold-rhs ((get-union-maker) (map type-rec-id elems))] [#:fold-rhs ((get-union-maker) (map type-rec-id elems))]
[#:key (let loop ([res null] [ts elems]) [#:key (let loop ([res null] [ts elems])
(if (null? ts) res (if (null? ts) res
(let ([k (Type-key (car ts))]) (let ([k (Type-key (car ts))])
(cond [(pair? k) (loop (append k res) (cdr ts))] (cond [(pair? k) (loop (append k res) (cdr ts))]
[k (loop (cons k res) (cdr ts))] [k (loop (cons k res) (cdr ts))]
[else #f]))))]) [else #f]))))])
(dt Univ () [#:frees #f] [#:fold-rhs #:base]) (dt Univ () [#:frees #f] [#:fold-rhs #:base])
@ -327,7 +326,8 @@
;; remove-dups: List[Type] -> List[Type] ;; remove-dups: List[Type] -> List[Type]
;; removes duplicate types from a SORTED list ;; removes duplicate types from a SORTED list
(define (remove-dups types) (d/c (remove-dups types)
((listof Rep?) . -> . (listof Rep?))
(cond [(null? types) types] (cond [(null? types) types]
[(null? (cdr types)) types] [(null? (cdr types)) types]
[(type-equal? (car types) (cadr types)) (remove-dups (cdr types))] [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))]
@ -349,15 +349,16 @@
[_ (int-err "Tried to remove too many scopes: ~a" sc)]))) [_ (int-err "Tried to remove too many scopes: ~a" sc)])))
;; type equality ;; type equality
(define type-equal? eq?) (d/c (type-equal? s t) (Rep? Rep? . -> . boolean?) (eq? (Rep-seq s) (Rep-seq t)))
;; inequality - good ;; inequality - good
(d/c (type<? s t)
(Rep? Rep? . -> . boolean?)
(< (Rep-seq s) (Rep-seq t)))
(define (type<? s t) (d/c (type-compare s t)
(< (Type-seq s) (Type-seq t))) (Rep? Rep? . -> . (or/c -1 0 1))
(cond [(type-equal? s t) 0]
(define (type-compare s t)
(cond [(eq? s t) 0]
[(type<? s t) 1] [(type<? s t) 1]
[else -1])) [else -1]))
@ -614,7 +615,7 @@
Poly-n Poly-n
PolyDots-n PolyDots-n
free-vars* free-vars*
type-equal? type-compare type<? type-compare type<?
remove-dups remove-dups
sub-lf sub-lo sub-pe sub-lf sub-lo sub-pe
Values: Values? Values-rs Values: Values? Values-rs
@ -628,4 +629,6 @@
[Poly-body* Poly-body] [Poly-body* Poly-body]
[PolyDots-body* PolyDots-body])) [PolyDots-body* PolyDots-body]))
(p/c [type-equal? (Rep? Rep? . -> . boolean?)])
;(trace unfold) ;(trace unfold)

4
collects/typed-scheme/typecheck/check-subforms-unit.ss
View File

@ -3,7 +3,7 @@
(require "../utils/utils.ss" (require "../utils/utils.ss"
syntax/kerncase syntax/kerncase
syntax/parse syntax/parse
scheme/match scheme/match unstable/debug
"signatures.ss" "tc-metafunctions.ss" "signatures.ss" "tc-metafunctions.ss"
(types utils convenience union subtype) (types utils convenience union subtype)
(utils tc-utils) (utils tc-utils)
@ -14,7 +14,7 @@
;; find the subexpressions that need to be typechecked in an ignored form ;; find the subexpressions that need to be typechecked in an ignored form
;; syntax -> any ;; syntax -> any
(define (check-subforms/with-handlers form) (define (check-subforms/with-handlers form [expected #f])
(define handler-tys '()) (define handler-tys '())
(define body-ty #f) (define body-ty #f)
(define (get-result-ty t) (define (get-result-ty t)

14
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) ...)) [(#%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 ...))] (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
;; ormap/andmap of ... argument ;; ormap/andmap of ... argument
[(#%plain-app or/andmap:id f arg) [(#%plain-app (~or (~literal andmap) (~literal ormap)) f arg)
#:fail-unless (or (free-identifier=? #'or/andmap #'ormap) #:attr ty+bound
(free-identifier=? #'or/andmap #'andmap)) #f (with-handlers ([exn:fail? (lambda _ #f)])
#:fail-unless (with-handlers ([exn:fail? (lambda _ #f)]) (let-values ([(ty bound) (tc/dots #'arg)])
(tc/dots #'arg) (list ty bound)))
#t) #f #:when (attribute ty+bound)
(let-values ([(ty bound) (tc/dots #'arg)]) (match-let ([(list ty bound) (attribute ty+bound)])
(parameterize ([current-tvars (extend-env (list bound) (parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound))) (list (make-DottedBoth (make-F bound)))
(current-tvars))]) (current-tvars))])

2
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -259,7 +259,7 @@
(with-lexical-env/extend (with-lexical-env/extend
(list or-part) (list (restrict t1 (-val #f))) (single-value e2 expected)))] (list or-part) (list (restrict t1 (-val #f))) (single-value e2 expected)))]
[t1* (remove t1 (-val #f))] [t1* (remove t1 (-val #f))]
[f1* (-FS fs+ (list (make-Bot)))]) [f1* (-FS null (list (make-Bot)))])
;; if we have the same number of values in both cases ;; if we have the same number of values in both cases
(let ([r (combine-filter f1 f1* f2 t1* t2 o1 o2)]) (let ([r (combine-filter f1 f1* f2 t1* t2 o1 o2)])
(if expected (if expected

13
collects/typed-scheme/typecheck/tc-metafunctions.ss
View File

@ -79,9 +79,12 @@
[(ImpFilter: as cs) [(ImpFilter: as cs)
(let ([a* (apply append (for/list ([f as]) (abo xs idxs f)))] (let ([a* (apply append (for/list ([f as]) (abo xs idxs f)))]
[c* (apply append (for/list ([f cs]) (abo xs idxs f)))]) [c* (apply append (for/list ([f cs]) (abo xs idxs f)))])
(if (< (length a*) (length as)) ;; if we removed some things, we can't be sure (cond [(< (length a*) (length as)) ;; if we removed some things, we can't be sure
null null]
(list (make-LImpFilter a* c*))))] [(null? c*) ;; this clause is now useless
null]
[else
(list (make-LImpFilter a* c*))]))]
[_ null])) [_ null]))
(define (merge-filter-sets fs) (define (merge-filter-sets fs)
@ -118,8 +121,8 @@
(define (idx= lf) (define (idx= lf)
(match lf (match lf
[(LBot:) #t] [(LBot:) #t]
[(LNotTypeFilter: _ _ idx*) (type-equal? idx* idx)] [(LNotTypeFilter: _ _ idx*) (= idx* idx)]
[(LTypeFilter: _ _ idx*) (type-equal? idx* idx)])) [(LTypeFilter: _ _ idx*) (= idx* idx)]))
(match lf (match lf
[(LFilterSet: lf+ lf-) [(LFilterSet: lf+ lf-)
(make-LFilterSet (filter idx= lf+) (filter idx= lf-))])) (make-LFilterSet (filter idx= lf+) (filter idx= lf-))]))

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

@ -2,7 +2,7 @@
(require "../utils/utils.ss") (require "../utils/utils.ss")
(require (rep type-rep object-rep filter-rep) (require (rep type-rep object-rep filter-rep rep-utils)
"printer.ss" "utils.ss" "printer.ss" "utils.ss"
(utils tc-utils) (utils tc-utils)
scheme/list scheme/list
@ -26,7 +26,7 @@
(define -box make-Box) (define -box make-Box)
(define -vec make-Vector) (define -vec make-Vector)
(define -LFS make-LFilterSet) (define -LFS make-LFilterSet)
(define -FS make-FilterSet) (define-syntax -FS (make-rename-transformer #'make-FilterSet))
(define-syntax *Un (define-syntax *Un
(syntax-rules () (syntax-rules ()
@ -36,9 +36,7 @@
(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) (define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
(define (-lst* #:tail [tail (-val null)] . args) (define (-lst* #:tail [tail (-val null)] . args)
(if (null? args) (for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl)))
tail
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
(define (-Tuple l) (define (-Tuple l)
(foldr -pair (-val '()) l)) (foldr -pair (-val '()) l))
@ -68,8 +66,10 @@
(make-Result t f o)) (make-Result t f o))
(d/c (-values args) (d/c (-values args)
(c:-> (listof Type/c) Values?) (c:-> (listof Type/c) (or/c Type/c Values?))
(make-Values (for/list ([i args]) (-result i)))) (match args
;[(list t) t]
[_ (make-Values (for/list ([i args]) (-result i)))]))
;; basic types ;; basic types

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

@ -14,6 +14,7 @@
make-Name make-ValuesDots make-Function make-Name make-ValuesDots make-Function
(rep-out filter-rep object-rep)) (rep-out filter-rep object-rep))
(define (one-of/c . args) (define (one-of/c . args)
(apply Un (map -val args))) (apply Un (map -val args)))
@ -53,7 +54,6 @@
(*Un (-val '()) (*Un (-val '())
(-pair (-Syntax e) (-pair (-Syntax e)
(*Un (-Syntax e) list))))))) (*Un (-Syntax e) list)))))))
(define Any-Syntax (-Syntax In-Syntax)) (define Any-Syntax (-Syntax In-Syntax))
(define (-Sexpof t) (define (-Sexpof t)

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

@ -200,7 +200,7 @@
;; potentially raises exn:subtype, when the algorithm fails ;; potentially raises exn:subtype, when the algorithm fails
;; is s a subtype of t, taking into account constraints A ;; is s a subtype of t, taking into account constraints A
(define (subtype* A s t) (define (subtype* A s t)
(parameterize ([match-equality-test type-equal?] (parameterize ([match-equality-test (lambda (a b) (if (and (Rep? a) (Rep? b)) (type-equal? a b) (equal? a b)))]
[current-seen A]) [current-seen A])
(let ([ks (Type-key s)] [kt (Type-key t)]) (let ([ks (Type-key s)] [kt (Type-key t)])
(cond (cond

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

@ -19,6 +19,8 @@
(define (flat t) (define (flat t)
(match t (match t
[(Union: es) es] [(Union: es) es]
[(Values: (list (Result: (Union: es) _ _))) es]
[(Values: (list (Result: t _ _))) (list t)]
[_ (list t)])) [_ (list t)]))
(define (remove-subtypes ts) (define (remove-subtypes ts)
@ -44,7 +46,7 @@
(cond (cond
[(null? types) (make-union* null)] [(null? types) (make-union* null)]
[(null? (cdr types)) (car types)] [(null? (cdr types)) (car types)]
[else (make-union* (foldr union2 '() (remove-subtypes types)))]))])) [else (make-union* (sort (foldr union2 '() (remove-subtypes types)) type<?))]))]))
(define (u-maker args) (apply Un args)) (define (u-maker args) (apply Un args))

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

@ -150,17 +150,18 @@ at least theoretically.
(define custom-printer (make-parameter #t)) (define custom-printer (make-parameter #t))
(define-syntax (define-struct/printer stx) (define-syntax (define-struct/printer stx)
(syntax-case stx () (syntax-parse stx
[(form name (flds ...) printer) [(form name (flds ...) printer:expr)
#`(define-struct/properties name (flds ...) #`(define-struct name (flds ...)
#:property prop:custom-write
#,(if printing? #,(if printing?
#'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))]) #'(lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))
#'([prop:custom-write pseudo-printer])) #'pseudo-printer)
#f)])) #:inspector #f)]))
;; turn contracts on and off - off by default for performance. ;; turn contracts on and off - off by default for performance.
(define-for-syntax enable-contracts? #f) (define-for-syntax enable-contracts? #t)
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) (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?' ;; these are versions of the contract forms conditionalized by `enable-contracts?'