From 347035fae9cf132840acb41fbb2231a54f39687c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 16 Feb 2009 23:23:35 +0000 Subject: [PATCH 001/156] sync to trunk svn: r13683 --- collects/typed-scheme/private/prims.ss | 46 +++++++++----------------- 1 file changed, 15 insertions(+), 31 deletions(-) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 3c7a17209f..d34ce7dd0d 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -84,37 +84,21 @@ This file defines two sorts of primitives. All of them are provided into any mod 'typechecker:ignore #t)))))])) (define-syntax (require/opaque-type stx) - (syntax-case stx () - [(_ ty pred lib #:name-exists) - (begin - (unless (identifier? #'ty) - (raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) - (unless (identifier? #'pred) - (raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) - (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) - (quasisyntax/loc stx - (begin - #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) - #,(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t))))] - [(_ ty pred lib) - (begin - (unless (identifier? #'ty) - (raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) - (unless (identifier? #'pred) - (raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) - (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) - (quasisyntax/loc stx - (begin - #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) - 'typechecker:ignore #t) - #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) - (define-type-alias ty (Opaque pred)) - #,(syntax-property #'(require/contract pred pred-cnt lib) - 'typechecker:ignore #t))))])) + (define-syntax-class name-exists-kw + (pattern #:name-exists)) + (syntax-parse stx + [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*) + (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) + (quasisyntax/loc stx + (begin + #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) + 'typechecker:ignore #t) + #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) + #,(if #'ne + (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) + (syntax/loc stx (define-type-alias ty (Opaque pred)))) + #,(syntax-property #'(require/contract pred pred-cnt lib) + 'typechecker:ignore #t)))])) (define-for-syntax (formal-annotation-error stx src) (let loop ([stx stx]) From 14475467b2c7b84d240b48fb3cc62f4d31a484bf Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Feb 2009 00:43:47 +0000 Subject: [PATCH 002/156] contracts on types and effects svn: r13685 --- collects/typed-scheme/private/base-env.ss | 38 ++--- collects/typed-scheme/private/type-abbrev.ss | 25 ++-- .../private/type-effect-convenience.ss | 4 + collects/typed-scheme/rep/effect-rep.ss | 12 +- collects/typed-scheme/rep/rep-utils.ss | 63 +++++--- collects/typed-scheme/rep/type-rep.ss | 139 ++++++++++++------ collects/typed-scheme/utils/utils.ss | 2 +- 7 files changed, 176 insertions(+), 107 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index c8e9b69a41..f845addcb1 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -57,7 +57,7 @@ [eqv? (-> Univ Univ B)] [equal? (-> Univ Univ B)] [even? (-> N B)] -[assert (-poly (a) (-> (*Un a (-val #f)) a))] +[assert (-poly (a) (-> (Un a (-val #f)) a))] [gensym (cl-> [(Sym) Sym] [() Sym])] [string-append (->* null -String -String)] @@ -251,8 +251,8 @@ . -> . (-values (list (-pair b (-val '())) N N N))))] -[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))] -[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))] +[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] +[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] [quotient (-Integer -Integer . -> . -Integer)] [remainder (-Integer -Integer . -> . -Integer)] @@ -276,9 +276,9 @@ (let ([?outp (-opt -Output-Port)] [?N (-opt N)] [optlist (lambda (t) (-opt (-lst (-opt t))))] - [-StrRx (*Un -String -Regexp -PRegexp)] - [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] - [-InpBts (*Un -Input-Port -Bytes)]) + [-StrRx (Un -String -Regexp -PRegexp)] + [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (Un -Input-Port -Bytes)]) (cl-> [(-StrRx -String ) (optlist -String)] [(-StrRx -String N ) (optlist -String)] [(-StrRx -String N ?N ) (optlist -String)] @@ -294,9 +294,9 @@ [regexp-match* (let ([?N (-opt N)] - [-StrRx (*Un -String -Regexp -PRegexp)] - [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] - [-InpBts (*Un -Input-Port -Bytes)]) + [-StrRx (Un -String -Regexp -PRegexp)] + [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (Un -Input-Port -Bytes)]) (cl->* (-StrRx -String [N ?N] . ->opt . (-lst -String)) (-BtsRx -String [N ?N] . ->opt . (-lst -Bytes)) @@ -315,17 +315,17 @@ (let ([?outp (-opt -Output-Port)] [?N (-opt N)] [optlist (lambda (t) (-opt (-lst (-opt t))))] - [-StrRx (*Un -String -Regexp -PRegexp)] - [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] - [-InpBts (*Un -Input-Port -Bytes)]) + [-StrRx (Un -String -Regexp -PRegexp)] + [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (Un -Input-Port -Bytes)]) (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))] [regexp-match-positions* (let ([?outp (-opt -Output-Port)] [?N (-opt N)] [optlist (lambda (t) (-opt (-lst (-opt t))))] - [-StrRx (*Un -String -Regexp -PRegexp)] - [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] - [-InpBts (*Un -Input-Port -Bytes)]) + [-StrRx (Un -String -Regexp -PRegexp)] + [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (Un -Input-Port -Bytes)]) (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))] #; [regexp-match-peek-positions*] @@ -443,8 +443,8 @@ [hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))] [hash-ref (-poly (a b c) (cl-> [((-HT a b) a) b] - [((-HT a b) a (-> c)) (*Un b c)] - [((-HT a b) a c) (*Un b c)]))] + [((-HT a b) a (-> c)) (Un b c)] + [((-HT a b) a c) (Un b c)]))] #;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))] [bytes (->* (list) N -Bytes)] @@ -464,7 +464,7 @@ [force (-poly (a) (-> (-Promise a) a))] [bytes* (list -Bytes) -Bytes B)] [regexp-replace* - (cl->* (-Pattern (*Un -Bytes -String) (*Un -Bytes -String) . -> . -Bytes) + (cl->* (-Pattern (Un -Bytes -String) (Un -Bytes -String) . -> . -Bytes) (-Pattern -String -String . -> . -String))] [peek-char (cl->* [-> -Char] @@ -503,7 +503,7 @@ [delete-file (-> -Pathlike -Void)] [make-namespace (cl->* (-> -Namespace) - (-> (*Un (-val 'empty) (-val 'initial)) -Namespace))] + (-> (Un (-val 'empty) (-val 'initial)) -Namespace))] [make-base-namespace (-> -Namespace)] [eval (-> -Sexp Univ)] diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 3a33b0f34d..6ee393d4f7 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -179,8 +179,8 @@ (define -Listof (-poly (list-elem) (make-Listof list-elem))) (define -lst make-Listof) -(define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x)))) -(define -Port (*Un -Input-Port -Output-Port)) +(define -Sexp (-mu x (*Un N B Sym -String (-val null) (-pair x x)))) +(define -Port (*Un -Output-Port -Input-Port)) (define (-lst* #:tail [tail (-val null)] . args) (if (null? args) @@ -199,9 +199,9 @@ (->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))] [(t) (make-pred-ty (list Univ) B t)])) -(define -Pathlike (*Un -Path -String)) -(define -Pathlike* (*Un (-val 'up) (-val 'same) -Path -String)) -(define -Pattern (*Un -String -Bytes -Regexp -Byte-Regexp -PRegexp -Byte-PRegexp)) +(define -Pathlike (*Un -String -Path)) +(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same))) +(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String)) (define -Byte N) (define (-Tuple l) @@ -220,16 +220,13 @@ (define Any-Syntax ;(-Syntax Univ) (-mu x (-Syntax (*Un - (-mu y (*Un (-pair x (*Un x y)) (-val '()))) - (make-Vector x) - (make-Box x) N B - -Keyword + Sym -String - Sym)))) + -Keyword + (-mu y (*Un (-val '()) (-pair x (*Un x y)))) + (make-Vector x) + (make-Box x))))) -(define Ident (-Syntax Sym)) - -;; DO NOT USE if t contains #f -(define (-opt t) (*Un (-val #f) t)) \ No newline at end of file +(define Ident (-Syntax Sym)) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index e8a8849f61..a3f41d0aa0 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -78,3 +78,7 @@ (define-syntax-rule (->opt args ... [opt ...] res) (opt-fn (list args ...) (list opt ...) res)) + + +;; DO NOT USE if t contains #f +(define (-opt t) (Un (-val #f) t)) \ No newline at end of file diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/rep/effect-rep.ss index 96f8768c9b..dd755d1f34 100644 --- a/collects/typed-scheme/rep/effect-rep.ss +++ b/collects/typed-scheme/rep/effect-rep.ss @@ -9,29 +9,29 @@ (de False-Effect () [#:frees #f] [#:fold-rhs #:base]) ;; v is an identifier -(de Var-True-Effect (v) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) +(de Var-True-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) ;; v is an identifier -(de Var-False-Effect (v) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) +(de Var-False-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) ;; t is a Type ;; v is an identifier -(de Restrict-Effect (t v) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)] +(de Restrict-Effect ([t Type?] [v identifier?]) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*Restrict-Effect (type-rec-id t) v)]) ;; t is a Type ;; v is an identifier -(de Remove-Effect (t v) +(de Remove-Effect ([t Type?] [v identifier?]) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*Remove-Effect (type-rec-id t) v)]) ;; t is a Type -(de Latent-Restrict-Effect (t) [#:frees (free-vars* t) (free-idxs* t)] +(de Latent-Restrict-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*Latent-Restrict-Effect (type-rec-id t))]) ;; t is a Type -(de Latent-Remove-Effect (t) [#:frees (free-vars* t) (free-idxs* t)] +(de Latent-Remove-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*Latent-Remove-Effect (type-rec-id t))]) (de Latent-Var-True-Effect () [#:frees #f] [#:fold-rhs #:base]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 2d2ecc7d98..f0a4b87c3c 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -7,6 +7,7 @@ "free-variance.ss" "interning.ss" mzlib/etc + scheme/contract (for-syntax stxclass scheme/base @@ -40,14 +41,25 @@ (define-for-syntax effect-rec-id #'effect-rec-id) (define-for-syntax fold-target #'fold-target) +(define-for-syntax enable-contracts? #t) + (provide (for-syntax type-rec-id effect-rec-id fold-target)) (define-syntaxes (dt de) (let () + (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 - (pattern (i:id ...))) + #:attributes ((i 1) (cnt 1) fs) + (pattern (oci:opt-cnt-id ...) + #:with (i ...) #'(oci.i ...) + #:with (cnt ...) #'(oci.cnt ...) + #:with fs #'(i ...))) (define (combiner f flds) (syntax-parse flds [() #'empty-hash-table] @@ -74,14 +86,18 @@ [[#:intern intern?:expr]] #:opt [[#:frees . frees:frees-pat]] #:opt [[#:fold-rhs fold-rhs:fold-pat]] #:opt + [[#:contract cnt:expr]] #:opt [no-provide?:no-provide-kw] #:opt) ...*) (with-syntax* ([ex (mk-id #'nm #'nm ":")] [kw-stx (string->keyword (symbol->string #'nm.datum))] [parent par] - [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)] + [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] [*maker (mk-id #'nm "*" #'nm)] [**maker (mk-id #'nm "**" #'nm)] + [*maker-cnt (if enable-contracts? + (or #'cnt #'(flds.cnt ... . -> . pred)) + #'any/c)] [ht-stx ht-stx] [bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)] [else #'(lambda (type-rec-id effect-rec-id) @@ -90,32 +106,33 @@ #'(begin) #`(begin (provide ex pred acc ...) - (provide (rename-out [*maker maker]))))] + (provide/contract (rename *maker maker *maker-cnt))))] [intern - (let ([mk (lambda (int) #`(defintern (**maker . flds) maker #,int #:extra-arg key-expr))]) - (syntax-parse #'flds + (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) + (syntax-parse #'flds.fs [_ #:when #'intern? (mk #'intern?)] [() (mk #'#f)] [(f) (mk #'f)] - [_ (mk #'(list . flds))]))] - [frees - (with-syntax ([(f1 f2) (if #'frees - #'(frees.f1 frees.f2) - (list (combiner #'free-vars* #'flds) - (combiner #'free-idxs* #'flds)))]) - (quasisyntax/loc stx - (define (*maker . flds) - (define v (**maker . flds)) - (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)))]) + [_ (mk #'(list . flds.fs))]))] + [frees + (with-syntax ([(f1 f2) (if #'frees + #'(frees.f1 frees.f2) + (list (combiner #'free-vars* #'flds.fs) + (combiner #'free-idxs* #'flds.fs)))]) + (quasisyntax/loc stx + (with-contract nm ([*maker *maker-cnt]) + (define (*maker . flds.fs) + (define v (**maker . flds.fs)) + (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 - (define-struct (nm parent) flds #:inspector #f) + (define-struct (nm parent) flds.fs #:inspector #f) (define-match-expander ex (lambda (s) (syntax-parse s @@ -123,7 +140,7 @@ #:with pat (syntax/loc s (_ _ . fs)) (syntax/loc s (struct nm pat))]))) (begin-for-syntax - (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) + (hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx))) intern provides frees))]))) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index ea2d2017bb..1bc93feae5 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -4,6 +4,7 @@ (require (utils tc-utils) "rep-utils.ss" "effect-rep.ss" "free-variance.ss" mzlib/trace scheme/match + scheme/contract (for-syntax scheme/base)) (define name-table (make-weak-hasheq)) @@ -13,26 +14,36 @@ ;; Type is defined in rep-utils.ss ;; t must be a Type -(dt Scope (t) [#:key (Type-key t)]) +(dt Scope ([t Type?]) [#:key (Type-key t)]) + +(define (scope-depth k) + (flat-named-contract + (format "Scope of depth ~a" k) + (lambda (sc) + (define (f k sc) + (cond [(= 0 k) (not (Scope? sc))] + [(not (Scope? sc)) #f] + [else (f (sub1 k) (Scope-t sc))])) + (f k sc)))) ;; this is ONLY used when a type error ocurrs (dt Error () [#:frees #f] [#:fold-rhs #:base]) ;; i is an nat -(dt B (i) +(dt B ([i natural-number/c]) [#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))] [#:fold-rhs #:base]) ;; n is a Name -(dt F (n) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base]) +(dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base]) ;; id is an Identifier -(dt Name (id) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base]) +(dt Name ([id identifier?]) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base]) ;; rator is a type ;; rands is a list of types ;; stx is the syntax of the pair of parens -(dt App (rator rands stx) +(dt App ([rator Type?] [rands (listof Type?)] [stx syntax?]) [#:intern (list rator rands)] [#:frees (combine-frees (map free-vars* (cons rator rands))) (combine-frees (map free-idxs* (cons rator rands)))] @@ -41,19 +52,19 @@ stx)]) ;; left and right are Types -(dt Pair (left right) [#:key 'pair]) +(dt Pair ([left Type?] [right Type?]) [#:key 'pair]) ;; elem is a Type -(dt Vector (elem) +(dt Vector ([elem Type?]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] [#:key 'vector]) ;; elem is a Type -(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] +(dt Box ([elem Type?]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] [#:key 'box]) ;; name is a Symbol (not a Name) -(dt Base (name contract) [#:frees #f] [#:fold-rhs #:base] [#:intern name] +(dt Base ([name symbol?] [contract syntax?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name] [#:key (case name [(Number Integer) 'number] [(Boolean) 'boolean] @@ -63,13 +74,17 @@ [else #f])]) ;; body is a Scope -(dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))] +(dt Mu ([body (scope-depth 1)]) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))] [#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))] [#:key (Type-key body)]) ;; n is how many variables are bound here ;; body is a Scope (dt Poly (n body) #:no-provide + [#:contract (->d ([n natural-number/c] + [body (scope-depth n)]) + () + [result Poly?])] [#:frees (free-vars* body) (without-below n (free-idxs* body))] [#:fold-rhs (let ([body* (remove-scopes n body)]) (*Poly n (add-scopes n (type-rec-id body*))))] @@ -79,6 +94,10 @@ ;; there are n-1 'normal' vars and 1 ... var ;; body is a Scope (dt PolyDots (n body) #:no-provide + [#:contract (->d ([n natural-number/c] + [body (scope-depth n)]) + () + [result PolyDots?])] [#:key (Type-key body)] [#:frees (free-vars* body) (without-below n (free-idxs* body))] [#:fold-rhs (let ([body* (remove-scopes n body)]) @@ -86,32 +105,13 @@ ;; pred : identifier ;; cert : syntax certifier -(dt Opaque (pred cert) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) - -;; name : symbol -;; parent : Struct -;; flds : Listof[Type] -;; proc : Function Type -;; poly? : is this a polymorphic type? -;; pred-id : identifier for the predicate of the struct -;; cert : syntax certifier for pred-id -(dt Struct (name parent flds proc poly? pred-id cert) - [#:intern (list name parent flds proc)] - [#:frees (combine-frees (map free-vars* (append (if proc (list proc) null) (if parent (list parent) null) flds))) - (combine-frees (map free-idxs* (append (if proc (list proc) null) (if parent (list parent) null) flds)))] - [#:fold-rhs (*Struct name - (and parent (type-rec-id parent)) - (map type-rec-id flds) - (and proc (type-rec-id proc)) - poly? - pred-id - cert)] - [#:key (gensym)]) +(dt Opaque ([pred identifier?] [cert procedure?]) + [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) ;; kw : keyword? ;; ty : Type ;; required? : Boolean -(dt Keyword (kw ty required?) +(dt Keyword ([kw keyword?] [ty Type?] [required? boolean?]) [#:frees (free-vars* ty) (free-idxs* ty)] [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)] @@ -126,7 +126,13 @@ ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type -(dt arr (dom rng rest drest kws thn-eff els-eff) +(dt arr ([dom (listof Type?)] + [rng Type?] + [rest (or/c #f Type?)] + [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] + [kws (listof Keyword?)] + [thn-eff (listof Effect?)] + [els-eff (listof Effect?)]) [#:key 'procedure] [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) (map Keyword-ty kws) @@ -163,11 +169,42 @@ (dt top-arr () [#:frees #f] [#:fold-rhs #:base]) +(define arr/c (or/c top-arr? arr?)) + ;; arities : Listof[arr] -(dt Function (arities) [#:frees (combine-frees (map free-vars* arities)) - (combine-frees (map free-idxs* arities))] +(dt Function ([arities (listof arr/c)]) + [#:frees (combine-frees (map free-vars* arities)) + (combine-frees (map free-idxs* arities))] [#:fold-rhs (*Function (map type-rec-id arities))]) + +;; name : symbol +;; parent : Struct +;; flds : Listof[Type] +;; proc : Function Type +;; poly? : is this a polymorphic type? +;; pred-id : identifier for the predicate of the struct +;; cert : syntax certifier for pred-id +(dt Struct ([name symbol?] + [parent (or/c #f Struct? Name?)] + [flds (listof Type?)] + [proc (or/c #f Function?)] + [poly? boolean?] + [pred-id identifier?] + [cert procedure?]) + [#:intern (list name parent flds proc)] + [#:frees (combine-frees (map free-vars* (append (if proc (list proc) null) (if parent (list parent) null) flds))) + (combine-frees (map free-idxs* (append (if proc (list proc) null) (if parent (list parent) null) flds)))] + [#:fold-rhs (*Struct name + (and parent (type-rec-id parent)) + (map type-rec-id flds) + (and proc (type-rec-id proc)) + poly? + pred-id + cert)] + [#:key (gensym)]) + + ;; v : Scheme Value (dt Value (v) [#:frees #f] [#:fold-rhs #:base] [#:key (cond [(number? v) 'number] [(boolean? v) 'boolean] @@ -175,8 +212,20 @@ [else #f])]) ;; elems : Listof[Type] -(dt Union (elems) [#:frees (combine-frees (map free-vars* elems)) - (combine-frees (map free-idxs* elems))] +(dt Union ([elems (and/c (listof Type?) + (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))] [#:key (let loop ([res null] [ts elems]) (if (null? ts) res @@ -188,14 +237,14 @@ (dt Univ () [#:frees #f] [#:fold-rhs #:base]) ;; types : Listof[Type] -(dt Values (types) +(dt Values ([types (listof Type?)]) #:no-provide [#:frees (combine-frees (map free-vars* types)) (combine-frees (map free-idxs* types))] [#:fold-rhs (*Values (map type-rec-id types))] [#:key 'values]) -(dt ValuesDots (types dty dbound) +(dt ValuesDots ([types (listof Type?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) [#:frees (combine-frees (map free-vars* (cons dty types))) (combine-frees (map free-idxs* (cons dty types)))] [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)] @@ -203,19 +252,21 @@ ;; in : Type ;; out : Type -(dt Param (in out) [#:key 'parameter]) +(dt Param ([in Type?] [out Type?]) [#:key 'parameter]) ;; key : Type ;; value : Type -(dt Hashtable (key value) [#:key 'hash]) +(dt Hashtable ([key Type?] [value Type?]) [#:key 'hash]) ;; t : Type -(dt Syntax (t) [#:key 'syntax]) +(dt Syntax ([t Type?]) [#:key 'syntax]) ;; pos-flds : (Listof Type) ;; name-flds : (Listof (Tuple Symbol Type Boolean)) ;; methods : (Listof (Tuple Symbol Function)) -(dt Class (pos-flds name-flds methods) +(dt Class ([pos-flds (listof Type?)] + [name-flds (listof (list/c symbol? Type? boolean?))] + [methods (listof (list/c symbol? Function?))]) [#:frees (combine-frees (map free-vars* (append pos-flds (map cadr name-flds) @@ -238,7 +289,7 @@ (map list mname (map type-rec-id mty)))])]) ;; cls : Class -(dt Instance (cls) [#:key 'instance]) +(dt Instance ([cls Class?]) [#:key 'instance]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 485bc20b7f..8cb1559cc4 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -166,7 +166,7 @@ [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #t) +(define-for-syntax printing? #f) (define print-type* (box (lambda _ (error "print-type* not yet defined")))) (define print-effect* (box (lambda _ (error "print-effect* not yet defined")))) From cc1265fc614c972006eea18ba56e579c03e4abd2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Feb 2009 01:09:23 +0000 Subject: [PATCH 003/156] Fix contract on App. Fix function construction for rec-lambda/check Re-enable printing. svn: r13687 --- collects/typed-scheme/rep/type-rep.ss | 2 +- collects/typed-scheme/typecheck/tc-lambda-unit.ss | 8 ++++---- collects/typed-scheme/utils/utils.ss | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 1bc93feae5..58528227ce 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -43,7 +43,7 @@ ;; rator is a type ;; rands is a list of types ;; stx is the syntax of the pair of parens -(dt App ([rator Type?] [rands (listof Type?)] [stx syntax?]) +(dt App ([rator Type?] [rands (listof Type?)] [stx (or/c #f syntax?)]) [#:intern (list rator rands)] [#:frees (combine-frees (map free-vars* (cons rator rands))) (combine-frees (map free-idxs* (cons rator rands)))] diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 66ce896383..d0d4d7244b 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -285,11 +285,11 @@ (define (tc/rec-lambda/check form formals body name args ret) (with-lexical-env/extend (syntax->list formals) args - (let ([t (->* args ret)]) + (let* ([t (make-arr args ret)] + [ft (make-Function (list t))]) (with-lexical-env/extend - (list name) (list t) - (begin (tc-exprs/check (syntax->list body) ret) - (make-Function (list t))))))) + (list name) (list ft) + (begin (tc-exprs/check (syntax->list body) ret) ft))))) ;(trace tc/mono-lambda) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 8cb1559cc4..485bc20b7f 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -166,7 +166,7 @@ [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #f) +(define-for-syntax printing? #t) (define print-type* (box (lambda _ (error "print-type* not yet defined")))) (define print-effect* (box (lambda _ (error "print-effect* not yet defined")))) From 00ff608247134f49ffecae576c90df40dacf7143 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Feb 2009 17:30:30 +0000 Subject: [PATCH 004/156] Move contract-enabling code to utils/utils Move `cnt' signature form to utils/utils, controlled by same boolean. Use `w/c' and `p/c' to enable/disable contracts in dt/de. Contract for `ret'. svn: r13699 --- collects/typed-scheme/private/type-utils.ss | 18 ++++++----- collects/typed-scheme/rep/rep-utils.ss | 6 ++-- collects/typed-scheme/utils/unit-utils.ss | 8 +---- collects/typed-scheme/utils/utils.ss | 35 ++++++++++++++++++++- 4 files changed, 48 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index 0617aa0f86..d4ca2ad05b 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -8,7 +8,8 @@ scheme/match scheme/list mzlib/trace - (for-syntax scheme/base)) + scheme/contract + (for-syntax scheme/base stxclass)) (provide fv fv/list substitute @@ -16,7 +17,7 @@ substitute-dotted subst-all subst - ret + ;ret instantiate-poly instantiate-poly-dotted tc-result: @@ -172,19 +173,22 @@ ;; this structure represents the result of typechecking an expression -(define-struct tc-result (t thn els) #:inspector #f) +(define-struct tc-result (t thn els) #:transparent) (define-match-expander tc-result: - (lambda (stx) - (syntax-case stx () - [(form pt) #'(struct tc-result (pt _ _))] - [(form pt pe1 pe2) #'(struct tc-result (pt pe1 pe2))]))) + (syntax-parser + [(_ pt) #'(struct tc-result (pt _ _))] + [(_ pt pe1 pe2) #'(struct tc-result (pt pe1 pe2))])) ;; convenience function for returning the result of typechecking an expression (define ret (case-lambda [(t) (make-tc-result t (list) (list))] [(t thn els) (make-tc-result t thn els)])) +(p/c + [ret (case-> (-> Type? tc-result?) + (-> Type? (listof Effect?) (listof Effect?) tc-result?))]) + (define (subst v t e) (substitute t v e)) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index f0a4b87c3c..caaa0daaeb 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -41,8 +41,6 @@ (define-for-syntax effect-rec-id #'effect-rec-id) (define-for-syntax fold-target #'fold-target) -(define-for-syntax enable-contracts? #t) - (provide (for-syntax type-rec-id effect-rec-id fold-target)) (define-syntaxes (dt de) @@ -106,7 +104,7 @@ #'(begin) #`(begin (provide ex pred acc ...) - (provide/contract (rename *maker maker *maker-cnt))))] + (p/c (rename *maker maker *maker-cnt))))] [intern (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) (syntax-parse #'flds.fs @@ -121,7 +119,7 @@ (list (combiner #'free-vars* #'flds.fs) (combiner #'free-idxs* #'flds.fs)))]) (quasisyntax/loc stx - (with-contract nm ([*maker *maker-cnt]) + (w/c nm ([*maker *maker-cnt]) (define (*maker . flds.fs) (define v (**maker . flds.fs)) (unless-in-table diff --git a/collects/typed-scheme/utils/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss index ebec947551..728edcd193 100644 --- a/collects/typed-scheme/utils/unit-utils.ss +++ b/collects/typed-scheme/utils/unit-utils.ss @@ -7,13 +7,7 @@ scheme/unit-exptime scheme/match)) -(provide define-values/link-units/infer cnt) - -(define-signature-form (cnt stx) - (syntax-case stx () - [(_ nm cnt) - (list #'nm) - #;(list #'[contracted (nm cnt)])])) +(provide define-values/link-units/infer) (define-syntax (define-values/link-units/infer stx) ;; construct something we can put in the imports/exports clause from the datum diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 485bc20b7f..c386b0c2bb 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -1,9 +1,11 @@ #lang scheme/base -(require (for-syntax scheme/base) +(require (for-syntax scheme/base stxclass) + scheme/contract mzlib/plt-match scheme/require-syntax mzlib/struct + scheme/unit (except-in stxclass id)) (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log @@ -235,3 +237,34 @@ (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) +(define-for-syntax enable-contracts? #t) +(provide (for-syntax enable-contracts?) p/c w/c cnt) + +(define-syntax p/c + (if enable-contracts? + (make-rename-transformer #'provide/contract) + (lambda (stx) + (define-syntax-class clause + #:literals (rename) + #:attributes (i) + (pattern [rename out:id in:id] + #:with i #'(rename-out out in)) + (pattern [i:id c])) + (syntax-parse stx + [(_ c:clause ...) + #'(provide c.i ...)])))) + +(define-syntax w/c + (if enable-contracts? + (make-rename-transformer #'with-contract) + (lambda (stx) + (syntax-parse stx + [(_ name specs . body) + #'(begin . body)])))) + +(define-signature-form (cnt stx) + (syntax-case stx () + [(_ nm cnt) + (if enable-contracts? + (list #'[contracted (nm cnt)]) + (list #'nm))])) \ No newline at end of file From a8a9af73d86e90fc725c59fb244dc32a11311385 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 18 Feb 2009 00:28:01 +0000 Subject: [PATCH 005/156] checkpoint svn: r13715 --- collects/typed-scheme/rep/effect-rep.ss | 5 + collects/typed-scheme/rep/object-rep.ss | 22 ++ collects/typed-scheme/rep/rep-utils.ss | 262 +++++++++++++----------- collects/typed-scheme/rep/type-rep.ss | 3 +- 4 files changed, 167 insertions(+), 125 deletions(-) create mode 100644 collects/typed-scheme/rep/object-rep.ss diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/rep/effect-rep.ss index dd755d1f34..0812e04fe1 100644 --- a/collects/typed-scheme/rep/effect-rep.ss +++ b/collects/typed-scheme/rep/effect-rep.ss @@ -4,6 +4,10 @@ (require mzlib/etc) (require "rep-utils.ss" "free-variance.ss") + + +#| + (de True-Effect () [#:frees #f] [#:fold-rhs #:base]) (de False-Effect () [#:frees #f] [#:fold-rhs #:base]) @@ -39,3 +43,4 @@ (de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base]) ;; could also have latent true/false effects, but seems pointless +|# \ No newline at end of file diff --git a/collects/typed-scheme/rep/object-rep.ss b/collects/typed-scheme/rep/object-rep.ss new file mode 100644 index 0000000000..e56bddd583 --- /dev/null +++ b/collects/typed-scheme/rep/object-rep.ss @@ -0,0 +1,22 @@ +#lang scheme/base + +(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss") + +(dpe CarPE () [#:frees #f] [#:fold-rhs #:base]) +(dpe CdrPE () [#:frees #f] [#:fold-rhs #:base]) +(dpe StructPE ([t Type?] [idx natural-number/c]) + [#:frees (free-vars* t) (free-idxs* t)] + [#:fold-rhs (*StructPE (type-rec-id t) idx)]) + +(do Bot () [#:frees #f] [#:fold-rhs #:base]) + +(do Path ([p (listof PathElem?)] [v identifier?]) + [#:intern (list p (hash-id v))] + [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] + [#:fold-rhs (*Path (map pathelem-rec-id t) v)]) + +(dlo LBot () [#:frees #f] [#:fold-rhs #:base]) + +(dlo LPath ([p (listof PathElem?)] [idx natural-number/c]) + [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] + [#:fold-rhs (*LPath (map pathelem-rec-id t) idx)]) \ No newline at end of file diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index caaa0daaeb..ad394dfdc8 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -15,132 +15,146 @@ syntax/stx (rename-in (utils utils) [id mk-id]))) -(provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key) +(provide == defintern hash-id (for-syntax fold-target)) - - -;; hash table for defining folds over types -(define-values-for-syntax (type-name-ht effect-name-ht) - (values (make-hasheq) (make-hasheq))) - -(provide (for-syntax type-name-ht effect-name-ht)) - - -;; all types are Type? -(define-struct/printer Type (seq key) (lambda (a b c) ((unbox print-type*) a b c))) - -(define-struct/printer Effect (seq key) (lambda (a b c) ((unbox print-effect*) a b c))) - - - - - -;; type/effect definition macro - -(define-for-syntax type-rec-id #'type-rec-id) -(define-for-syntax effect-rec-id #'effect-rec-id) (define-for-syntax fold-target #'fold-target) -(provide (for-syntax type-rec-id effect-rec-id fold-target)) +(define-for-syntax (mk par ht-stx) + (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 (oci:opt-cnt-id ...) + #:with (i ...) #'(oci.i ...) + #:with (cnt ...) #'(oci.cnt ...) + #:with fs #'(i ...))) + (define (combiner f flds) + (syntax-parse flds + [() #'empty-hash-table] + [(e) #`(#,f e)] + [(e ...) #`(combine-frees (list (#,f e) ...))])) + (define-syntax-class frees-pat + #:transparent + #:attributes (f1 f2) + (pattern (f1:expr f2:expr)) + (pattern (#f) + #:with f1 #'empty-hash-table + #:with f2 #'empty-hash-table)) + (define-syntax-class fold-pat + #:transparent + #:attributes (e) + (pattern #:base + #:with e fold-target) + (pattern ex:expr + #:with e #'#'ex)) + (lambda (stx) + (syntax-parse stx + [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt + [[#:intern intern?:expr]] #:opt + [[#:frees . frees:frees-pat]] #:opt + [[#:fold-rhs fold-rhs:fold-pat]] #:opt + [[#:contract cnt:expr]] #:opt + [no-provide?:no-provide-kw] #:opt) ...*) + (with-syntax* + ([ex (mk-id #'nm #'nm ":")] + [kw-stx (string->keyword (symbol->string #'nm.datum))] + [parent par] + [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] + [*maker (mk-id #'nm "*" #'nm)] + [**maker (mk-id #'nm "**" #'nm)] + [*maker-cnt (if enable-contracts? + (or #'cnt #'(flds.cnt ... . -> . pred)) + #'any/c)] + [ht-stx ht-stx] + [bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)] + [else #'(lambda (type-rec-id effect-rec-id) + #`(*maker (#,type-rec-id flds.i) ...))])] + [provides (if #'no-provide? + #'(begin) + #`(begin + (provide ex pred acc ...) + (p/c (rename *maker maker *maker-cnt))))] + [intern + (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) + (syntax-parse #'flds.fs + [_ #:when #'intern? + (mk #'intern?)] + [() (mk #'#f)] + [(f) (mk #'f)] + [_ (mk #'(list . flds.fs))]))] + [frees + (with-syntax ([(f1 f2) (if #'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)) + (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 + (define-struct (nm parent) flds.fs #:inspector #f) + (define-match-expander ex + (lambda (s) + (syntax-parse s + [(_ . fs) + #:with pat (syntax/loc s (_ _ . fs)) + (syntax/loc s (struct nm pat))]))) + (begin-for-syntax + (hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx))) + intern + provides + frees))]))) -(define-syntaxes (dt de) - (let () - (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 (oci:opt-cnt-id ...) - #:with (i ...) #'(oci.i ...) - #:with (cnt ...) #'(oci.cnt ...) - #:with fs #'(i ...))) - (define (combiner f flds) - (syntax-parse flds - [() #'empty-hash-table] - [(e) #`(#,f e)] - [(e ...) #`(combine-frees (list (#,f e) ...))])) - (define-syntax-class frees-pat - #:transparent - #:attributes (f1 f2) - (pattern (f1:expr f2:expr)) - (pattern (#f) - #:with f1 #'empty-hash-table - #:with f2 #'empty-hash-table)) - (define-syntax-class fold-pat - #:transparent - #:attributes (e) - (pattern #:base - #:with e fold-target) - (pattern ex:expr - #:with e #'#'ex)) - (define (mk par ht-stx) - (lambda (stx) - (syntax-parse stx - [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt - [[#:intern intern?:expr]] #:opt - [[#:frees . frees:frees-pat]] #:opt - [[#:fold-rhs fold-rhs:fold-pat]] #:opt - [[#:contract cnt:expr]] #:opt - [no-provide?:no-provide-kw] #:opt) ...*) - (with-syntax* - ([ex (mk-id #'nm #'nm ":")] - [kw-stx (string->keyword (symbol->string #'nm.datum))] - [parent par] - [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] - [*maker (mk-id #'nm "*" #'nm)] - [**maker (mk-id #'nm "**" #'nm)] - [*maker-cnt (if enable-contracts? - (or #'cnt #'(flds.cnt ... . -> . pred)) - #'any/c)] - [ht-stx ht-stx] - [bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)] - [else #'(lambda (type-rec-id effect-rec-id) - #`(*maker (#,type-rec-id flds.i) ...))])] - [provides (if #'no-provide? - #'(begin) - #`(begin - (provide ex pred acc ...) - (p/c (rename *maker maker *maker-cnt))))] - [intern - (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) - (syntax-parse #'flds.fs - [_ #:when #'intern? - (mk #'intern?)] - [() (mk #'#f)] - [(f) (mk #'f)] - [_ (mk #'(list . flds.fs))]))] - [frees - (with-syntax ([(f1 f2) (if #'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)) - (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 - (define-struct (nm parent) flds.fs #:inspector #f) - (define-match-expander ex - (lambda (s) - (syntax-parse s - [(_ . fs) - #:with pat (syntax/loc s (_ _ . fs)) - (syntax/loc s (struct nm pat))]))) - (begin-for-syntax - (hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx))) - intern - provides - frees))]))) - (values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht)))) +(define-syntax (make-prim-type stx) + (define default-flds #'(seq)) + (define-syntax-class type-name-base + #:attributes (i lower-s first-letter (fld-names 1)) + #:transparent + (pattern i:id + #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:with (fld-names ...) default-flds + #:with first-letter (string-ref #'lower-s 0)) + (pattern [i:id #:d d-name:id] + #:with (fld-names ...) default-flds + #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:with first-letter (symbol->string #'d-name.datum)) + (pattern [i:id #:fields extra-fld-names:id ...] + #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) + (syntax->list #'(extra-fld-names ...)))) + #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:with first-letter (string-ref #'lower-s 0))) + (define-syntax-class type-name + #:transparent + (pattern :type-name-base + #:with name #'i + #:with printer (mk-id #'i "print-" #'lower-s "*") + #:with ht (mk-id #'i #'lower-s "-name-ht") + #:with rec-id (mk-id #'i #'lower-s "-rec-id") + #:with d-id (mk-id #'i "d" #'first-letter) + #:with (_ _ pred? accs ...) + (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))) + (syntax-parse stx + [(_ i:type-name ...) + #'(begin + (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)) ... + (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))) ... + (define-for-syntax i.rec-id #'i.rec-id) ...)])) + +(make-prim-type [Type #:fields key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] + [PathElem #:d pe]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 58528227ce..e34ba3f1ec 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -5,6 +5,7 @@ "rep-utils.ss" "effect-rep.ss" "free-variance.ss" mzlib/trace scheme/match scheme/contract + stxclass/util (for-syntax scheme/base)) (define name-table (make-weak-hasheq)) @@ -161,7 +162,7 @@ (and rest (type-rec-id rest)) (and drest (cons (type-rec-id (car drest)) (cdr drest))) (for/list ([kw kws]) - (cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw))) + (make Keyword (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw))) (map effect-rec-id thn-eff) (map effect-rec-id els-eff))]) From 7d5581b06f3db4e40fc5ed1db1e02d3cd1f7d075 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 18 Feb 2009 01:58:11 +0000 Subject: [PATCH 006/156] move svn: r13716 --- collects/typed-scheme/rep/{effect-rep.ss => filter-rep.ss} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename collects/typed-scheme/rep/{effect-rep.ss => filter-rep.ss} (100%) diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/rep/filter-rep.ss similarity index 100% rename from collects/typed-scheme/rep/effect-rep.ss rename to collects/typed-scheme/rep/filter-rep.ss From c0861fd39b88e3858c5ef6785938a3dbf8b3377c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 18 Feb 2009 02:58:47 +0000 Subject: [PATCH 007/156] checkpoint again svn: r13718 --- collects/typed-scheme/rep/filter-rep.ss | 58 ++++++++++--------------- collects/typed-scheme/rep/object-rep.ss | 12 ++--- collects/typed-scheme/rep/rep-utils.ss | 22 +++++++--- 3 files changed, 43 insertions(+), 49 deletions(-) diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index 0812e04fe1..d468d109f8 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -4,43 +4,29 @@ (require mzlib/etc) (require "rep-utils.ss" "free-variance.ss") +(df Bot () [#:fold-rhs #:base]) + +(df TypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?]) + [#:intern (list t p (hash-id v))] + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*TypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) + +(df NotTypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?]) + [#:intern (list t p (hash-id v))] + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) -#| +(dlf LBot () [#:fold-rhs #:base]) -(de True-Effect () [#:frees #f] [#:fold-rhs #:base]) +(dlf LTypeFilter ([t Type?] [p (listof PathElem?)]) + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) -(de False-Effect () [#:frees #f] [#:fold-rhs #:base]) - -;; v is an identifier -(de Var-True-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) - -;; v is an identifier -(de Var-False-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) - -;; t is a Type -;; v is an identifier -(de Restrict-Effect ([t Type?] [v identifier?]) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Restrict-Effect (type-rec-id t) v)]) - -;; t is a Type -;; v is an identifier -(de Remove-Effect ([t Type?] [v identifier?]) - [#:intern (list t (hash-id v))] - [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Remove-Effect (type-rec-id t) v)]) - -;; t is a Type -(de Latent-Restrict-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Latent-Restrict-Effect (type-rec-id t))]) - -;; t is a Type -(de Latent-Remove-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Latent-Remove-Effect (type-rec-id t))]) - -(de Latent-Var-True-Effect () [#:frees #f] [#:fold-rhs #:base]) - -(de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base]) - -;; could also have latent true/false effects, but seems pointless -|# \ No newline at end of file +(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)]) + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) diff --git a/collects/typed-scheme/rep/object-rep.ss b/collects/typed-scheme/rep/object-rep.ss index e56bddd583..4a6f10a28c 100644 --- a/collects/typed-scheme/rep/object-rep.ss +++ b/collects/typed-scheme/rep/object-rep.ss @@ -2,21 +2,21 @@ (require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss") -(dpe CarPE () [#:frees #f] [#:fold-rhs #:base]) -(dpe CdrPE () [#:frees #f] [#:fold-rhs #:base]) +(dpe CarPE () [#:fold-rhs #:base]) +(dpe CdrPE () [#:fold-rhs #:base]) (dpe StructPE ([t Type?] [idx natural-number/c]) [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*StructPE (type-rec-id t) idx)]) -(do Bot () [#:frees #f] [#:fold-rhs #:base]) +(do Empty () [#:fold-rhs #:base]) (do Path ([p (listof PathElem?)] [v identifier?]) [#:intern (list p (hash-id v))] [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] - [#:fold-rhs (*Path (map pathelem-rec-id t) v)]) + [#:fold-rhs (*Path (map pathelem-rec-id p) v)]) -(dlo LBot () [#:frees #f] [#:fold-rhs #:base]) +(dlo LEmpty () [#:fold-rhs #:base]) (dlo LPath ([p (listof PathElem?)] [idx natural-number/c]) [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] - [#:fold-rhs (*LPath (map pathelem-rec-id t) idx)]) \ No newline at end of file + [#:fold-rhs (*LPath (map pathelem-rec-id p) idx)]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ad394dfdc8..0cfd62bd35 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -19,7 +19,7 @@ (define-for-syntax fold-target #'fold-target) -(define-for-syntax (mk par ht-stx) +(define-for-syntax (mk par ht-stx key?) (define-syntax-class opt-cnt-id #:attributes (i cnt) (pattern i:id @@ -80,7 +80,10 @@ (provide ex pred acc ...) (p/c (rename *maker maker *maker-cnt))))] [intern - (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) + (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int + #,@(if key? + #'(#:extra-arg key-expr) + #'())))]) (syntax-parse #'flds.fs [_ #:when #'intern? (mk #'intern?)] @@ -121,20 +124,25 @@ (define-syntax (make-prim-type stx) (define default-flds #'(seq)) (define-syntax-class type-name-base - #:attributes (i lower-s first-letter (fld-names 1)) + #:attributes (i lower-s first-letter key? (fld-names 1)) #:transparent (pattern i:id #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:when (printf "loc1: ~a~n" #'lower-s) #:with (fld-names ...) default-flds + #:with key? #'#f #:with first-letter (string-ref #'lower-s 0)) (pattern [i:id #:d d-name:id] #:with (fld-names ...) default-flds #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:with key? #'#f #:with first-letter (symbol->string #'d-name.datum)) - (pattern [i:id #:fields extra-fld-names:id ...] + (pattern [i:id #:key] #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) - (syntax->list #'(extra-fld-names ...)))) + (syntax->list #'(key)))) #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:when (printf "loc2: ~v~n" (syntax->datum #'lower-s)) + #:with key? #'#t #:with first-letter (string-ref #'lower-s 0))) (define-syntax-class type-name #:transparent @@ -151,10 +159,10 @@ #'(begin (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)) ... + (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))) ... (define-for-syntax i.rec-id #'i.rec-id) ...)])) -(make-prim-type [Type #:fields key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] +(make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] [PathElem #:d pe]) From 26fe69d9a775c4f3af7b094c1eddbee97df2650b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 18 Feb 2009 04:31:28 +0000 Subject: [PATCH 008/156] fix some strange stxclass strangeness svn: r13722 --- collects/typed-scheme/rep/interning.ss | 5 +++-- collects/typed-scheme/rep/rep-utils.ss | 16 +++++++--------- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 2430ee4af9..4a85792ce2 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -7,8 +7,9 @@ (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name key ([#:extra-arg e:expr]) ...*) - #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)] + [(_ name+args make-name:id key:expr . rest) + #:with (_:id _:id ...) #'name+args + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key . rest)] [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) #'(define *name (let ([table (make-ht)]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 0cfd62bd35..ee2b632687 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -80,12 +80,12 @@ (provide ex pred acc ...) (p/c (rename *maker maker *maker-cnt))))] [intern - (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int - #,@(if key? - #'(#:extra-arg key-expr) - #'())))]) - (syntax-parse #'flds.fs - [_ #:when #'intern? + (let ([mk (lambda (int) + (if key? + #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr) + #`(defintern (**maker . flds.fs) maker #,int)))]) + (syntax-parse #'flds.fs + [_ #:when #'intern? (mk #'intern?)] [() (mk #'#f)] [(f) (mk #'f)] @@ -96,7 +96,7 @@ (list (combiner #'free-vars* #'flds.fs) (combiner #'free-idxs* #'flds.fs)))]) (quasisyntax/loc stx - (w/c nm ([*maker *maker-cnt]) + (w/c nm ([*maker *maker-cnt]) (define (*maker . flds.fs) (define v (**maker . flds.fs)) (unless-in-table @@ -128,7 +128,6 @@ #:transparent (pattern i:id #:with lower-s (string-downcase (symbol->string #'i.datum)) - #:when (printf "loc1: ~a~n" #'lower-s) #:with (fld-names ...) default-flds #:with key? #'#f #:with first-letter (string-ref #'lower-s 0)) @@ -141,7 +140,6 @@ #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) (syntax->list #'(key)))) #:with lower-s (string-downcase (symbol->string #'i.datum)) - #:when (printf "loc2: ~v~n" (syntax->datum #'lower-s)) #:with key? #'#t #:with first-letter (string-ref #'lower-s 0))) (define-syntax-class type-name From e5e0adb499e0037c125f9662c19952bb872276ae Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 19 Feb 2009 01:39:11 +0000 Subject: [PATCH 009/156] checkpoint again svn: r13735 --- collects/typed-scheme/rep/filter-rep.ss | 14 ++++- collects/typed-scheme/rep/interning.ss | 10 ++-- collects/typed-scheme/rep/rep-utils.ss | 28 ++++++---- collects/typed-scheme/rep/type-rep.ss | 69 +++++++++++-------------- 4 files changed, 65 insertions(+), 56 deletions(-) diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index d468d109f8..965defde52 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require mzlib/plt-match) -(require mzlib/etc) +(require scheme/match scheme/contract) (require "rep-utils.ss" "free-variance.ss") (df Bot () [#:fold-rhs #:base]) @@ -18,6 +17,11 @@ (combine-frees (map free-idxs* (cons t p)))] [#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) +(df FilterSet ([thn (listof (and/c Filter? (not/c FilterSet?)))] + [els (listof (and/c Filter? (not/c FilterSet?)))]) + [#:frees (combine-frees (map free-vars* (append thn els))) + (combine-frees (map free-idxs* (append thn els)))] + [#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))]) (dlf LBot () [#:fold-rhs #:base]) @@ -30,3 +34,9 @@ [#:frees (combine-frees (map free-vars* (cons t p))) (combine-frees (map free-idxs* (cons t p)))] [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) + +(dlf LFilterSet ([thn (listof (and/c LatentFilter? (not/c LFilterSet?)))] + [els (listof (and/c LatentFilter? (not/c LFilterSet?)))]) + [#:frees (combine-frees (map free-vars* (append thn els))) + (combine-frees (map free-idxs* (append thn els)))] + [#:fold-rhs (*LFilterSet (map latentfilter-rec-id thn) (map latentfilter-rec-id els))]) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 4a85792ce2..151b976903 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -4,13 +4,11 @@ (provide defintern hash-id) - (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name:id key:expr . rest) - #:with (_:id _:id ...) #'name+args - #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key . rest)] - [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) + [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)] + [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr] #:opt) ...) #'(define *name (let ([table (make-ht)]) (lambda (arg ...) @@ -18,7 +16,7 @@ (let ([key key-expr]) (hash-ref table key (lambda () - (let ([new (make-name (count!) e ... arg ...)]) + (let ([new (make-name (count!) e arg ...)]) (hash-set! table key new) new)))))))])) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ee2b632687..ac59875f9e 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -8,6 +8,7 @@ "interning.ss" mzlib/etc scheme/contract + (for-meta 1 stxclass/util) (for-syntax stxclass scheme/base @@ -40,11 +41,18 @@ [(e ...) #`(combine-frees (list (#,f e) ...))])) (define-syntax-class frees-pat #:transparent - #:attributes (f1 f2) - (pattern (f1:expr f2:expr)) + #:attributes (f1 f2 def) + (pattern (f1:expr f2:expr) + #:with def #'(begin)) (pattern (#f) #:with f1 #'empty-hash-table - #:with f2 #'empty-hash-table)) + #:with f2 #'empty-hash-table + #:with def #'(begin)) + (pattern (e:expr) + #:with id (generate-temporary) + #:with def #'(define id e) + #:with f1 #'(id free-vars*) + #:with f2 #'(id free-idxs*))) (define-syntax-class fold-pat #:transparent #:attributes (e) @@ -54,12 +62,12 @@ #:with e #'#'ex)) (lambda (stx) (syntax-parse stx - [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt - [[#:intern intern?:expr]] #:opt - [[#:frees . frees:frees-pat]] #:opt - [[#:fold-rhs fold-rhs:fold-pat]] #:opt - [[#:contract cnt:expr]] #:opt - [no-provide?:no-provide-kw] #:opt) ...*) + [(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt + [[#:intern intern?:expr]] #:opt + [[#:frees . frees:frees-pat]] #:opt + [[#:fold-rhs fold-rhs:fold-pat]] #:opt + [[#:contract cnt:expr]] #:opt + [no-provide?:no-provide-kw] #:opt) ...) (with-syntax* ([ex (mk-id #'nm #'nm ":")] [kw-stx (string->keyword (symbol->string #'nm.datum))] @@ -90,6 +98,7 @@ [() (mk #'#f)] [(f) (mk #'f)] [_ (mk #'(list . flds.fs))]))] + [frees-def (if #'frees #'frees.def #'(begin))] [frees (with-syntax ([(f1 f2) (if #'frees #'(frees.f1 frees.f2) @@ -99,6 +108,7 @@ (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) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index e34ba3f1ec..32c0d7f6f0 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") (require (utils tc-utils) - "rep-utils.ss" "effect-rep.ss" "free-variance.ss" + "rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss" mzlib/trace scheme/match scheme/contract stxclass/util @@ -109,14 +109,18 @@ (dt Opaque ([pred identifier?] [cert procedure?]) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) +;; represents an argument and its associated filters +(dt DomType ([t Type?] [filters LFilterSet?]) + [#:fold-rhs (*DomTy (type-rec-id t) + (latentfilter-rec-id filters))]) + ;; kw : keyword? ;; ty : Type ;; required? : Boolean -(dt Keyword ([kw keyword?] [ty Type?] [required? boolean?]) +(dt Keyword ([kw keyword?] [ty DomType?] [required? boolean?]) [#:frees (free-vars* ty) (free-idxs* ty)] - [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)] - [#:key 'keyword]) + [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) ;; dom : Listof[Type] ;; rng : Type @@ -127,36 +131,25 @@ ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type -(dt arr ([dom (listof Type?)] +(dt arr ([dom (listof DomType?)] [rng Type?] [rest (or/c #f Type?)] [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] [kws (listof Keyword?)] - [thn-eff (listof Effect?)] - [els-eff (listof Effect?)]) - [#:key 'procedure] - [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) - (map Keyword-ty kws) - dom))) - (match drest - [(cons t (? symbol? bnd)) - (list (fix-bound (flip-variances (free-vars* t)) bnd))] - [(cons t bnd) (list (flip-variances (free-vars* t)))] - [_ null]) - (list (free-vars* rng)) - (map make-invariant - (map free-vars* (append thn-eff els-eff))))) - (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) - (map Keyword-ty kws) - dom))) - (match drest - [(cons t (? number? bnd)) - (list (fix-bound (flip-variances (free-idxs* t)) bnd))] - [(cons t bnd) (list (flip-variances (free-idxs* t)))] - [_ null]) - (list (free-idxs* rng)) - (map make-invariant - (map free-idxs* (append thn-eff els-eff)))))] + [filters (listof LatentFilter?)]) + [#:frees (lambda (free*) + (combine-frees + (append (map (compose flip-variances free*) + (append (if rest (list rest) null) + (map Keyword-ty kws) + dom)) + (match drest + [(cons t (? symbol? bnd)) + (list (fix-bound (flip-variances (free* t)) bnd))] + [(cons t bnd) (list (flip-variances (free* t)))] + [_ null]) + (list (free* rng)) + (map (compose make-invariant free*) filters))))] [#:fold-rhs (*arr (map type-rec-id dom) (type-rec-id rng) (and rest (type-rec-id rest)) @@ -167,13 +160,13 @@ (map effect-rec-id els-eff))]) ;; top-arr is the supertype of all function types -(dt top-arr () - [#:frees #f] [#:fold-rhs #:base]) +(dt top-arr () [#:fold-rhs #:base]) (define arr/c (or/c top-arr? arr?)) ;; arities : Listof[arr] (dt Function ([arities (listof arr/c)]) + [#:key 'procedure] [#:frees (combine-frees (map free-vars* arities)) (combine-frees (map free-idxs* arities))] [#:fold-rhs (*Function (map type-rec-id arities))]) @@ -317,7 +310,7 @@ ;; type/effect fold -(define-syntaxes (type-case effect-case) +(define-syntaxes (type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) (let () (define (mk ht) (lambda (stx) @@ -363,17 +356,15 @@ #,(quasisyntax/loc stx (match #,fold-target #,@(hash-map ht gen-clause))))))])))) - (values (mk type-name-ht) (mk effect-name-ht)))) + (apply values + (map mk + (list type-name-ht filter-name-ht latentfilter-name-ht object-name-ht latentobject-name-ht pathelem-name-ht))))) -(provide type-case effect-case) +(provide type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; sub-eff : (Type -> Type) Eff -> Eff -(define (sub-eff sb eff) - (effect-case sb eff)) - (define (add-scopes n t) (if (zero? n) t (add-scopes (sub1 n) (*Scope t)))) From 72ff13bea9b32631551ace3a24c97064c3d5b802 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 19 Feb 2009 17:39:19 +0000 Subject: [PATCH 010/156] new function representation svn: r13744 --- collects/typed-scheme/rep/filter-rep.ss | 16 +++--- collects/typed-scheme/rep/rep-utils.ss | 61 +++++++++++++++++++--- collects/typed-scheme/rep/type-rep.ss | 68 +++++++++++-------------- 3 files changed, 92 insertions(+), 53 deletions(-) diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index 965defde52..e9f70374ba 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -23,17 +23,17 @@ (combine-frees (map free-idxs* (append thn els)))] [#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))]) +(define index/c (or/c natural-number/c keyword?)) + (dlf LBot () [#:fold-rhs #:base]) -(dlf LTypeFilter ([t Type?] [p (listof PathElem?)]) - [#:frees (combine-frees (map free-vars* (cons t p))) - (combine-frees (map free-idxs* (cons t p)))] - [#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) +(dlf LTypeFilter ([t Type?] [p (listof PathElem?)] [idx index/c]) + [#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))] + [#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)]) -(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)]) - [#:frees (combine-frees (map free-vars* (cons t p))) - (combine-frees (map free-idxs* (cons t p)))] - [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) +(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)] [idx index/c]) + [#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))] + [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)]) (dlf LFilterSet ([thn (listof (and/c LatentFilter? (not/c LFilterSet?)))] [els (listof (and/c LatentFilter? (not/c LFilterSet?)))]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ac59875f9e..263f9790e9 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -156,6 +156,8 @@ #:transparent (pattern :type-name-base #:with name #'i + #:with tmp-rec-id (generate-temporary) + #:with case (mk-id #'i #'lower-s "-case") #:with printer (mk-id #'i "print-" #'lower-s "*") #:with ht (mk-id #'i #'lower-s "-name-ht") #:with rec-id (mk-id #'i #'lower-s "-rec-id") @@ -164,13 +166,58 @@ (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))) (syntax-parse stx [(_ i:type-name ...) - #'(begin - (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?)) ... - (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))) ... - (define-for-syntax i.rec-id #'i.rec-id) ...)])) + (with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))] + [fresh-ids-list #'(fresh-ids ...)]) + #'(begin + (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?)) ... + (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))) ... + (define-for-syntax i.rec-id #'i.rec-id) ... + (provide i.case ...) + (define-syntaxes (i.case ...) + (let () + (define (mk ht) + (lambda (stx) + (let ([ht (hash-copy ht)]) + (define (mk-matcher kw) + (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":")))) + (define (add-clause cl) + (... + (syntax-case cl () + [(kw #:matcher mtch pats ... expr) + (hash-set! ht (syntax-e #'kw) (list #'mtch + (syntax/loc cl (pats ...)) + (lambda fresh-ids-list #'expr) + cl))] + [(kw pats ... expr) + (hash-set! ht (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw)) + (syntax/loc cl (pats ...)) + (lambda fresh-ids-list #'expr) + cl))]))) + (define i.tmp-rec-id i.rec-id) ... + (define (gen-clause k v) + (define match-ex (car v)) + (define pats (cadr v)) + (define body-f (caddr v)) + (define src (cadddr v)) + (define pat (quasisyntax/loc src (#,match-ex . #,pats))) + (define cl (quasisyntax/loc src (#,pat #,(body-f i.tmp-rec-id ...)))) + cl) + (syntax-case stx () + [(tc fresh-ids ... ty . clauses) + (begin + (map add-clause (syntax->list #'clauses)) + (with-syntax ([old-rec-id type-rec-id]) + #`(let ([#,i.tmp-rec-id fresh-ids] ... + [#,fold-target ty]) + ;; then generate the fold + #,(quasisyntax/loc stx + (match #,fold-target + #,@(hash-map ht gen-clause))))))])))) + (apply values + (map mk (list i.ht ...)))))))])) (make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] [PathElem #:d pe]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 32c0d7f6f0..61405616df 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -109,19 +109,28 @@ (dt Opaque ([pred identifier?] [cert procedure?]) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) -;; represents an argument and its associated filters -(dt DomType ([t Type?] [filters LFilterSet?]) - [#:fold-rhs (*DomTy (type-rec-id t) - (latentfilter-rec-id filters))]) - ;; kw : keyword? ;; ty : Type ;; required? : Boolean -(dt Keyword ([kw keyword?] [ty DomType?] [required? boolean?]) - [#:frees (free-vars* ty) - (free-idxs* ty)] +(dt Keyword ([kw keyword?] [ty Type?] [required? boolean?]) + [#:frees (λ (f) (f ty))] [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) +(dt Result ([t Type?] [f LFilterSet?] [o LatentObject?]) + [#:frees (λ (f) (combine-frees (map f (list t f o))))] + [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))]) + +;; types : Listof[Type] +(dt Values ([rs (listof Result?)]) + #:no-provide + [#:frees (λ (f) (combine-frees (map f rs)))] + [#:fold-rhs (*Values (map type-rec-id types))]) + +(dt ValuesDots ([types (listof Result?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) + [#:frees (λ (f) (combine-frees (map f (cons dty types))))] + [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)]) + + ;; dom : Listof[Type] ;; rng : Type ;; rest : Option[Type] @@ -131,12 +140,11 @@ ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type -(dt arr ([dom (listof DomType?)] - [rng Type?] +(dt arr ([dom (listof Type?)] + [rng (or/c Values? ValuesDots?)] [rest (or/c #f Type?)] [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] - [kws (listof Keyword?)] - [filters (listof LatentFilter?)]) + [kws (listof Keyword?)]) [#:frees (lambda (free*) (combine-frees (append (map (compose flip-variances free*) @@ -146,18 +154,14 @@ (match drest [(cons t (? symbol? bnd)) (list (fix-bound (flip-variances (free* t)) bnd))] - [(cons t bnd) (list (flip-variances (free* t)))] - [_ null]) - (list (free* rng)) - (map (compose make-invariant free*) filters))))] + [(cons t (? number? bnd)) (list (flip-variances (free* t)))] + [#f null]) + (list (free* rng)))))] [#:fold-rhs (*arr (map type-rec-id dom) (type-rec-id rng) (and rest (type-rec-id rest)) (and drest (cons (type-rec-id (car drest)) (cdr drest))) - (for/list ([kw kws]) - (make Keyword (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw))) - (map effect-rec-id thn-eff) - (map effect-rec-id els-eff))]) + (map type-rec-id kws))]) ;; top-arr is the supertype of all function types (dt top-arr () [#:fold-rhs #:base]) @@ -230,20 +234,6 @@ (dt Univ () [#:frees #f] [#:fold-rhs #:base]) -;; types : Listof[Type] -(dt Values ([types (listof Type?)]) - #:no-provide - [#:frees (combine-frees (map free-vars* types)) - (combine-frees (map free-idxs* types))] - [#:fold-rhs (*Values (map type-rec-id types))] - [#:key 'values]) - -(dt ValuesDots ([types (listof Type?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) - [#:frees (combine-frees (map free-vars* (cons dty types))) - (combine-frees (map free-idxs* (cons dty types)))] - [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)] - [#:key 'values]) - ;; in : Type ;; out : Type (dt Param ([in Type?] [out Type?]) [#:key 'parameter]) @@ -297,7 +287,7 @@ (provide set-union-maker! get-union-maker) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +#| ;; remove-dups: List[Type] -> List[Type] ;; removes duplicate types from a SORTED list (define (remove-dups types) @@ -305,11 +295,11 @@ [(null? (cdr types)) types] [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))] [else (cons (car types) (remove-dups (cdr types)))])) - +|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type/effect fold - +#| (define-syntaxes (type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) (let () (define (mk ht) @@ -361,9 +351,10 @@ (list type-name-ht filter-name-ht latentfilter-name-ht object-name-ht latentobject-name-ht pathelem-name-ht))))) (provide type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) - +|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| (define (add-scopes n t) (if (zero? n) t @@ -649,3 +640,4 @@ ;(trace unfold) +|# \ No newline at end of file From 428e7c471b915a6fbc2b52631a3f848c7faf3553 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 19 Feb 2009 21:28:41 +0000 Subject: [PATCH 011/156] checkpoint svn: r13749 --- collects/typed-scheme/rep/rep-utils.ss | 117 +++++++++++++++---------- collects/typed-scheme/rep/type-rep.ss | 12 +-- 2 files changed, 79 insertions(+), 50 deletions(-) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 263f9790e9..e80c88717f 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -14,6 +14,7 @@ scheme/base syntax/struct syntax/stx + scheme/contract (rename-in (utils utils) [id mk-id]))) (provide == defintern hash-id (for-syntax fold-target)) @@ -70,6 +71,7 @@ [no-provide?:no-provide-kw] #:opt) ...) (with-syntax* ([ex (mk-id #'nm #'nm ":")] + [fold-name (mk-id #f #'nm "-fold")] [kw-stx (string->keyword (symbol->string #'nm.datum))] [parent par] [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)] @@ -79,9 +81,15 @@ (or #'cnt #'(flds.cnt ... . -> . pred)) #'any/c)] [ht-stx ht-stx] - [bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)] - [else #'(lambda (type-rec-id effect-rec-id) - #`(*maker (#,type-rec-id flds.i) ...))])] + [bfs-fold-rhs (cond [#'fold-rhs #`(procedure-rename + (lambda () #,#'fold-rhs.e) + 'fold-name)] + ;; otherwise we assume that everything is a type, + ;; and recur on all the arguments + [else #'(procedure-rename + (lambda () + #`(*maker (#,type-rec-id flds.i) ...)) + 'fold-name)])] [provides (if #'no-provide? #'(begin) #`(begin @@ -130,6 +138,64 @@ provides frees))]))) +(define-for-syntax (mk-fold ht type-rec-id rec-ids) + (lambda (stx) + (define anys (for/list ([i rec-ids]) any/c)) + (with-syntax* ([(fresh-ids ...) (generate-temporaries rec-ids)]) + (let ([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? + (lambda (p) (procedure-arity-includes? p (length rec-ids))) + syntax?) + . -> . void?) + (hash-set! 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 i.tmp-rec-id i.rec-id) ... + (define (gen-clause k v) + (define match-ex (car v)) + (define pats (cadr v)) + (define body-f (caddr v)) + (define tmpx (printf "got to here 1~n")) + (define src (cadddr v)) + (define pat (quasisyntax/loc src (#,match-ex . #,pats))) + (define tmpx2 (printf "got to here 2: ~a ~a~n" body-f (object-name body-f))) + (define cl (quasisyntax/loc src (#,pat #,(body-f)))) + (define tmpx3 (printf "got to here 3~n")) + cl) + (define-syntax-class (sized-id-list k) + (pattern (i:id ...) + #:when (= k (length (syntax->list #'(i ...)))))) + (syntax-parse stx + [(tc fresh-ids ty . clauses) + #:declare fresh-ids (sized-id-list (length rec-ids)) + (begin + (map add-clause (syntax->list #'clauses)) + (with-syntax ([old-rec-id type-rec-id] + [(let-clauses ...) + (for/list ([rec-id rec-ids] + [i (syntax->list #'fresh-ids)]) + #`[#,rec-id #,i])]) + #`(let (let-clauses ... + [#,fold-target ty]) + ;; then generate the fold + #,(quasisyntax/loc stx + (match #,fold-target + #,@(hash-map ht gen-clause))))))]))))) + (define-syntax (make-prim-type stx) (define default-flds #'(seq)) @@ -167,7 +233,8 @@ (syntax-parse stx [(_ i:type-name ...) (with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))] - [fresh-ids-list #'(fresh-ids ...)]) + [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.accs ... ... (for-syntax i.ht ... i.rec-id ...)) @@ -177,47 +244,9 @@ (define-for-syntax i.rec-id #'i.rec-id) ... (provide i.case ...) (define-syntaxes (i.case ...) - (let () - (define (mk ht) - (lambda (stx) - (let ([ht (hash-copy ht)]) - (define (mk-matcher kw) - (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":")))) - (define (add-clause cl) - (... - (syntax-case cl () - [(kw #:matcher mtch pats ... expr) - (hash-set! ht (syntax-e #'kw) (list #'mtch - (syntax/loc cl (pats ...)) - (lambda fresh-ids-list #'expr) - cl))] - [(kw pats ... expr) - (hash-set! ht (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw)) - (syntax/loc cl (pats ...)) - (lambda fresh-ids-list #'expr) - cl))]))) - (define i.tmp-rec-id i.rec-id) ... - (define (gen-clause k v) - (define match-ex (car v)) - (define pats (cadr v)) - (define body-f (caddr v)) - (define src (cadddr v)) - (define pat (quasisyntax/loc src (#,match-ex . #,pats))) - (define cl (quasisyntax/loc src (#,pat #,(body-f i.tmp-rec-id ...)))) - cl) - (syntax-case stx () - [(tc fresh-ids ... ty . clauses) - (begin - (map add-clause (syntax->list #'clauses)) - (with-syntax ([old-rec-id type-rec-id]) - #`(let ([#,i.tmp-rec-id fresh-ids] ... - [#,fold-target ty]) - ;; then generate the fold - #,(quasisyntax/loc stx - (match #,fold-target - #,@(hash-map ht gen-clause))))))])))) + (let () (apply values - (map mk (list i.ht ...)))))))])) + (map (lambda (ht) (mk-fold ht (car (list #'i.rec-id ...)) (list #'i.rec-id ...))) (list i.ht ...)))))))])) (make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] [PathElem #:d pe]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 61405616df..0e928d50ec 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -124,11 +124,11 @@ (dt Values ([rs (listof Result?)]) #:no-provide [#:frees (λ (f) (combine-frees (map f rs)))] - [#:fold-rhs (*Values (map type-rec-id types))]) + [#:fold-rhs (*Values (map type-rec-id rs))]) -(dt ValuesDots ([types (listof Result?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) - [#:frees (λ (f) (combine-frees (map f (cons dty types))))] - [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)]) +(dt ValuesDots ([rs (listof Result?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) + [#:frees (λ (f) (combine-frees (map f (cons dty rs))))] + [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) ;; dom : Listof[Type] @@ -354,7 +354,7 @@ |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#| + (define (add-scopes n t) (if (zero? n) t @@ -366,7 +366,7 @@ (match sc [(Scope: sc*) (remove-scopes (sub1 n) sc*)] [_ (int-err "Tried to remove too many scopes: ~a" sc)]))) - +#| ;; abstract-many : Names Type -> Scope^n ;; where n is the length of names (define (abstract-many names ty) From 0edfd7f31f8e85b7d0176c28baebeae22e34de00 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 20 Feb 2009 23:35:02 +0000 Subject: [PATCH 012/156] Finished new representation defs and folding. New definition of `define-requirer' that doesn't use lib requires. New `defprinter' syntax. svn: r13755 --- collects/typed-scheme/rep/rep-utils.ss | 159 +++++++++++++++---------- collects/typed-scheme/rep/type-rep.ss | 106 ++++------------- collects/typed-scheme/utils/utils.ss | 53 +++++---- 3 files changed, 148 insertions(+), 170 deletions(-) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index e80c88717f..ea86764836 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -7,9 +7,11 @@ "free-variance.ss" "interning.ss" mzlib/etc - scheme/contract - (for-meta 1 stxclass/util) + scheme/contract (for-syntax + scheme/list + stxclass/util + scheme/match stxclass scheme/base syntax/struct @@ -138,63 +140,87 @@ provides frees))]))) -(define-for-syntax (mk-fold ht type-rec-id rec-ids) +(define-for-syntax (mk-fold ht type-rec-id rec-ids kws) (lambda (stx) - (define anys (for/list ([i rec-ids]) any/c)) - (with-syntax* ([(fresh-ids ...) (generate-temporaries rec-ids)]) - (let ([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? - (lambda (p) (procedure-arity-includes? p (length rec-ids))) - syntax?) - . -> . void?) - (hash-set! 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 i.tmp-rec-id i.rec-id) ... - (define (gen-clause k v) - (define match-ex (car v)) - (define pats (cadr v)) - (define body-f (caddr v)) - (define tmpx (printf "got to here 1~n")) - (define src (cadddr v)) - (define pat (quasisyntax/loc src (#,match-ex . #,pats))) - (define tmpx2 (printf "got to here 2: ~a ~a~n" body-f (object-name body-f))) - (define cl (quasisyntax/loc src (#,pat #,(body-f)))) - (define tmpx3 (printf "got to here 3~n")) - cl) - (define-syntax-class (sized-id-list k) - (pattern (i:id ...) - #:when (= k (length (syntax->list #'(i ...)))))) - (syntax-parse stx - [(tc fresh-ids ty . clauses) - #:declare fresh-ids (sized-id-list (length rec-ids)) - (begin - (map add-clause (syntax->list #'clauses)) - (with-syntax ([old-rec-id type-rec-id] - [(let-clauses ...) - (for/list ([rec-id rec-ids] - [i (syntax->list #'fresh-ids)]) - #`[#,rec-id #,i])]) - #`(let (let-clauses ... - [#,fold-target ty]) - ;; then generate the fold - #,(quasisyntax/loc stx - (match #,fold-target - #,@(hash-map ht gen-clause))))))]))))) + (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 + (pattern + (k:keyword #:matcher mtch pats ... e:expr) + #:with kw #'k.datum + #:with val (list #'mtch + (syntax #;#;/loc (current-syntax-context) (pats ...)) + (lambda () #'e) + #'here #;(current-syntax-context))) + (pattern + (k:keyword pats ... e:expr) + #:with kw (syntax-e #'k) + #:with val (list (mk-matcher #'kw) + (syntax #;#;/loc (current-syntax-context) (pats ...)) + (lambda () #'e) + #'here #;(current-syntax-context)))) + (define (gen-clause k v) + (match v + [(list match-ex pats body-f src) + (let ([pat (quasisyntax/loc src (#,match-ex . #,pats))]) + (quasisyntax/loc src (#,pat #,(body-f))))])) + (define-syntax-class (keyword-in kws) + #:attributes (datum) + (pattern k:keyword + #:when (memq #'k.datum kws) + #:with datum #'k.datum)) + (define-syntax-class (sized-list kws) + #:description (format "keyword expr pairs matching with keywords in the list ~a" kws) + (pattern ((~or [k e:expr]) ...) + #:declare k (keyword-in kws) + #:when (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum)))) + #:with mapping (for/hash ([k* (attribute k.datum)] + [e* (attribute e)]) + (values k* e*)) + )) + (syntax-parse stx + [(tc recs ty clauses:clause ...) + #:declare recs (sized-list kws) + (begin + (for ([k (attribute clauses.kw)] + [v (attribute clauses.val)]) + (put k v)) + (with-syntax ([(let-clauses ...) + (for/list ([rec-id rec-ids] + [k kws]) + #`[#,rec-id #,(hash-ref (attribute recs.mapping) k + #'values + #; + (lambda () + (error (format + "failed to find key ~a in table ~a" + k (attribute recs.mapping)))))])]) + #`(let (let-clauses ... + [#,fold-target ty]) + ;; then generate the fold + #,(quasisyntax/loc stx + (match #,fold-target + #,@(hash-map new-ht gen-clause))))))]))) (define-syntax (make-prim-type stx) @@ -222,6 +248,7 @@ #:transparent (pattern :type-name-base #:with name #'i + #:with keyword (string->keyword (symbol->string (syntax-e #'i))) #:with tmp-rec-id (generate-temporary) #:with case (mk-id #'i #'lower-s "-case") #:with printer (mk-id #'i "print-" #'lower-s "*") @@ -233,6 +260,7 @@ (syntax-parse stx [(_ i:type-name ...) (with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))] + [(default-ids ...) (generate-temporaries #'(i.name ...))] [fresh-ids-list #'(fresh-ids ...)] [(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)]) #'(begin @@ -242,11 +270,20 @@ (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))) ... (define-for-syntax i.rec-id #'i.rec-id) ... - (provide i.case ...) + (provide i.case ...) (define-syntaxes (i.case ...) (let () (apply values - (map (lambda (ht) (mk-fold ht (car (list #'i.rec-id ...)) (list #'i.rec-id ...))) (list i.ht ...)))))))])) + (map (lambda (ht) + (mk-fold ht + (car (list #'i.rec-id ...)) + (list #'i.rec-id ...) + '(i.keyword ...))) + (list i.ht ...)))))))])) -(make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] +(make-prim-type [Type #:key] + Filter + [LatentFilter #:d lf] + Object + [LatentObject #:d lo] [PathElem #:d pe]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 0e928d50ec..b837cd14d5 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -130,15 +130,6 @@ [#:frees (λ (f) (combine-frees (map f (cons dty rs))))] [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) - -;; dom : Listof[Type] -;; rng : Type -;; rest : Option[Type] -;; drest : Option[Cons[Type,Name or nat]] -;; kws : Listof[Keyword] -;; rest and drest NOT both true -;; thn-eff : Effect -;; els-eff : Effect ;; arr is NOT a Type (dt arr ([dom (listof Type?)] [rng (or/c Values? ValuesDots?)] @@ -287,7 +278,7 @@ (provide set-union-maker! get-union-maker) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#| + ;; remove-dups: List[Type] -> List[Type] ;; removes duplicate types from a SORTED list (define (remove-dups types) @@ -295,67 +286,11 @@ [(null? (cdr types)) types] [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))] [else (cons (car types) (remove-dups (cdr types)))])) -|# -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; type/effect fold -#| -(define-syntaxes (type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) - (let () - (define (mk ht) - (lambda (stx) - (let ([ht (hash-copy ht)]) - (define (mk-matcher kw) - (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":")))) - (define (add-clause cl) - (syntax-case cl () - [(kw #:matcher mtch pats ... expr) - (hash-set! ht (syntax-e #'kw) (list #'mtch - (syntax/loc cl (pats ...)) - (lambda (tr er) #'expr) - cl))] - [(kw pats ... expr) - (hash-set! ht (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw)) - (syntax/loc cl (pats ...)) - (lambda (tr er) #'expr) - cl))])) - (define rid #'type-rec-id) - (define erid #'effect-rec-id) - (define (gen-clause k v) - (define match-ex (car v)) - (define pats (cadr v)) - (define body-f (caddr v)) - (define src (cadddr v)) - (define pat (quasisyntax/loc src (#,match-ex . #,pats))) - (define cl (quasisyntax/loc src (#,pat #,(body-f rid erid)))) - cl) - (syntax-case stx () - [(tc rec-id ty clauses ...) - (syntax-case #'(clauses ...) () - [([kw pats ... es] ...) #t] - [_ #f]) - (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))] - [(tc rec-id e-rec-id ty clauses ...) - (begin - (map add-clause (syntax->list #'(clauses ...))) - (with-syntax ([old-rec-id type-rec-id]) - #`(let ([#,rid rec-id] - [#,erid e-rec-id] - [#,fold-target ty]) - ;; then generate the fold - #,(quasisyntax/loc stx - (match #,fold-target - #,@(hash-map ht gen-clause))))))])))) - (apply values - (map mk - (list type-name-ht filter-name-ht latentfilter-name-ht object-name-ht latentobject-name-ht pathelem-name-ht))))) - -(provide type-case filter-case latentfilter-case object-case latentobject-case pathelem-case) -|# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (add-scopes n t) (if (zero? n) t (add-scopes (sub1 n) (*Scope t)))) @@ -366,6 +301,26 @@ (match sc [(Scope: sc*) (remove-scopes (sub1 n) sc*)] [_ (int-err "Tried to remove too many scopes: ~a" sc)]))) + +;; type equality +(define type-equal? eq?) + +;; inequality - good + +(define (type Scope^n ;; where n is the length of names @@ -591,23 +546,6 @@ (list syms (PolyDots-body* syms t)))) (list nps bp)))]))) -;; type equality -(define type-equal? eq?) - -;; inequality - good - -(define (typelist #'(id ...))) - (with-syntax ([(id* ...) - (map (lambda (id) - (datum->syntax - id - (string->symbol - (string-append - "typed-scheme/" - #,(symbol->string (syntax-e #'nm)) - "/" - (symbol->string (syntax-e id)))) - id id)) - (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))]))))])) + (define-require-syntax (nm stx) + (syntax-parse stx + [(_ id:identifier ...) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + `(file + ,(path->string + (build-path (collection-path "typed-scheme" + #,(symbol->string (syntax-e #'nm))) + (string-append (symbol->string (syntax-e id)) + ".ss")))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))])))])) (define-requirer rep) @@ -168,11 +164,17 @@ [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #t) +(define-for-syntax printing? #f) -(define print-type* (box (lambda _ (error "print-type* not yet defined")))) -(define print-effect* (box (lambda _ (error "print-effect* not yet defined")))) +(define-syntax-rule (defprinter t ...) + (begin + (define t (box (lambda _ (error (format "~a not yet defined" 't))))) ... + (provide t ...))) +(defprinter + print-type* print-filter* print-latentfilter* print-object* print-latentobject* + print-pathelem*) + (require scheme/pretty mzlib/pconvert) (define-syntax (define-struct/printer stx) @@ -195,6 +197,7 @@ (define (f v) (cond [(string? v) v] [(symbol? v) (symbol->string v)] + [(char? v) (string v)] [(identifier? v) (symbol->string (syntax-e v))])) (datum->syntax kw (string->symbol (apply string-append (map f args))))) From 70e174c0e1fbe917d117e36dd9b7b894497fd115 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 21 Feb 2009 15:23:42 +0000 Subject: [PATCH 013/156] Type rep compiles svn: r13768 --- collects/typed-scheme/rep/rep-utils.ss | 3 +- collects/typed-scheme/rep/type-rep.ss | 46 +++++++++++++------------- 2 files changed, 25 insertions(+), 24 deletions(-) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ea86764836..ebad2a3324 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -108,6 +108,7 @@ [() (mk #'#f)] [(f) (mk #'f)] [_ (mk #'(list . flds.fs))]))] + [(ign-pats ...) (if key? #'(_ _) #'(_))] [frees-def (if #'frees #'frees.def #'(begin))] [frees (with-syntax ([(f1 f2) (if #'frees @@ -132,7 +133,7 @@ (lambda (s) (syntax-parse s [(_ . fs) - #:with pat (syntax/loc s (_ _ . fs)) + #:with pat (syntax/loc s (ign-pats ... . fs)) (syntax/loc s (struct nm pat))]))) (begin-for-syntax (hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx))) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index b837cd14d5..e6cdd5c512 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -320,21 +320,26 @@ (car l) (*Values l))) +(define ((sub-lf st) e) + (latentfilter-case (#:Type st + #:LatentFilter (sub-lf st)) + e)) -#| ;; abstract-many : Names Type -> Scope^n ;; where n is the length of names (define (abstract-many names ty) (define (nameTo name count type) (let loop ([outer 0] [ty type]) (define (sb t) (loop outer t)) + (define slf (sub-lf sb)) (type-case - sb ty + (#:Type sb #:LatentFilter (sub-lf sb)) + ty [#:F name* (if (eq? name name*) (*B (+ count outer)) ty)] ;; necessary to avoid infinite loops [#:Union elems (*Union (remove-dups (sort (map sb elems) type Date: Sat, 21 Feb 2009 17:07:19 +0000 Subject: [PATCH 014/156] printer now compiles svn: r13772 --- .../private/type-effect-printer.ss | 42 +++++++++---------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index b5852df8d3..fc51ae3686 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep effect-rep rep-utils) +(require (rep type-rep filter-rep rep-utils) (utils tc-utils) scheme/match) @@ -9,7 +9,7 @@ ;; FIXME - currently broken (define print-poly-types? #f) ;; do we use simple type aliases in printing -(define print-aliases #t) +(define print-aliases #f) ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] @@ -27,19 +27,21 @@ ;; print out an effect ;; print-effect : Effect Port Boolean -> Void -(define (print-effect c port write?) - (define (fp . args) (apply fprintf port args)) +(define (print-latentfilter c port write?) + (define (fp . args) (apply fprintf port args)) (match c - [(Restrict-Effect: t v) (fp "(restrict ~a ~a)" t (syntax-e v))] - [(Remove-Effect: t v) (fp "(remove ~a ~a)" t (syntax-e v))] - [(Latent-Restrict-Effect: t) (fp "(restrict ~a)" t)] - [(Latent-Remove-Effect: t) (fp "(remove ~a)" t)] - [(Latent-Var-True-Effect:) (fp "(var #t)")] - [(Latent-Var-False-Effect:) (fp "(var #f)")] - [(True-Effect:) (fp "T")] - [(False-Effect:) (fp "F")] - [(Var-True-Effect: v) (fp "(var #t ~a)" (syntax-e v))] - [(Var-False-Effect: v) (fp "(var #f ~a)" (syntax-e v))])) + [(LFilterSet: thn els) (fp "(~a | ~a)") thn els] + [(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)] + [(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)] + [(LBot:) (fp "LBot")])) + +(define (print-filter c port write?) + (define (fp . args) (apply fprintf port args)) + (match c + [(FilterSet: thn els) (fp "(~a | ~a)") thn els] + [(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))] + [(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path (syntax-e id))] + [(Bot:) (fp "Bot")])) ;; print out a type @@ -50,7 +52,7 @@ (match a [(top-arr:) (fp "Procedure")] - [(arr: dom rng rest drest kws thn-eff els-eff) + [(arr: dom rng rest drest kws) (fp "(") (for-each (lambda (t) (fp "~a " t)) dom) (for ([kw kws]) @@ -64,11 +66,6 @@ (when drest (fp "~a ... ~a " (car drest) (cdr drest))) (fp "-> ~a" rng) - (match* (thn-eff els-eff) - [((list) (list)) (void)] - [((list (Latent-Restrict-Effect: t)) (list (Latent-Remove-Effect: t))) (fp " : ~a" t)] - [((list (Latent-Restrict-Effect: t)) (list (Latent-Remove-Effect: t))) (fp " : ~a" t)] - [(_ _) (fp " : ~a ~a" thn-eff els-eff)]) (fp ")")])) (define (tuple? t) (match t @@ -115,7 +112,7 @@ (lambda (e) (fp " ") (print-arr e)) b) (fp ")")]))] - [(arr: _ _ _ _ _ _ _) (print-arr c)] + [(arr: _ _ _ _ _) (print-arr c)] [(Vector: e) (fp "(Vectorof ~a)" e)] [(Box: e) (fp "(Box ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] @@ -161,4 +158,5 @@ )) (set-box! print-type* print-type) -(set-box! print-effect* print-effect) +(set-box! print-filter* print-filter) +(set-box! print-latentfilter* print-latentfilter) From 99f678e1baee83c045c0c215fb3d522773f19980 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 21 Feb 2009 17:07:29 +0000 Subject: [PATCH 015/156] merge ryan's changes svn: r13773 --- collects/typed-scheme/private/parse-type.ss | 2 +- collects/typed-scheme/private/prims.ss | 4 ++-- collects/typed-scheme/private/type-abbrev.ss | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 526d91843e..135384af86 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -251,7 +251,7 @@ (pattern (case-lambda f:fun-ty/one ...) #:with t (make-Function (syntax->datum #'(f.arr ...)))) - (pattern (t:Class (pos-args:type ...) ([fname:id fty:type ((rest:boolean) #:opt) ...*] ...) ([mname:id mty:type] ...)) + (pattern (t:Class (pos-args:type ...) ([fname:id fty:type (~or (rest:boolean) #:opt) ...] ...) ([mname:id mty:type] ...)) #:with t (make-Class (syntax->datum #'(pos-args.t ...)) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index d34ce7dd0d..3988110b43 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -66,7 +66,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ lib [nm:opt-rename ty] ...) #'(begin (require/typed nm ty lib) ...)] - [(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*) + [(_ nm:opt-rename ty lib (~or [#:struct-maker parent] #:opt) ...) (with-syntax ([cnt* (generate-temporary #'nm.nm)] [sm (if #'parent #'(#:struct-maker parent) @@ -87,7 +87,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax-class name-exists-kw (pattern #:name-exists)) (syntax-parse stx - [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*) + [(_ ty:id pred:id lib (~or [ne:name-exists-kw] #:opt) ...) (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) (quasisyntax/loc stx (begin diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 6ee393d4f7..85dd5283c6 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -82,7 +82,7 @@ (define-syntax (->key stx) (syntax-parse stx - [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) #'(make-Function (list (make-arr* (list ty ...) From 85de5f27bfdf2b5d22b0a0f0b3062bbda8ce7618 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 21 Feb 2009 18:07:07 +0000 Subject: [PATCH 016/156] checkpoint svn: r13777 --- collects/typed-scheme/no-check.ss | 29 +++++++++++++++++-- collects/typed-scheme/rep/interning.ss | 13 +++++---- .../{private => rep}/type-effect-printer.ss | 28 +++++++++++++++--- collects/typed-scheme/rep/type-rep.ss | 8 ----- collects/typed-scheme/utils/utils.ss | 2 +- 5 files changed, 60 insertions(+), 20 deletions(-) rename collects/typed-scheme/{private => rep}/type-effect-printer.ss (85%) diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss index bd104f6110..a1a7601c59 100644 --- a/collects/typed-scheme/no-check.ss +++ b/collects/typed-scheme/no-check.ss @@ -1,5 +1,30 @@ #lang scheme/base -(require "private/prims.ss") +#;(require "private/prims.ss") (provide (all-from-out scheme/base) - (all-from-out "private/prims.ss")) + (all-defined-out) + #;(all-from-out "private/prims.ss")) + +(define-syntax-rule (define-type-alias . _) (begin)) + +(define-syntax-rule (define: nm _ _ . body) + (define nm . body)) + +(define-syntax-rule (ann e . rest) e) + +(define-syntax-rule (require/typed mod [id . _] ...) + (require (only-in mod id ...))) + +(define-syntax-rule (: . args) (begin)) + +(define-syntax let: + (syntax-rules () + [(_ ([id _ _ . rest] ...) . b) + (let ([id . rest] ...) . b)] + [(_ id _ _ ([ids _ _ e] ...) . b) + (let id ([ids e] ...) . b)])) + +(define-syntax-rule (lambda: ([id . rest] ...) . b) + (lambda (id ...) . b)) + +(define-syntax-rule (λ: . arg) (lambda: . arg)) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 151b976903..68b393b8d8 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -1,14 +1,17 @@ #lang scheme/base -(require syntax/boundmap (for-syntax scheme/base stxclass)) +(require syntax/boundmap (for-syntax scheme/base stxclass) + macro-debugger/stepper) (provide defintern hash-id) (define-syntax (defintern stx) (syntax-parse stx - [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) - #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)] - [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr] #:opt) ...) + [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) + (if #'e + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e) + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))] + [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...) #'(define *name (let ([table (make-ht)]) (lambda (arg ...) @@ -16,7 +19,7 @@ (let ([key key-expr]) (hash-ref table key (lambda () - (let ([new (make-name (count!) e arg ...)]) + (let ([new (make-name (count!) e ... arg ...)]) (hash-set! table key new) new)))))))])) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/rep/type-effect-printer.ss similarity index 85% rename from collects/typed-scheme/private/type-effect-printer.ss rename to collects/typed-scheme/rep/type-effect-printer.ss index fc51ae3686..c63b650a32 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/rep/type-effect-printer.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep filter-rep rep-utils) +(require (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) scheme/match) @@ -30,7 +30,10 @@ (define (print-latentfilter c port write?) (define (fp . args) (apply fprintf port args)) (match c - [(LFilterSet: thn els) (fp "(~a | ~a)") thn els] + [(LFilterSet: thn els) (fp "(") + (for ([i thn]) (fp "~a " i)) (fp "|") + (for ([i els]) (fp " ~a" i)) + (fp")")] [(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)] [(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)] [(LBot:) (fp "LBot")])) @@ -38,11 +41,26 @@ (define (print-filter c port write?) (define (fp . args) (apply fprintf port args)) (match c - [(FilterSet: thn els) (fp "(~a | ~a)") thn els] + [(FilterSet: thn els) (fp "(") + (for ([i thn]) (fp "~a " i)) (fp "|") + (for ([i els]) (fp " ~a" i)) + (fp")")] [(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))] [(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path (syntax-e id))] [(Bot:) (fp "Bot")])) +(define (print-pathelem c port write?) + (define (fp . args) (apply fprintf port args)) + (match c + [(CarPE:) (fp "car")] + [(CdrPE:) (fp "cdr")] + [(StructPE: t i) (fp "(~a ~a)" t i)])) + +(define (print-latentobject c port write?) + (define (fp . args) (apply fprintf port args)) + (match c + [(LEmpty:) (fp "")] + [(LPath: pes i) (fp "~a" (append pes (list i)))])) ;; print out a type ;; print-type : Type Port Boolean -> Void @@ -145,7 +163,7 @@ (Vector: (F: x)) (Box: (F: x)))))) (fp "SyntaxObject")] - [(Mu-name: name body) (fp "(mu ~a ~a ~a)" (Type-seq c) name body)] + [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)] ;; FIXME - this should not be used #; [(Scope: sc) (fp "(Scope ~a)" sc)] @@ -160,3 +178,5 @@ (set-box! print-type* print-type) (set-box! print-filter* print-filter) (set-box! print-latentfilter* print-latentfilter) +(set-box! print-latentobject* print-latentobject) +(set-box! print-pathelem* print-pathelem) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index e6cdd5c512..e791defb95 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -122,7 +122,6 @@ ;; types : Listof[Type] (dt Values ([rs (listof Result?)]) - #:no-provide [#:frees (λ (f) (combine-frees (map f rs)))] [#:fold-rhs (*Values (map type-rec-id rs))]) @@ -315,11 +314,6 @@ [(type Date: Sat, 21 Feb 2009 18:08:11 +0000 Subject: [PATCH 017/156] rename printer file svn: r13778 --- collects/typed-scheme/rep/{type-effect-printer.ss => printer.ss} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename collects/typed-scheme/rep/{type-effect-printer.ss => printer.ss} (100%) diff --git a/collects/typed-scheme/rep/type-effect-printer.ss b/collects/typed-scheme/rep/printer.ss similarity index 100% rename from collects/typed-scheme/rep/type-effect-printer.ss rename to collects/typed-scheme/rep/printer.ss From b57c78e0a4d97d556e2e94a296c823d7e1ffec36 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 21 Feb 2009 18:31:23 +0000 Subject: [PATCH 018/156] finished implementing printing svn: r13779 --- collects/typed-scheme/rep/printer.ss | 10 ++++++ collects/typed-scheme/rep/type-rep.ss | 49 ++++++++++++++++----------- 2 files changed, 40 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/rep/printer.ss b/collects/typed-scheme/rep/printer.ss index c63b650a32..7bef89b314 100644 --- a/collects/typed-scheme/rep/printer.ss +++ b/collects/typed-scheme/rep/printer.ss @@ -62,6 +62,12 @@ [(LEmpty:) (fp "")] [(LPath: pes i) (fp "~a" (append pes (list i)))])) +(define (print-object c port write?) + (define (fp . args) (apply fprintf port args)) + (match c + [(Empty:) (fp "")] + [(Path: pes i) (fp "~a" (append pes (list (syntax-e i))))])) + ;; print out a type ;; print-type : Type Port Boolean -> Void (define (print-type c port write?) @@ -172,11 +178,15 @@ [(Syntax: t) (fp "(Syntax ~a)" t)] [(Instance: t) (fp "(Instance ~a)" t)] [(Class: pf nf ms) (fp "(Class)")] + [(Result: t (LFilterSet: (list) (list)) (LEmpty:)) (fp "~a" t)] + [(Result: t fs (LEmpty:)) (fp "(~a : ~a)" t fs)] + [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] [else (fp "Unknown Type: ~a" (struct->vector c))] )) (set-box! print-type* print-type) (set-box! print-filter* print-filter) (set-box! print-latentfilter* print-latentfilter) +(set-box! print-object* print-object) (set-box! print-latentobject* print-latentobject) (set-box! print-pathelem* print-pathelem) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index e791defb95..ff06cc92a8 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -10,6 +10,17 @@ (define name-table (make-weak-hasheq)) +(define Type/c + (flat-named-contract + "Type" + (λ (e) + (and (Type? e) + (not (Scope? e)) + (not (arr? e)) + (not (Values? e)) + (not (ValuesDots? e)) + (not (Result? e)))))) + ;; Name = Symbol ;; Type is defined in rep-utils.ss @@ -44,7 +55,7 @@ ;; rator is a type ;; rands is a list of types ;; stx is the syntax of the pair of parens -(dt App ([rator Type?] [rands (listof Type?)] [stx (or/c #f syntax?)]) +(dt App ([rator Type/c] [rands (listof Type/c)] [stx (or/c #f syntax?)]) [#:intern (list rator rands)] [#:frees (combine-frees (map free-vars* (cons rator rands))) (combine-frees (map free-idxs* (cons rator rands)))] @@ -53,15 +64,15 @@ stx)]) ;; left and right are Types -(dt Pair ([left Type?] [right Type?]) [#:key 'pair]) +(dt Pair ([left Type/c] [right Type/c]) [#:key 'pair]) ;; elem is a Type -(dt Vector ([elem Type?]) +(dt Vector ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] [#:key 'vector]) ;; elem is a Type -(dt Box ([elem Type?]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] +(dt Box ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] [#:key 'box]) ;; name is a Symbol (not a Name) @@ -112,12 +123,12 @@ ;; kw : keyword? ;; ty : Type ;; required? : Boolean -(dt Keyword ([kw keyword?] [ty Type?] [required? boolean?]) +(dt Keyword ([kw keyword?] [ty Type/c] [required? boolean?]) [#:frees (λ (f) (f ty))] [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) -(dt Result ([t Type?] [f LFilterSet?] [o LatentObject?]) - [#:frees (λ (f) (combine-frees (map f (list t f o))))] +(dt Result ([t Type/c] [f LFilterSet?] [o LatentObject?]) + [#:frees (λ (frees) (combine-frees (map frees (list t f o))))] [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))]) ;; types : Listof[Type] @@ -125,15 +136,15 @@ [#:frees (λ (f) (combine-frees (map f rs)))] [#:fold-rhs (*Values (map type-rec-id rs))]) -(dt ValuesDots ([rs (listof Result?)] [dty Type?] [dbound (or/c symbol? natural-number/c)]) +(dt ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)]) [#:frees (λ (f) (combine-frees (map f (cons dty rs))))] [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) ;; arr is NOT a Type -(dt arr ([dom (listof Type?)] +(dt arr ([dom (listof Type/c)] [rng (or/c Values? ValuesDots?)] - [rest (or/c #f Type?)] - [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] + [rest (or/c #f Type/c)] + [drest (or/c #f (cons/c Type/c (or/c natural-number/c symbol?)))] [kws (listof Keyword?)]) [#:frees (lambda (free*) (combine-frees @@ -175,7 +186,7 @@ ;; cert : syntax certifier for pred-id (dt Struct ([name symbol?] [parent (or/c #f Struct? Name?)] - [flds (listof Type?)] + [flds (listof Type/c)] [proc (or/c #f Function?)] [poly? boolean?] [pred-id identifier?] @@ -200,7 +211,7 @@ [else #f])]) ;; elems : Listof[Type] -(dt Union ([elems (and/c (listof Type?) +(dt Union ([elems (and/c (listof Type/c) (lambda (es) (let-values ([(sorted? k) (for/fold ([sorted? #t] @@ -226,20 +237,20 @@ ;; in : Type ;; out : Type -(dt Param ([in Type?] [out Type?]) [#:key 'parameter]) +(dt Param ([in Type/c] [out Type/c]) [#:key 'parameter]) ;; key : Type ;; value : Type -(dt Hashtable ([key Type?] [value Type?]) [#:key 'hash]) +(dt Hashtable ([key Type/c] [value Type/c]) [#:key 'hash]) ;; t : Type -(dt Syntax ([t Type?]) [#:key 'syntax]) +(dt Syntax ([t Type/c]) [#:key 'syntax]) ;; pos-flds : (Listof Type) ;; name-flds : (Listof (Tuple Symbol Type Boolean)) ;; methods : (Listof (Tuple Symbol Function)) -(dt Class ([pos-flds (listof Type?)] - [name-flds (listof (list/c symbol? Type? boolean?))] +(dt Class ([pos-flds (listof Type/c)] + [name-flds (listof (list/c symbol? Type/c boolean?))] [methods (listof (list/c symbol? Function?))]) [#:frees (combine-frees (map free-vars* (append pos-flds @@ -541,7 +552,6 @@ (list syms (PolyDots-body* syms t)))) (list nps bp)))]))) - ;(trace subst subst-all) (provide @@ -553,6 +563,7 @@ Mu? Poly? PolyDots? arr Type? Filter? LatentFilter? Object? LatentObject? + Type/c Poly-n PolyDots-n free-vars* From a1fb6962330cc6fbd078a07047394f95742b8102 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 21 Feb 2009 20:19:44 +0000 Subject: [PATCH 019/156] type-utils.ss now compiles svn: r13782 --- collects/typed-scheme/private/type-utils.ss | 75 +++++++++++---------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index d4ca2ad05b..d92760d7de 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") -(require (rep type-rep effect-rep rep-utils) +(require (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) (only-in (rep free-variance) combine-frees) scheme/match @@ -20,7 +20,6 @@ ;ret instantiate-poly instantiate-poly-dotted - tc-result: tc-result? tc-result-equal? effects-equal? @@ -37,10 +36,11 @@ (define (substitute image name target #:Un [Un (get-union-maker)]) (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) - (type-case sb target + (type-case (#:Type sb #:LatentFilter (sub-lf sb)) + target [#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] - [#:arr dom rng rest drest kws thn-eff els-eff + [#:arr dom rng rest drest kws (begin (when (and (pair? drest) (eq? name (cdr drest)) @@ -50,10 +50,7 @@ (sb rng) (and rest (sb rest)) (and drest (cons (sb (car drest)) (cdr drest))) - (for/list ([kw kws]) - (cons (car kw) (sb (cdr kw)))) - (map (lambda (e) (sub-eff sb e)) thn-eff) - (map (lambda (e) (sub-eff sb e)) els-eff)))] + (map sb kws)))] [#:ValuesDots types dty dbound (begin (when (eq? name dbound) @@ -65,7 +62,7 @@ (define (substitute-dots images rimage name target) (define (sb t) (substitute-dots images rimage name t)) (if (hash-ref (free-vars* target) name #f) - (type-case sb target + (type-case (#:Type sb #:LatentFilter (sub-lf sb)) target [#:ValuesDots types dty dbound (if (eq? name dbound) (make-Values @@ -73,9 +70,13 @@ (map sb types) ;; We need to recur first, just to expand out any dotted usages of this. (let ([expanded (sb dty)]) - (map (lambda (img) (substitute img name expanded)) images)))) + (for/list ([img images]) + (make-Result + (substitute img name expanded) + (make-LFilterSet null null) + (make-LEmpty)))))) (make-ValuesDots (map sb types) (sb dty) dbound))] - [#:arr dom rng rest drest kws thn-eff els-eff + [#:arr dom rng rest drest kws (if (and (pair? drest) (eq? name (cdr drest))) (make-arr (append @@ -86,18 +87,12 @@ (sb rng) rimage #f - (for/list ([kw kws]) - (cons (car kw) (sb (cdr kw)))) - (map (lambda (e) (sub-eff sb e)) thn-eff) - (map (lambda (e) (sub-eff sb e)) els-eff)) + (map sb kws)) (make-arr (map sb dom) (sb rng) (and rest (sb rest)) (and drest (cons (sb (car drest)) (cdr drest))) - (for/list ([kw kws]) - (cons (car kw) (sb (cdr kw)))) - (map (lambda (e) (sub-eff sb e)) thn-eff) - (map (lambda (e) (sub-eff sb e)) els-eff)))]) + (map sb kws)))]) target)) ;; implements sd from the formalism @@ -105,7 +100,8 @@ (define (substitute-dotted image image-bound name target) (define (sb t) (substitute-dotted image image-bound name t)) (if (hash-ref (free-vars* target) name #f) - (type-case sb target + (type-case (#:Type sb #:LatentFilter (sub-lf sb)) + target [#:ValuesDots types dty dbound (make-ValuesDots (map sb types) (sb dty) @@ -114,17 +110,14 @@ (if (eq? name* name) image target)] - [#:arr dom rng rest drest kws thn-eff els-eff + [#:arr dom rng rest drest kws (make-arr (map sb dom) (sb rng) (and rest (sb rest)) (and drest (cons (sb (car drest)) (if (eq? name (cdr drest)) image-bound (cdr drest)))) - (for/list ([kw kws]) - (cons (car kw) (sb (cdr kw)))) - (map (lambda (e) (sub-eff sb e)) thn-eff) - (map (lambda (e) (sub-eff sb e)) els-eff))]) + (map sb kws))]) target)) ;; substitute many variables @@ -173,21 +166,33 @@ ;; this structure represents the result of typechecking an expression -(define-struct tc-result (t thn els) #:transparent) - -(define-match-expander tc-result: - (syntax-parser - [(_ pt) #'(struct tc-result (pt _ _))] - [(_ pt pe1 pe2) #'(struct tc-result (pt pe1 pe2))])) +(d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent) ;; convenience function for returning the result of typechecking an expression (define ret - (case-lambda [(t) (make-tc-result t (list) (list))] - [(t thn els) (make-tc-result t thn els)])) + (case-lambda [(t) + (if (Type? t) + (list (make-tc-result t (make-FilterSet null null) (make-Empty))) + (for/list ([i t]) + (make-tc-result i (make-FilterSet null null) (make-Empty))))] + [(t f) (error 'ret "two arguments not supported")] + [(t f o) + (if (and (list? t) (list? f) (list? o)) + (map make-tc-result t f o) + (list (make-tc-result t f o)))])) (p/c - [ret (case-> (-> Type? tc-result?) - (-> Type? (listof Effect?) (listof Effect?) tc-result?))]) + [ret + (->d ([t (or/c Type/c (listof Type/c))]) + ([f (if (list? t) + (listof FilterSet?) + FilterSet?)] + [o (if (or (list? f) (FilterSet? f)) + (if (list? t) + (listof Object?) + Object?) + (lambda (e) (eq? e f)))]) + [_ (listof tc-result?)])]) (define (subst v t e) (substitute t v e)) From 0343ae06f39e5b7d93a44072e505e354a7666bc1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 21 Feb 2009 23:55:32 +0000 Subject: [PATCH 020/156] Remove macro-debugger require. Use `this-syntax' More contract renamers Finish type-abbrev.ss svn: r13785 --- collects/typed-scheme/private/type-abbrev.ss | 261 +++++++++---------- collects/typed-scheme/rep/interning.ss | 2 +- collects/typed-scheme/rep/rep-utils.ss | 15 +- collects/typed-scheme/utils/utils.ss | 19 +- 4 files changed, 147 insertions(+), 150 deletions(-) diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 85dd5283c6..1770757248 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -2,113 +2,66 @@ (require "../utils/utils.ss") -(require (rep type-rep effect-rep) +(require (rep type-rep object-rep filter-rep printer) (utils tc-utils) scheme/list - scheme/match - "type-effect-printer.ss" + scheme/match scheme/promise + (prefix-in c: scheme/contract) (for-syntax scheme/base stxclass) (for-template scheme/base scheme/contract scheme/tcp)) (provide (all-defined-out)) -(define top-func (make-Function (list (make-top-arr)))) +;; convenient constructors -(define (-vet id) (make-Var-True-Effect id)) -(define (-vef id) (make-Var-False-Effect id)) +(define -values make-Values) +(define -pair make-Pair) +(define -struct make-Struct) +(define -val make-Value) +(define -lst make-Listof) +(define -Param make-Param) +(define -box make-Box) +(define -vec make-Vector) +(define -LFS make-LFilterSet) -(define -rem make-Remove-Effect) -(define -rest make-Restrict-Effect) +(define-syntax *Un + (syntax-rules () + [(_ . args) (make-Union (list . args))])) -(define (var->type-eff eff) - (match eff - [(Var-True-Effect: v) (make-Remove-Effect (make-Value #f) v)] - [(Var-False-Effect: v) (make-Restrict-Effect (make-Value #f) v)] - [_ eff])) -(define ((add-var v) eff) - (match eff - [(Latent-Var-True-Effect:) (-vet v)] - [(Latent-Var-False-Effect:) (-vef v)] - [(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)] - [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] - [(True-Effect:) eff] - [(False-Effect:) eff] - [_ (int-err "can't add var ~a to effect ~a" v eff)])) +(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) -(define-syntax (-> stx) - (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [(_ dom ... rng : eff1 eff2) - #'(->* (list dom ...) rng : eff1 eff2)] - [(_ dom ... rng : eff1 eff2) - #'(->* (list dom ...) rng : eff1 eff2)] - [(_ dom ... rng) - #'(->* (list dom ...) rng)])) +(define (-lst* #:tail [tail (-val null)] . args) + (if (null? args) + tail + (-pair (car args) (apply -lst* #:tail tail (cdr args))))) -(define-syntax ->* - (syntax-rules (:) - [(_ dom rng) - (make-Function (list (make-arr* dom rng)))] - [(_ dom rst rng) - (make-Function (list (make-arr* dom rng rst)))] - [(_ dom rng : eff1 eff2) - (make-Function (list (make-arr* dom rng #f eff1 eff2)))] - [(_ dom rst rng : eff1 eff2) - (make-Function (list (make-arr* dom rng rst eff1 eff2)))])) -(define-syntax ->... - (syntax-rules (:) - [(_ dom rng) - (->* dom rng)] - [(_ dom (dty dbound) rng) - (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) (list) (list))))] - [(_ dom rng : eff1 eff2) - (->* dom rng : eff1 eff2)] - [(_ dom (dty dbound) rng : eff1 eff2) - (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) eff1 eff2)))])) -(define-syntax cl-> - (syntax-rules (:) - [(_ [(dom ...) rng] ...) - (make-Function (list (make-arr* (list dom ...) rng) ...))] - [(_ [(dom ...) rng : eff1 eff2] ...) - (make-Function (list (make-arr* (list dom ...) rng #f eff1 eff2) ...))] - [(_ [(dom ...) rng rst : eff1 eff2] ...) - (make-Function (list (make-arr* (list dom ...) rng rst eff1 eff2) ...))])) -(define (cl->* . args) - (define (funty-arities f) - (match f - [(Function: as) as])) - (make-Function (apply append (map funty-arities args)))) +(define (-Tuple l) + (foldr -pair (-val '()) l)) -(define-syntax (->key stx) - (syntax-parse stx - [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) - #'(make-Function - (list - (make-arr* (list ty ...) - rng - #f - #f - (list (make-Keyword 'k kty opt) ...) - null - null)))])) +(define (untuple t) + (match t + [(Value: '()) null] + [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] + [else #f])] + [_ #f])) -(define make-arr* - (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] - [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] - [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] - [(dom rng rest drest kws eff1 eff2) - (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword* (Type/c) (LFilterSet? LatentObject?) Result?) + (make-Result t f o)) + +;; basic types (define make-promise-ty (let ([s (string->uninterned-symbol "Promise")]) (lambda (t) (make-Struct s #f (list t) #f #f #'promise? values)))) +(define -Listof (-poly (list-elem) (make-Listof list-elem))) + + (define N (make-Base 'Number #'number?)) (define -Integer (make-Base 'Integer #'exact-integer?)) (define B (make-Base 'Boolean #'boolean?)) @@ -139,6 +92,35 @@ (define -Nat -Integer) +(define Any-Syntax + (-mu x + (-Syntax (*Un + N + B + Sym + -String + -Keyword + (-mu y (*Un (-val '()) (-pair x (*Un x y)))) + (make-Vector x) + (make-Box x))))) + +(define Ident (-Syntax Sym)) + +(define -Sexp (-mu x (*Un (-val null) N B Sym -String (-pair x x)))) +(define -Port (*Un -Output-Port -Input-Port)) + +(define -Pathlike (*Un -String -Path)) +(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same))) +(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String)) +(define -Byte N) + +(define -no-lfilter (make-LFilterSet null null)) +(define -no-filter (make-FilterSet null null)) +(define -no-lobj (make-LEmpty)) +(define -no-obj (make-Empty)) + +;; convenient syntax + (define-syntax -v (syntax-rules () [(_ x) (make-F 'x)])) @@ -162,71 +144,76 @@ (let ([var (-v var)]) (make-Mu 'var ty))])) +;; function type constructors -(define -values make-Values) +(define top-func (make-Function (list (make-top-arr)))) -(define-syntax *Un - (syntax-rules () - [(_ . args) (make-Union (list . args))])) +(d/c (make-arr* dom rng + #:rest [rest #f] #:drest [drest #f] #:kws [kws null] + #:filters [filters -no-lfilter] #:object [obj -no-lobj]) + (c:->* ((listof Type/c) Type/c) + (#:rest Type/c + #:drest (cons/c symbol? Type/c) + #:kws (listof Keyword?) + #:filters LFilterSet? + #:object LatentObject?) + arr?) + (make-arr dom (-result rng filters obj) rest drest (sort #:key Keyword-kw kws keyword* + (syntax-rules (:) + [(_ dom rng) + (make-Function (list (make-arr* dom rng)))] + [(_ dom rst rng) + (make-Function (list (make-arr* dom rng #:rest rst)))] + [(_ dom rng : filters) + (make-Function (list (make-arr* dom rng #f #:filters filters)))] + [(_ dom rst rng : filters) + (make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))])) -(define -pair make-Pair) +(define-syntax (-> stx) + (syntax-parse stx + #:literals (:) + [(_ dom ... rng : filters) + #'(->* (list dom ...) rng : filters)] + [(_ dom ... rng : filters) + #'(->* (list dom ...) rng : filters)] + [(_ dom ... rng) + #'(->* (list dom ...) rng)])) -(define -struct make-Struct) -(define -val make-Value) +(define-syntax ->... + (syntax-rules (:) + [(_ dom rng) + (->* dom rng)] + [(_ dom (dty dbound) rng) + (make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound))))] + [(_ dom rng : filters) + (->* dom rng : filters)] + [(_ dom (dty dbound) rng : filters) + (make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))])) -(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) -(define -Listof (-poly (list-elem) (make-Listof list-elem))) +(define (cl->* . args) + (define (funty-arities f) + (match f + [(Function: as) as])) + (make-Function (apply append (map funty-arities args)))) -(define -lst make-Listof) -(define -Sexp (-mu x (*Un N B Sym -String (-val null) (-pair x x)))) -(define -Port (*Un -Output-Port -Input-Port)) +(define-syntax (->key stx) + (syntax-parse stx + [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) + #'(make-Function + (list + (make-arr* (list ty ...) + rng + #:kws (list (make-Keyword 'k kty opt) ...))))])) -(define (-lst* #:tail [tail (-val null)] . args) - (if (null? args) - tail - (-pair (car args) (apply -lst* #:tail tail (cdr args))))) +(define (make-arr-dots dom rng dty dbound) + (make-arr* dom rng #:drest (cons dty dbound))) -#;(define NE (-mu x (Un N (make-Listof x)))) -(define -NE (-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null))))))) - -(define -Param make-Param) - (define make-pred-ty (case-lambda [(in out t) - (->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))] + (->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))] [(t) (make-pred-ty (list Univ) B t)])) -(define -Pathlike (*Un -String -Path)) -(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same))) -(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String)) -(define -Byte N) - -(define (-Tuple l) - (foldr -pair (-val '()) l)) - -(define (untuple t) - (match t - [(Value: '()) null] - [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] - [else #f])] - [_ #f])) - -(define -box make-Box) -(define -vec make-Vector) - -(define Any-Syntax ;(-Syntax Univ) - (-mu x - (-Syntax (*Un - N - B - Sym - -String - -Keyword - (-mu y (*Un (-val '()) (-pair x (*Un x y)))) - (make-Vector x) - (make-Box x))))) - -(define Ident (-Syntax Sym)) \ No newline at end of file diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index 68b393b8d8..83551c46b2 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -1,7 +1,7 @@ #lang scheme/base (require syntax/boundmap (for-syntax scheme/base stxclass) - macro-debugger/stepper) + #;macro-debugger/stepper) (provide defintern hash-id) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ebad2a3324..3de0e278e8 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -170,16 +170,16 @@ (k:keyword #:matcher mtch pats ... e:expr) #:with kw #'k.datum #:with val (list #'mtch - (syntax #;#;/loc (current-syntax-context) (pats ...)) + (syntax/loc this-syntax (pats ...)) (lambda () #'e) - #'here #;(current-syntax-context))) + this-syntax)) (pattern (k:keyword pats ... e:expr) #:with kw (syntax-e #'k) #:with val (list (mk-matcher #'kw) - (syntax #;#;/loc (current-syntax-context) (pats ...)) + (syntax/loc this-syntax (pats ...)) (lambda () #'e) - #'here #;(current-syntax-context)))) + this-syntax))) (define (gen-clause k v) (match v [(list match-ex pats body-f src) @@ -210,12 +210,7 @@ (for/list ([rec-id rec-ids] [k kws]) #`[#,rec-id #,(hash-ref (attribute recs.mapping) k - #'values - #; - (lambda () - (error (format - "failed to find key ~a in table ~a" - k (attribute recs.mapping)))))])]) + #'values)])]) #`(let (let-clauses ... [#,fold-target ty]) ;; then generate the fold diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index fdf2202fc0..b8e5f21f9b 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -164,7 +164,7 @@ [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #t) +(define-for-syntax printing? #f) (define-syntax-rule (defprinter t ...) (begin @@ -241,7 +241,7 @@ (append t (build-list (- (length s) (length t)) (lambda _ extra)))) (define-for-syntax enable-contracts? #t) -(provide (for-syntax enable-contracts?) p/c w/c cnt) +(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c) (define-syntax p/c (if enable-contracts? @@ -265,6 +265,21 @@ [(_ name specs . body) #'(begin . body)])))) +(define-syntax d/c + (if enable-contracts? + (make-rename-transformer #'define/contract) + (lambda (stx) + (syntax-parse stx + [(_ head cnt . body) + #'(define head . body)])))) + +(define-syntax d-s/c + (if enable-contracts? + (make-rename-transformer #'define-struct/contract) + (syntax-rules () + [(_ hd ([i c] ...) . opts) + (define-struct hd (i ...) . opts)]))) + (define-signature-form (cnt stx) (syntax-case stx () [(_ nm cnt) From 7020ff07a5e71f9b57bafbf7f912200b4526d948 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 22 Feb 2009 00:03:41 +0000 Subject: [PATCH 021/156] finished resolve-type svn: r13786 --- collects/typed-scheme/private/resolve-type.ss | 47 ------------------- 1 file changed, 47 deletions(-) diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index 28ec18a488..c7faacdcd0 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -31,50 +31,3 @@ [(Mu: _ _) (unfold t)] [(App: r r* s) (resolve-app r r* s)] [(Name: _) (resolve-name t)])) - -#| - -(define (resolve-tc-result tcr) - (match tcr - [(tc-result: t e1s e2s) - (ret (resolve-type t) (map resolve-effect e1s) (map resolve-effect e2s))])) - -(define (resolve-effect* e) - (effect-case resolve-type resolve-effect e)) - - - -(define (resolve-type* t) - (define (int t) - (type-case resolve-type t - [#:Name stx (lookup-type-name stx)] - [#:Poly #:matcher Poly: names body (make-Poly names (resolve-type body))] - [#:Mu #:matcher Mu: name body (make-Mu name (resolve-type body))] - [#:App rator rands stx - (let ([rator (resolve-type rator)] - [rands (map resolve-type rands)]) - (unless (Poly? rator) - (tc-error/stx stx "Cannot apply non-polymorphic type: ~a, arguments were: ~a" rator rands)) - (instantiate-poly rator rands))])) - (let loop ([t (int t)]) - (if (or (Name? t) (App? t)) - (loop (resolve-type t)) - t))) - -(define table (make-hash-table)) - -(define (resolve-type t) - (hash-table-get table t - (lambda () (let ([v (resolve-type* t)]) - (hash-table-put! table t v) - v)))) - -(define (resolve-effect t) - (hash-table-get table t - (lambda () (let ([v (resolve-effect* t)]) - (hash-table-put! table t v) - v)))) - -;(trace resolve-type) - -|# From a197c1b9613174d731ce8b1f5d564969cdc2aa98 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Feb 2009 02:53:39 +0000 Subject: [PATCH 022/156] new directory svn: r13796 --- collects/typed-scheme/{private => types}/type-abbrev.ss | 0 collects/typed-scheme/{private => types}/type-utils.ss | 0 collects/typed-scheme/utils/utils.ss | 1 + 3 files changed, 1 insertion(+) rename collects/typed-scheme/{private => types}/type-abbrev.ss (100%) rename collects/typed-scheme/{private => types}/type-utils.ss (100%) diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/types/type-abbrev.ss similarity index 100% rename from collects/typed-scheme/private/type-abbrev.ss rename to collects/typed-scheme/types/type-abbrev.ss diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/types/type-utils.ss similarity index 100% rename from collects/typed-scheme/private/type-utils.ss rename to collects/typed-scheme/types/type-utils.ss diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index b8e5f21f9b..edc3304a94 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -50,6 +50,7 @@ (define-requirer utils) (define-requirer env) (define-requirer private) +(define-requirer types) (define-sequence-syntax in-syntax (lambda () #'syntax->list) From af3449cf56500be4eced680e73f77af51e10b8ab Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Feb 2009 03:02:00 +0000 Subject: [PATCH 023/156] more file moving svn: r13797 --- .../{private/type-comparison.ss => types/comparison.ss} | 0 collects/typed-scheme/{rep => types}/printer.ss | 0 .../typed-scheme/{private/resolve-type.ss => types/resolve.ss} | 0 collects/typed-scheme/types/type-abbrev.ss | 3 ++- 4 files changed, 2 insertions(+), 1 deletion(-) rename collects/typed-scheme/{private/type-comparison.ss => types/comparison.ss} (100%) rename collects/typed-scheme/{rep => types}/printer.ss (100%) rename collects/typed-scheme/{private/resolve-type.ss => types/resolve.ss} (100%) diff --git a/collects/typed-scheme/private/type-comparison.ss b/collects/typed-scheme/types/comparison.ss similarity index 100% rename from collects/typed-scheme/private/type-comparison.ss rename to collects/typed-scheme/types/comparison.ss diff --git a/collects/typed-scheme/rep/printer.ss b/collects/typed-scheme/types/printer.ss similarity index 100% rename from collects/typed-scheme/rep/printer.ss rename to collects/typed-scheme/types/printer.ss diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/types/resolve.ss similarity index 100% rename from collects/typed-scheme/private/resolve-type.ss rename to collects/typed-scheme/types/resolve.ss diff --git a/collects/typed-scheme/types/type-abbrev.ss b/collects/typed-scheme/types/type-abbrev.ss index 1770757248..632fc2659b 100644 --- a/collects/typed-scheme/types/type-abbrev.ss +++ b/collects/typed-scheme/types/type-abbrev.ss @@ -2,7 +2,8 @@ (require "../utils/utils.ss") -(require (rep type-rep object-rep filter-rep printer) +(require (rep type-rep object-rep filter-rep) + "printer.ss" (utils tc-utils) scheme/list scheme/match From ea86a63e8033ec8e11cee59e4463acc55586a044 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 24 Feb 2009 16:23:16 +0000 Subject: [PATCH 024/156] move subtype.ss svn: r13815 --- .../{private => types}/subtype.ss | 62 +++++++++---------- 1 file changed, 31 insertions(+), 31 deletions(-) rename collects/typed-scheme/{private => types}/subtype.ss (90%) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/types/subtype.ss similarity index 90% rename from collects/typed-scheme/private/subtype.ss rename to collects/typed-scheme/types/subtype.ss index 0c2ffdb722..cebf102d4e 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -1,16 +1,17 @@ #lang scheme/base (require "../utils/utils.ss") -(require (except-in (rep type-rep effect-rep rep-utils) sub-eff) +(require (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) "type-utils.ss" - "type-comparison.ss" - "resolve-type.ss" + "comparison.ss" + "resolve.ss" "type-abbrev.ss" (env type-name-env) (only-in (infer infer-dummy) unify) scheme/match - mzlib/trace) + mzlib/trace + (for-syntax scheme/base stxclass)) @@ -18,21 +19,14 @@ ;; s,t both types (define-struct (exn:subtype exn:fail) (s t)) -#; -(define-values (fail-sym exn:subtype?) - (let ([sym (gensym)]) - (values sym (lambda (s) (eq? s sym))))) ;; inference failure - masked before it gets to the user program (define-syntax fail! (syntax-rules () - [(_ s t) #;(raise fail-sym) - (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t)) - #;(error "inference failed" s t)])) - + [(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))])) ;; data structures for remembering things on recursive calls -(define (empty-set) '()) +(define (empty-set) '()) (define current-seen (make-parameter (empty-set))) @@ -94,19 +88,20 @@ (define (supertype-of-one/arr A s ts) (ormap (lambda (e) (arr-subtype*/no-fail A e s)) ts)) -(define (sub-eff e1 e2) - (match* (e1 e2) - [(e e) #t] - [((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: t*)) - (and (subtype t t*) - (subtype t* t))] - [((Latent-Remove-Effect: t) (Latent-Remove-Effect: t*)) - (and (subtype t t*) - (subtype t* t))] - [(_ _) #f])) - -;(trace sub-eff) - +(define-syntax (subtype-seq stx) + (define-syntax-class sub* + (pattern e:expr)) + (syntax-parse stx + [(_ init (s1:sub* . args1) (s:sub* . args) ...) + (with-syntax ([(A* ... A-last) (generate-temporaries #'(s1 s ...))]) + (with-syntax ([(clauses ...) + (for/list ([s (syntax->list #'(s1 s ...))] + [args (syntax->list #'(args1 args ...))] + [A (syntax->list #'(init A* ...))] + [A-next (syntax->list #'(A* ... A-last))]) + #`[A-next (#,s #,A . #,args)])]) + #'(let* (clauses ...) + A-last)))])) ;; simple co/contra-variance for -> (define (arr-subtype*/no-fail A0 s t) @@ -115,11 +110,16 @@ (match (list s t) ;; top for functions is above everything [(list _ (top-arr:)) A0] - [(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) - (arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff)) - (let* ([A1 (subtypes* A0 t1 s1)] - [A2 (subtypes* A1 t-kw-ty s-kw-ty)]) - (subtype* A1 s2 t2))] + [(list (arr: s1 s2 #f #f s-kws) + (arr: t1 t2 #f #f t-kws)) + ;; optional keywords are subtypes of required keywords + (unless (for/and ([s-r s-req] [t-r t-req]) + (or (eq? s-r t-r) (not s-r))) + (fail! s t)) + (subtype-seq A0 + (subtypes* t1 s1) + (kw-subtypes* t-kws s-kws) + (subtype* s2 t2))] [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*)) (unless From d951ea57c2f2313170efb303c0bdb902cdb70292 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 27 Feb 2009 00:14:02 +0000 Subject: [PATCH 025/156] unbreak these svn: r13862 --- collects/drscheme/private/auto-language.ss | 6 +++--- collects/drscheme/private/insert-large-letters.ss | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss index f0bf4a4f4a..3417770099 100644 --- a/collects/drscheme/private/auto-language.ss +++ b/collects/drscheme/private/auto-language.ss @@ -1,7 +1,7 @@ -#lang typed-scheme +#lang typed-scheme/no-check -(require typed/framework/framework - typed/mred/mred +(require framework/framework ;typed/framework/framework + mred ;typed/mred/mred scheme/class) (provide pick-new-language looks-like-module?) diff --git a/collects/drscheme/private/insert-large-letters.ss b/collects/drscheme/private/insert-large-letters.ss index ea55ecfbfb..37493b4973 100644 --- a/collects/drscheme/private/insert-large-letters.ss +++ b/collects/drscheme/private/insert-large-letters.ss @@ -1,7 +1,7 @@ -#lang typed-scheme +#lang typed-scheme/no-check -(require typed/mred/mred - typed/framework/framework +(require #;typed/ mred/mred + #;typed/ framework/framework scheme/class string-constants/string-constant) From eaf15594c084b398e8bbc4449fb698257f088689 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 01:24:06 +0000 Subject: [PATCH 026/156] subtype.ss now compiles svn: r13901 --- collects/typed-scheme/env/type-name-env.ss | 2 +- collects/typed-scheme/types/subtype.ss | 52 +++++++++++----------- collects/typed-scheme/types/type-abbrev.ss | 4 +- collects/typed-scheme/utils/utils.ss | 2 +- 4 files changed, 29 insertions(+), 31 deletions(-) diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index d6773f0ea5..314f61735b 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -4,7 +4,7 @@ (require syntax/boundmap mzlib/trace (utils tc-utils) - (private type-utils)) + (types type-utils)) (provide register-type-name lookup-type-name diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index cebf102d4e..1e7cd1519b 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -99,10 +99,30 @@ [args (syntax->list #'(args1 args ...))] [A (syntax->list #'(init A* ...))] [A-next (syntax->list #'(A* ... A-last))]) - #`[A-next (#,s #,A . #,args)])]) + #`[#,A-next (#,s #,A . #,args)])]) #'(let* (clauses ...) A-last)))])) +(define (kw-subtypes* A0 t-kws s-kws) + (let loop ([A A0] [t t-kws] [s s-kws]) + (match* (t s) + [((list (Keyword: kt tt rt) rest-t) (list (Keyword: ks ts rs) rest-s)) + (cond [(eq? kt ks) + (if + ;; if s is optional, t must be as well + (or rs (not rt)) + (loop (subtype A tt ts) rest-t rest-s) + (fail! t s))] + ;; extra keywords in t are ok + ;; we just ignore them + [(keyword (define (arr-subtype*/no-fail A0 s t) (with-handlers @@ -112,33 +132,11 @@ [(list _ (top-arr:)) A0] [(list (arr: s1 s2 #f #f s-kws) (arr: t1 t2 #f #f t-kws)) - ;; optional keywords are subtypes of required keywords - (unless (for/and ([s-r s-req] [t-r t-req]) - (or (eq? s-r t-r) (not s-r))) - (fail! s t)) (subtype-seq A0 - (subtypes* t1 s1) - (kw-subtypes* t-kws s-kws) - (subtype* s2 t2))] - [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) - (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*)) - (unless - (or (and (null? thn-eff*) (null? els-eff*)) - (and (effects-equal? thn-eff thn-eff*) - (effects-equal? els-eff els-eff*)) - (and - (= (length thn-eff) (length thn-eff*)) - (= (length els-eff) (length els-eff*)) - (andmap sub-eff thn-eff thn-eff*) - (andmap sub-eff els-eff els-eff*))) - (fail! s t)) - ;; either the effects have to be the same, or the supertype can't have effects - (let* ([A2 (subtypes*/varargs A0 t1 s1 s3)] - [A3 (subtypes* A2 t-kw-ty s-kw-ty)]) - (if (not t3) - (subtype* A3 s2 t2) - (let ([A1 (subtype* A3 t3 s3)]) - (subtype* A1 s2 t2))))] + (subtypes* t1 s1) + (kw-subtypes* t-kws s-kws) + (subtype* s2 t2))] + ;; FIXME - handle varargs [else (fail! s t)]))) diff --git a/collects/typed-scheme/types/type-abbrev.ss b/collects/typed-scheme/types/type-abbrev.ss index 632fc2659b..de6aee2898 100644 --- a/collects/typed-scheme/types/type-abbrev.ss +++ b/collects/typed-scheme/types/type-abbrev.ss @@ -12,7 +12,8 @@ (for-syntax scheme/base stxclass) (for-template scheme/base scheme/contract scheme/tcp)) -(provide (all-defined-out)) +(provide (all-defined-out) + (rename-out [make-Listof -lst])) ;; convenient constructors @@ -20,7 +21,6 @@ (define -pair make-Pair) (define -struct make-Struct) (define -val make-Value) -(define -lst make-Listof) (define -Param make-Param) (define -box make-Box) (define -vec make-Vector) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index edc3304a94..a0bb5f1a1b 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -20,7 +20,7 @@ debug in-syntax ;; require macros - rep utils typecheck infer env private) + rep utils typecheck infer env private types) (define-syntax (define-requirer stx) (syntax-parse stx From 089c5363e7e1990667c908864e0086b443637b33 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 19:31:30 +0000 Subject: [PATCH 027/156] stamp shows branch svn: r13919 --- collects/repos-time-stamp/stamp.ss | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 2f7a99d275..8aab08c2e7 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1,10 @@ -#lang scheme/base (provide stamp) (define stamp "2mar2009") +#lang scheme/base +(provide stamp) +(define stamp + (string-append "2mar2009 " + (let ([s "$URL$"]) + (substring + s 0 + (- (string-length s) + (string-length + "collects/repos-time-stamp/stamp.ss")))))) From 4cf824cbb06d1fbdb579d0611176f1a49f236511 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 19:33:09 +0000 Subject: [PATCH 028/156] fix substring svn: r13920 --- collects/repos-time-stamp/stamp.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8aab08c2e7..7341e33be3 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -4,7 +4,7 @@ (string-append "2mar2009 " (let ([s "$URL$"]) (substring - s 0 + s 6 (- (string-length s) (string-length - "collects/repos-time-stamp/stamp.ss")))))) + "collects/repos-time-stamp/stamp.ss $")))))) From 4615d7573e2a3c6313bd35913dc4267db6427723 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 20:35:18 +0000 Subject: [PATCH 029/156] subst-tests now pass svn: r13923 --- .../unit-tests/planet-requires.ss | 21 ++----------------- .../typed-scheme/unit-tests/subst-tests.ss | 4 ++-- .../typed-scheme/unit-tests/test-utils.ss | 13 +++++------- 3 files changed, 9 insertions(+), 29 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/planet-requires.ss b/collects/tests/typed-scheme/unit-tests/planet-requires.ss index 038b3fb17e..96b80f4ee2 100644 --- a/collects/tests/typed-scheme/unit-tests/planet-requires.ss +++ b/collects/tests/typed-scheme/unit-tests/planet-requires.ss @@ -9,28 +9,11 @@ (define-syntax define-module (syntax-rules () - [(_ nm spec ...) - + [(_ nm spec ...) (define-syntax nm (make-require-transformer (lambda (stx) - (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))) - #; - (define-require-syntax nm - (lambda (stx) - (syntax-case stx () - [(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))])) - -#; -(define-syntax define-module - (lambda (stx) - (syntax-case stx () - [(_ nm spec ...) - (syntax/loc stx - (define-syntax nm - (make-require-transformer - (lambda (stx) - (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))))]))) + (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...)))))])) (define-syntax planet/multiple (make-require-transformer diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 91d42cd426..6ac1db6fb3 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -2,14 +2,14 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (private type-utils type-effect-convenience) + (types type-utils type-abbrev) (schemeunit)) (define-syntax-rule (s img var tgt result) (test-eq? "test" (substitute img 'var tgt) result)) (define-syntax-rule (s... imgs var tgt result) - (test-eq? "test" (substitute-dots (list . imgs) 'var tgt) result)) + (test-eq? "test" (substitute-dots (list . imgs) #f 'var tgt) result)) (define (subst-tests) (test-suite "Tests for substitution" diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index 9c40943939..c520cebdc0 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -8,9 +8,10 @@ (for-syntax scheme/base)) -(require (private type-comparison type-utils) +(require (types comparison type-utils) (schemeunit)) -(provide private typecheck (rename-out [infer r:infer]) utils env rep) + +(provide private typecheck (rename-out [infer r:infer]) utils env rep types) (define (mk-suite ts) (match (map (lambda (f) (f)) ts) @@ -38,13 +39,9 @@ (values (lambda () (run tmps ...)) (lambda () (run/gui tmps ...))))))])) -;; FIXME - check that effects are equal +;; FIXME - do something more intelligent (define (tc-result-equal/test? a b) - (match* (a b) - [((tc-result: t1 thn1 els1) (tc-result: t2 thn2 els2)) - (and (type-equal? t1 t2) - (= (length thn1) (length thn2)) - (= (length els1) (length els2)))])) + (equal? a b)) (define-syntax (check-type-equal? stx) (syntax-case stx () From 6271f648c6c3b4b0b7220497f037a2783a5a2ce0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 21:53:02 +0000 Subject: [PATCH 030/156] fix some requires svn: r13925 --- collects/tests/typed-scheme/unit-tests/subtype-tests.ss | 2 +- collects/tests/typed-scheme/unit-tests/type-equal-tests.ss | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 9c3c7d34e7..719f108bf5 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss") -(require (private subtype type-effect-convenience union) +(require (types subtype type-effect-convenience union) (rep type-rep) (env init-envs type-environments) (r:infer infer infer-dummy) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 30462350d1..c6064d45a4 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (private type-comparison type-effect-convenience union subtype) + (types comparison type-abbrev) (schemeunit)) (provide type-equal-tests) From 0eda7878d5b7e7b9cbaac8db4794cc5cd94ecfdd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 21:53:26 +0000 Subject: [PATCH 031/156] fix make-arr svn: r13926 --- collects/typed-scheme/types/type-abbrev.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/types/type-abbrev.ss b/collects/typed-scheme/types/type-abbrev.ss index de6aee2898..432f4e1db2 100644 --- a/collects/typed-scheme/types/type-abbrev.ss +++ b/collects/typed-scheme/types/type-abbrev.ss @@ -154,12 +154,12 @@ #:filters [filters -no-lfilter] #:object [obj -no-lobj]) (c:->* ((listof Type/c) Type/c) (#:rest Type/c - #:drest (cons/c symbol? Type/c) + #:drest (cons/c Type/c symbol?) #:kws (listof Keyword?) #:filters LFilterSet? #:object LatentObject?) arr?) - (make-arr dom (-result rng filters obj) rest drest (sort #:key Keyword-kw kws keyword* (syntax-rules (:) From 20628199f58d659b7a62f13b56a4b7e8bb8c2196 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 21:55:11 +0000 Subject: [PATCH 032/156] union.ss compiles svn: r13927 --- collects/typed-scheme/private/union.ss | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/collects/typed-scheme/private/union.ss b/collects/typed-scheme/private/union.ss index 816dbe7eb9..cf48cac6e3 100644 --- a/collects/typed-scheme/private/union.ss +++ b/collects/typed-scheme/private/union.ss @@ -4,11 +4,7 @@ (require (rep type-rep rep-utils) (utils tc-utils) - "type-utils.ss" - "subtype.ss" - "type-abbrev.ss" - "type-effect-printer.ss" - "type-comparison.ss" + (types type-utils subtype type-abbrev printer comparison) scheme/match mzlib/trace) (provide Un #;(rename *Un Un)) @@ -49,20 +45,9 @@ (cond [(null? types) (make-union* null)] [(null? (cdr types)) (car types)] - [(ormap Values? types) - (if (andmap Values? types) - (make-Values (apply map Un (map Values-types types))) - (int-err "Un: should not take the union of multiple values with some other type: ~a" types))] - [else (make-union* #;(remove-subtypes types) (foldr union2 '() (remove-subtypes types)))]))])) - -#;(defintern (Un-intern args) (lambda (_ args) (apply Un args)) args) - -#;(define (*Un . args) (Un-intern args)) - -;(trace Un) + [else (make-union* (foldr union2 '() (remove-subtypes types)))]))])) (define (u-maker args) (apply Un args)) -;(trace u-maker) (set-union-maker! u-maker) From bbfb99bc77cdb16e9178ad45d0d1440f6fc91f92 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 22:26:15 +0000 Subject: [PATCH 033/156] More file movement svn: r13929 --- collects/typed-scheme/env/type-name-env.ss | 2 +- .../typed-scheme/types/{type-abbrev.ss => abbrev.ss} | 0 collects/typed-scheme/types/comparison.ss | 2 +- .../convenience.ss} | 12 ++++-------- collects/typed-scheme/types/resolve.ss | 6 ++++-- collects/typed-scheme/types/subtype.ss | 7 +------ collects/typed-scheme/{private => types}/union.ss | 5 ++--- .../typed-scheme/types/{type-utils.ss => utils.ss} | 0 8 files changed, 13 insertions(+), 21 deletions(-) rename collects/typed-scheme/types/{type-abbrev.ss => abbrev.ss} (100%) rename collects/typed-scheme/{private/type-effect-convenience.ss => types/convenience.ss} (88%) rename collects/typed-scheme/{private => types}/union.ss (91%) rename collects/typed-scheme/types/{type-utils.ss => utils.ss} (100%) diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index 314f61735b..374a2368be 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -4,7 +4,7 @@ (require syntax/boundmap mzlib/trace (utils tc-utils) - (types type-utils)) + (types utils)) (provide register-type-name lookup-type-name diff --git a/collects/typed-scheme/types/type-abbrev.ss b/collects/typed-scheme/types/abbrev.ss similarity index 100% rename from collects/typed-scheme/types/type-abbrev.ss rename to collects/typed-scheme/types/abbrev.ss diff --git a/collects/typed-scheme/types/comparison.ss b/collects/typed-scheme/types/comparison.ss index dbc70e5f46..0ca075439e 100644 --- a/collects/typed-scheme/types/comparison.ss +++ b/collects/typed-scheme/types/comparison.ss @@ -1,4 +1,4 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep) "type-utils.ss") +(require (rep type-rep) (types utils)) (provide type-equal? tc-result-equal? type Date: Tue, 3 Mar 2009 22:30:08 +0000 Subject: [PATCH 034/156] convenience now compiles svn: r13930 --- collects/typed-scheme/types/convenience.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index bdf297865b..b7078647cd 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -1,10 +1,10 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep effect-rep) +(require (rep type-rep) (utils tc-utils) - (types comparison printer - union subtype type-utils type-abbrev) + "abbrev.ss" + (types comparison printer union subtype utils) scheme/list scheme/match scheme/promise @@ -13,7 +13,7 @@ (for-template scheme/base scheme/contract scheme/tcp)) (provide (all-defined-out) - (all-from-out (types type-abbrev)) + (all-from-out "abbrev.ss") ;; these should all eventually go away make-Name make-ValuesDots make-Function) From f05fcfcf13ccb0e8f57edc86191fdaa6fef4da91 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 22:45:57 +0000 Subject: [PATCH 035/156] all of types/ now compiles everything that doesn't use Un out of convenience.ss added -out form for requires svn: r13931 --- collects/typed-scheme/private/env-lang.ss | 14 ++--- collects/typed-scheme/types/abbrev.ss | 7 +++ collects/typed-scheme/types/convenience.ss | 36 +---------- collects/typed-scheme/utils/tc-utils.ss | 24 ++++++- collects/typed-scheme/utils/utils.ss | 73 +++++++++++++--------- 5 files changed, 80 insertions(+), 74 deletions(-) diff --git a/collects/typed-scheme/private/env-lang.ss b/collects/typed-scheme/private/env-lang.ss index c047e3a61d..bbbfd3bd6e 100644 --- a/collects/typed-scheme/private/env-lang.ss +++ b/collects/typed-scheme/private/env-lang.ss @@ -2,15 +2,14 @@ (require (rename-in "../utils/utils.ss" [infer r:infer])) -(require (for-syntax (private type-effect-convenience) +(require (for-syntax (utils tc-utils) (env init-envs) scheme/base (r:infer infer) (only-in (r:infer infer-dummy) infer-param) - (except-in (rep effect-rep type-rep) make-arr) - "type-effect-convenience.ss" - (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "union.ss")) + (except-in (rep object-rep filter-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]))) (define-syntax (#%module-begin stx) (syntax-case stx (require) @@ -33,6 +32,5 @@ require (all-from-out scheme/base) (for-syntax - (all-from-out scheme/base - "type-effect-convenience.ss" - "union.ss"))) + (types convenience union) + (all-from-out scheme/base))) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 432f4e1db2..19f8a47232 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -218,3 +218,10 @@ (->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))] [(t) (make-pred-ty (list Univ) B t)])) + +(define (opt-fn args opt-args result) + (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) + (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) + +(define-syntax-rule (->opt args ... [opt ...] res) + (opt-fn (list args ...) (list opt ...) res)) \ No newline at end of file diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index b7078647cd..702a4c0cde 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -10,7 +10,7 @@ scheme/promise (for-syntax stxclass) (for-syntax scheme/base) - (for-template scheme/base scheme/contract scheme/tcp)) + (for-template scheme/base)) (provide (all-defined-out) (all-from-out "abbrev.ss") @@ -24,31 +24,6 @@ (apply Un (map tc-result-t args))) -(define-syntax (make-env stx) - (syntax-case stx () - [(_ e ...) - #`(list - #,@(map (lambda (e) - (syntax-case e () - [(nm ty) - (identifier? #'nm) - #`(list #'nm ty)] - [(e ty extra-mods ...) - #'(let ([x (list (let ([new-ns - (let* ([ns (make-empty-namespace)]) - (namespace-attach-module (current-namespace) - 'scheme/base - ns) - ns)]) - (parameterize ([current-namespace new-ns]) - (namespace-require 'scheme/base) - (namespace-require 'extra-mods) ... - e)) - ty)]) - ;(display x) (newline) - x)])) - (syntax->list #'(e ...))))])) - ;; if t is of the form (Pair t* (Pair t* ... (Listof t*))) ;; return t* ;; otherwise, return t @@ -67,14 +42,5 @@ [_ (exit t)])))) - -(define (opt-fn args opt-args result) - (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) - (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) - -(define-syntax-rule (->opt args ... [opt ...] res) - (opt-fn (list args ...) (list opt ...) res)) - - ;; DO NOT USE if t contains #f (define (-opt t) (Un (-val #f) t)) \ No newline at end of file diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 75e5ac4740..53958415a1 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -1,6 +1,6 @@ #lang scheme/base (provide (all-defined-out)) -(require "syntax-traversal.ss" (for-syntax scheme/base) scheme/match) +(require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match) ;; a parameter representing the original location of the syntax being currently checked (define current-orig-stx (make-parameter #'here)) @@ -142,4 +142,24 @@ (define (add-type-name-reference t) (type-name-references (cons t (type-name-references)))) - +;; environment constructor +(define-syntax (make-env stx) + (define-syntax-class spec + #:transparent + #:attributes (ty id) + (pattern [nm:identifier ty] + #:with id #'#'nm) + (pattern [e:expr ty extra-mods ...] + #:with id #'(let ([new-ns + (let* ([ns (make-empty-namespace)]) + (namespace-attach-module (current-namespace) + 'scheme/base + ns) + ns)]) + (parameterize ([current-namespace new-ns]) + (namespace-require 'scheme/base) + (namespace-require 'extra-mods) ... + e)))) + (syntax-parse stx + [(_ e:spec ...) + #'(list (list e.id e.ty) ...)])) \ No newline at end of file diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index a0bb5f1a1b..01fa657d8f 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -1,11 +1,8 @@ #lang scheme/base (require (for-syntax scheme/base stxclass) - scheme/contract - mzlib/plt-match - scheme/require-syntax - mzlib/struct - scheme/unit + scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax + mzlib/struct scheme/unit (except-in stxclass id)) (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log @@ -24,33 +21,51 @@ (define-syntax (define-requirer stx) (syntax-parse stx - [(_ nm:id) + [(_ nm:id nm-out:id) #`(... - (define-require-syntax (nm stx) - (syntax-parse stx - [(_ id:identifier ...) - (with-syntax ([(id* ...) - (map (lambda (id) - (datum->syntax - id - `(file - ,(path->string - (build-path (collection-path "typed-scheme" - #,(symbol->string (syntax-e #'nm))) - (string-append (symbol->string (syntax-e id)) - ".ss")))) - id id)) - (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))])))])) + (begin + (define-require-syntax (nm stx) + (syntax-parse stx + [(_ id:identifier ...) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + `(file + ,(path->string + (build-path (collection-path "typed-scheme" + #,(symbol->string (syntax-e #'nm))) + (string-append (symbol->string (syntax-e id)) + ".ss")))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))])) + (define-provide-syntax (nm-out stx) + (syntax-parse stx + [(_ id:identifier ...) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + `(file + ,(path->string + (build-path (collection-path "typed-scheme" + #,(symbol->string (syntax-e #'nm))) + (string-append (symbol->string (syntax-e id)) + ".ss")))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-out (all-from-out id*) ...)))])) + (provide nm nm-out)))])) -(define-requirer rep) -(define-requirer infer) -(define-requirer typecheck) -(define-requirer utils) -(define-requirer env) -(define-requirer private) -(define-requirer types) +(define-requirer rep rep-out) +(define-requirer infer infer-out) +(define-requirer typecheck typecheck-out) +(define-requirer utils utils-out) +(define-requirer env env-out) +(define-requirer private private-out) +(define-requirer types types-out) (define-sequence-syntax in-syntax (lambda () #'syntax->list) From 9d0ee637c74b0d7705d7b9fc60ee0712cac6b0f9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 23:18:00 +0000 Subject: [PATCH 036/156] Fix name of Type/c Fix fold on Result. Add comments. New -struct constructor with opt args. Fix tests to agree with contracts. svn: r13934 --- collects/tests/typed-scheme/unit-tests/test-utils.ss | 2 +- .../tests/typed-scheme/unit-tests/type-equal-tests.ss | 10 ++++------ collects/typed-scheme/rep/type-rep.ss | 4 ++-- collects/typed-scheme/types/abbrev.ss | 4 +++- collects/typed-scheme/utils/tc-utils.ss | 6 ++++++ collects/typed-scheme/utils/utils.ss | 9 ++++++--- 6 files changed, 22 insertions(+), 13 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index c520cebdc0..b0b3f782ee 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -8,7 +8,7 @@ (for-syntax scheme/base)) -(require (types comparison type-utils) +(require (types comparison utils) (schemeunit)) (provide private typecheck (rename-out [infer r:infer]) utils env rep types) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index c6064d45a4..2a2625d943 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -2,12 +2,12 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (types comparison type-abbrev) + (types comparison abbrev union) (schemeunit)) (provide type-equal-tests) -(define (-base x) (make-Base x #f)) +(define (-base x) (make-Base x #'dummy)) (define-syntax (te-tests stx) @@ -37,14 +37,12 @@ [(-mu x (Un N Sym x)) (-mu y (Un N Sym y))] ;; found bug [FAIL (Un (-mu heap-node - (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f #f #f values)) + (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))))) (-base 'heap-empty)) (Un (-mu heap-node - (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f #f #f values)) + (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))))) (-base 'heap-empty))])) - - (define-go type-equal-tests) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index ff06cc92a8..bfd1605f45 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -12,7 +12,7 @@ (define Type/c (flat-named-contract - "Type" + 'Type (λ (e) (and (Type? e) (not (Scope? e)) @@ -129,7 +129,7 @@ (dt Result ([t Type/c] [f LFilterSet?] [o LatentObject?]) [#:frees (λ (frees) (combine-frees (map frees (list t f o))))] - [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))]) + [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id o))]) ;; types : Listof[Type] (dt Values ([rs (listof Result?)]) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 19f8a47232..0f02eb6372 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -19,7 +19,6 @@ (define -values make-Values) (define -pair make-Pair) -(define -struct make-Struct) (define -val make-Value) (define -Param make-Param) (define -box make-Box) @@ -211,6 +210,9 @@ (define (make-arr-dots dom rng dty dbound) (make-arr* dom rng #:drest (cons dty dbound))) +(define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values]) + (make-Struct name parent flds proc poly pred cert)) + (define make-pred-ty (case-lambda diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 53958415a1..515cbef66c 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -1,4 +1,10 @@ #lang scheme/base + +#| +This file is for utilities that are only useful for Typed Scheme, but +don't depend on any other portion of the system +|# + (provide (all-defined-out)) (require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 01fa657d8f..28a80ce412 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -1,5 +1,10 @@ #lang scheme/base +#| +This file is for utilities that are of general interest, +at least theoretically. +|# + (require (for-syntax scheme/base stxclass) scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax mzlib/struct scheme/unit @@ -15,9 +20,7 @@ in-list-forever extend debug - in-syntax - ;; require macros - rep utils typecheck infer env private types) + in-syntax) (define-syntax (define-requirer stx) (syntax-parse stx From c819793a828c0688d156dee35045848e1b775345 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 00:13:54 +0000 Subject: [PATCH 037/156] more stuff works svn: r13935 --- .../typed-scheme/env/type-environments.ss | 2 +- collects/typed-scheme/infer/constraints.ss | 2 +- collects/typed-scheme/infer/infer-unit.ss | 10 ++-- collects/typed-scheme/infer/promote-demote.ss | 49 ++++++++----------- collects/typed-scheme/infer/restrict.ss | 2 +- .../{private => types}/remove-intersect.ss | 2 +- 6 files changed, 31 insertions(+), 36 deletions(-) rename collects/typed-scheme/{private => types}/remove-intersect.ss (96%) diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 0f159ec0bd..8095c8063c 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -12,7 +12,7 @@ (require (prefix-in r: "../utils/utils.ss")) (require scheme/match - (r:utils tc-utils)) + (except-in (r:utils tc-utils) make-env)) ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/infer/constraints.ss index 3dff2c088a..cacc1863b2 100644 --- a/collects/typed-scheme/infer/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -1,7 +1,7 @@ #lang scheme/unit (require (except-in "../utils/utils.ss" extend)) -(require (private type-effect-convenience type-utils union subtype) +(require (types convenience utils union subtype) (rep type-rep) (utils tc-utils) "signatures.ss" "constraint-structs.ss" diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index bcfc0e85fb..6b84ee4899 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -1,11 +1,11 @@ #lang scheme/unit (require (except-in "../utils/utils.ss")) -(require (rep free-variance type-rep effect-rep rep-utils) - (private type-effect-convenience union subtype remove-intersect) - (utils tc-utils) +(require (rep free-variance type-rep filter-rep rep-utils) + (types convenience union subtype remove-intersect) + (except-in (utils tc-utils) make-env) (env type-name-env) - (except-in (private type-utils) Dotted) + (except-in (types utils) Dotted) "constraint-structs.ss" "signatures.ss" (only-in (env type-environments) lookup current-tvars) @@ -100,6 +100,8 @@ (define (cgen/eff V X t s) (match* (t s) [(e e) (empty-cset X)] + ;; FIXME - do something here + #;#; [((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: s)) (cset-meet (cgen V X t s) (cgen V X s t))] [((Latent-Remove-Effect: t) (Latent-Remove-Effect: s)) diff --git a/collects/typed-scheme/infer/promote-demote.ss b/collects/typed-scheme/infer/promote-demote.ss index 8705122937..1eb261f135 100644 --- a/collects/typed-scheme/infer/promote-demote.ss +++ b/collects/typed-scheme/infer/promote-demote.ss @@ -1,10 +1,10 @@ #lang scheme/unit (require "../utils/utils.ss") -(require (rep type-rep) - (private type-effect-convenience union type-utils) +(require (rep type-rep rep-utils) + (types convenience union utils) "signatures.ss" - scheme/list) + scheme/list scheme/match) (import) (export promote-demote^) @@ -13,10 +13,15 @@ (for/or ([e (append* (map fv ts))]) (memq e V))) +(define (get-filters rng) + (match rng + [(Values: (list (Result: _ lf _) ...)) lf] + [(ValuesDots: (list (Result: _ lf _) ...) _ _) lf])) + (define (var-promote T V) (define (vp t) (var-promote t V)) (define (inv t) (if (V-in? V t) Univ t)) - (type-case vp T + (type-case (#:Type vp #:LatentFilter (sub-lf vp)) T [#:F name (if (memq name V) Univ T)] [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] @@ -27,19 +32,16 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest kws thn els - (cond - [(apply V-in? V (append thn els)) - (make-arr null (Un) Univ #f null null)] + [#:arr dom rng rest drest kws + (cond + [(apply V-in? V (get-filters rng)) + (make-top-arr)] [(and drest (memq (cdr drest) V)) (make-arr (for/list ([d dom]) (var-demote d V)) (vp rng) (var-demote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) - thn - els)] + (for/list ([k kws]) (var-demote k V)))] [else (make-arr (for/list ([d dom]) (var-demote d V)) (vp rng) @@ -47,15 +49,12 @@ (and drest (cons (var-demote (car drest) V) (cdr drest))) - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) - thn - els)])])) + (for/list ([k kws]) (var-demote k V)))])])) (define (var-demote T V) (define (vd t) (var-demote t V)) (define (inv t) (if (V-in? V t) (Un) t)) - (type-case vd T + (type-case (#:Type vd #:LatentFilter (sub-lf vd)) T [#:F name (if (memq name V) (Un) T)] [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] @@ -66,19 +65,16 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest kws thn els + [#:arr dom rng rest drest kws (cond - [(apply V-in? V (append thn els)) - (make-arr null (Un) Univ #f null null)] + [(apply V-in? V (get-filters rng)) + (make-top-arr)] [(and drest (memq (cdr drest) V)) (make-arr (for/list ([d dom]) (var-promote d V)) (vd rng) (var-promote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) - thn - els)] + (for/list ([k kws]) (var-demote k V)))] [else (make-arr (for/list ([d dom]) (var-promote d V)) (vd rng) @@ -86,7 +82,4 @@ (and drest (cons (var-promote (car drest) V) (cdr drest))) - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) - thn - els)])])) + (for/list ([k kws]) (var-demote k V)))])])) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/infer/restrict.ss index 4d2d26380c..140e276db5 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") (require (rep type-rep) - (private type-utils union remove-intersect subtype) + (types utils union subtype remove-intersect) "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss similarity index 96% rename from collects/typed-scheme/private/remove-intersect.ss rename to collects/typed-scheme/types/remove-intersect.ss index ca2b264c01..c7a1b219ee 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -2,7 +2,7 @@ (require (except-in "../utils/utils.ss" extend)) (require (rep type-rep) - (private union subtype resolve-type type-effect-convenience type-utils) + (types union subtype resolve convenience utils) scheme/match mzlib/trace) (provide (rename-out [*remove remove]) overlap) From e8fa7fd4dde516bd336c45c817e65e9682ab2a43 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 16:32:50 +0000 Subject: [PATCH 038/156] more movement svn: r13945 --- collects/typed-scheme/{private => types}/type-contract.ss | 0 collects/typed-scheme/{private => utils}/mutated-vars.ss | 0 collects/typed-scheme/{private => utils}/require-contract.ss | 0 collects/typed-scheme/{private => utils}/stxclass-util.ss | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename collects/typed-scheme/{private => types}/type-contract.ss (100%) rename collects/typed-scheme/{private => utils}/mutated-vars.ss (100%) rename collects/typed-scheme/{private => utils}/require-contract.ss (100%) rename collects/typed-scheme/{private => utils}/stxclass-util.ss (100%) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/types/type-contract.ss similarity index 100% rename from collects/typed-scheme/private/type-contract.ss rename to collects/typed-scheme/types/type-contract.ss diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/utils/mutated-vars.ss similarity index 100% rename from collects/typed-scheme/private/mutated-vars.ss rename to collects/typed-scheme/utils/mutated-vars.ss diff --git a/collects/typed-scheme/private/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss similarity index 100% rename from collects/typed-scheme/private/require-contract.ss rename to collects/typed-scheme/utils/require-contract.ss diff --git a/collects/typed-scheme/private/stxclass-util.ss b/collects/typed-scheme/utils/stxclass-util.ss similarity index 100% rename from collects/typed-scheme/private/stxclass-util.ss rename to collects/typed-scheme/utils/stxclass-util.ss From 7847d358426bc9b7d22547b33cddf06de89e8336 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 16:37:00 +0000 Subject: [PATCH 039/156] undo this move svn: r13947 --- collects/typed-scheme/{types => private}/type-contract.ss | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename collects/typed-scheme/{types => private}/type-contract.ss (100%) diff --git a/collects/typed-scheme/types/type-contract.ss b/collects/typed-scheme/private/type-contract.ss similarity index 100% rename from collects/typed-scheme/types/type-contract.ss rename to collects/typed-scheme/private/type-contract.ss From 84d13347d7929b6dc71a91701b46d718b4775cb0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 18:33:29 +0000 Subject: [PATCH 040/156] infer now compiles svn: r13949 --- collects/typed-scheme/infer/infer-unit.ss | 66 +++++++++-------------- 1 file changed, 26 insertions(+), 40 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 6b84ee4899..1a1d55cca7 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -115,15 +115,13 @@ (define (cgen/arr V X t-arr s-arr) (define (cg S T) (cgen V X S T)) (match* (t-arr s-arr) - [((arr: ts t #f #f '() t-thn-eff t-els-eff) - (arr: ss s #f #f '() s-thn-eff s-els-eff)) + [((arr: ts t #f #f '()) + (arr: ss s #f #f '())) (cset-meet* (list (cgen/list V X ss ts) - (cg t s) - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff)))] - [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) - (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) + (cg t s)))] + [((arr: ts t t-rest #f '()) + (arr: ss s s-rest #f '())) (let ([arg-mapping (cond [(and t-rest s-rest (<= (length ts) (length ss))) (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))] @@ -136,11 +134,9 @@ [else (fail! S T)])] [ret-mapping (cg t s)]) (cset-meet* - (list arg-mapping ret-mapping - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s #f #f '() s-thn-eff s-els-eff)) + (list arg-mapping ret-mapping)))] + [((arr: ts t #f (cons dty dbound) '()) + (arr: ss s #f #f '())) (unless (memq dbound X) (fail! S T)) (unless (<= (length ts) (length ss)) @@ -150,10 +146,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)]) + [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null) s-arr)]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f #f '() t-thn-eff t-els-eff) - (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff)) + [((arr: ts t #f #f '()) + (arr: ss s #f (cons dty dbound) '())) (unless (memq dbound X) (fail! S T)) (unless (<= (length ss) (length ts)) @@ -163,10 +159,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))]) + [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null))]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '()) + (arr: ss s #f (cons s-dty dbound) '())) (unless (= (length ts) (length ss)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? @@ -176,22 +172,18 @@ [darg-mapping (cgen V X s-dty t-dty)] [ret-mapping (cg t s)]) (cset-meet* - (list arg-mapping darg-mapping ret-mapping - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff)) + (list arg-mapping darg-mapping ret-mapping)))] + [((arr: ts t #f (cons t-dty dbound) '()) + (arr: ss s #f (cons s-dty dbound*) '())) (unless (= (length ts) (length ss)) (fail! S T)) (let* ([arg-mapping (cgen/list V X ss ts)] [darg-mapping (cgen V (cons dbound* X) s-dty t-dty)] [ret-mapping (cg t s)]) (cset-meet* - (list arg-mapping darg-mapping ret-mapping - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) + (list arg-mapping darg-mapping ret-mapping)))] + [((arr: ts t t-rest #f '()) + (arr: ss s #f (cons s-dty dbound) '())) (unless (memq dbound X) (fail! S T)) (if (<= (length ts) (length ss)) @@ -199,9 +191,7 @@ (let* ([arg-mapping (cgen/list V X ss (extend ss ts t-rest))] [darg-mapping (move-rest-to-dmap (cgen V X s-dty t-rest) dbound)] [ret-mapping (cg t s)]) - (cset-meet* (list arg-mapping darg-mapping ret-mapping - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff)))) + (cset-meet* (list arg-mapping darg-mapping ret-mapping))) ;; the hard case (let* ([num-vars (- (length ts) (length ss))] [vars (for/list ([n (in-range num-vars)]) @@ -209,11 +199,11 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] [new-cset (cgen/arr V (append vars X) t-arr - (make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))]) + (make-arr (append ss new-tys) s #f (cons s-dty dbound) null))]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. - [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) - (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '()) + (arr: ss s s-rest #f '())) (unless (memq dbound X) (fail! S T)) (cond [(< (length ts) (length ss)) @@ -227,18 +217,14 @@ [darg-mapping (cgen V X s-rest t-dty)] [ret-mapping (cg t s)] [new-cset - (cset-meet* (list arg-mapping darg-mapping ret-mapping - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff)))]) + (cset-meet* (list arg-mapping darg-mapping ret-mapping))]) (move-vars+rest-to-dmap new-cset dbound vars #:exact #t))] [else ;; the simple case (let* ([arg-mapping (cgen/list V X (extend ts ss s-rest) ts)] [darg-mapping (move-rest-to-dmap (cgen V X s-rest t-dty) dbound #:exact #t)] [ret-mapping (cg t s)]) - (cset-meet* (list arg-mapping darg-mapping ret-mapping - (cgen/eff/list V X t-thn-eff s-thn-eff) - (cgen/eff/list V X t-els-eff s-els-eff))))])] + (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])] [(_ _) (fail! S T)])) ;; determine constraints on the variables in X that would make T a supertype of S From 78fe918457e1aea1f7d0acfcf9a47d0893b5b453 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 18:39:19 +0000 Subject: [PATCH 041/156] env now compiles svn: r13950 --- collects/typed-scheme/env/init-envs.ss | 17 +++++++++-------- collects/typed-scheme/env/lexical-env.ss | 6 ++---- collects/typed-scheme/env/type-env.ss | 2 +- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index 0b64510527..dc5dc33090 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -4,12 +4,12 @@ (require "type-env.ss" "type-name-env.ss" - (rep type-rep effect-rep) - (for-template (rep type-rep effect-rep) - (private union) + "type-alias-env.ss" + (rep type-rep object-rep filter-rep) + (for-template (rep type-rep object-rep filter-rep) + (types union) mzlib/pconvert mzlib/shared scheme/base) - (private type-effect-convenience union) - "type-alias-env.ss" + (types union convenience) mzlib/pconvert scheme/match mzlib/shared) (define (initialize-type-name-env initial-type-names) @@ -32,9 +32,10 @@ [(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))] - [(? Type? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals))) - `(,(gen-constructor tag) ,@(map sub vals))] - [(? Effect? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals))) + [(? (lambda (e) (or (Type? e) + (LatentFilter? e) + (LatentObject? e))) + (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals))) `(,(gen-constructor tag) ,@(map sub vals))] [_ (basic v)])) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 63a1295b76..04ddc7a93c 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -2,11 +2,9 @@ (require (except-in "../utils/utils.ss" extend)) (require "type-environments.ss" - (utils tc-utils) "type-env.ss" - (private mutated-vars) - (private type-utils) - (private type-effect-convenience)) + (utils tc-utils mutated-vars) + (types utils convenience)) (provide (all-defined-out)) diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index 59eb3cad7e..dda31d6679 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -3,7 +3,7 @@ (require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap (utils tc-utils) - (private type-utils)) + (types utils)) (provide register-type finish-register-type From 37aa9746ea98b683b8b4d90193f20d6e51e9a5af Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 18:53:37 +0000 Subject: [PATCH 042/156] more stuff compiles svn: r13952 --- collects/typed-scheme/private/base-env.ss | 7 ++----- collects/typed-scheme/private/env-lang.ss | 4 ++-- collects/typed-scheme/types/abbrev.ss | 13 ++++++++++++- collects/typed-scheme/types/convenience.ss | 5 +++-- 4 files changed, 19 insertions(+), 10 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index eedf52c58b..35d2481812 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -46,7 +46,7 @@ [null (-val null)] [number? (make-pred-ty N)] [char? (make-pred-ty -Char)] -[integer? (Univ . -> . B : (list (make-Latent-Restrict-Effect N)) (list (make-Latent-Remove-Effect -Integer)))] +[integer? (Univ . -> . B : (-LFS (list (-filter N)) (list (-not-filter -Integer))))] [exact-integer? (make-pred-ty -Integer)] [boolean? (make-pred-ty B)] [add1 (cl->* (-> -Integer -Integer) @@ -106,10 +106,7 @@ [((a b c . -> . c) c (-lst a) (-lst b)) c]))] [foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] [filter (-poly (a b) (cl->* - ((a . -> . B - : - (list (make-Latent-Restrict-Effect b)) - (list (make-Latent-Remove-Effect b))) + ((make-pred-ty a B b) (-lst a) . -> . (-lst b)) diff --git a/collects/typed-scheme/private/env-lang.ss b/collects/typed-scheme/private/env-lang.ss index bbbfd3bd6e..1311e9cae4 100644 --- a/collects/typed-scheme/private/env-lang.ss +++ b/collects/typed-scheme/private/env-lang.ss @@ -31,6 +31,6 @@ (provide #%module-begin require (all-from-out scheme/base) - (for-syntax - (types convenience union) + (for-syntax + (types-out convenience union) (all-from-out scheme/base))) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 0f02eb6372..aa84eeb08d 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -198,6 +198,11 @@ [(Function: as) as])) (make-Function (apply append (map funty-arities args)))) +(define-syntax cl-> + (syntax-parser + [(_ [(dom ...) rng] ...) + #'(cl->* (dom ... . -> . rng) ...)])) + (define-syntax (->key stx) (syntax-parse stx [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) @@ -213,11 +218,17 @@ (define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values]) (make-Struct name parent flds proc poly pred cert)) +(define (-filter t [p null] [i 0]) + (make-LTypeFilter t p i)) + +(define (-not-filter t [p null] [i 0]) + (make-LNotTypeFilter t p i)) + (define make-pred-ty (case-lambda [(in out t) - (->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))] + (->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))] [(t) (make-pred-ty (list Univ) B t)])) diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index 702a4c0cde..12184a7207 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep) +(require (rep type-rep filter-rep object-rep) (utils tc-utils) "abbrev.ss" (types comparison printer union subtype utils) @@ -15,7 +15,8 @@ (provide (all-defined-out) (all-from-out "abbrev.ss") ;; these should all eventually go away - make-Name make-ValuesDots make-Function) + make-Name make-ValuesDots make-Function + (rep-out filter-rep object-rep)) (define (one-of/c . args) (apply Un (map -val args))) From e53a851bc21a1759161e0831730cc97c36743e2e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 19:28:48 +0000 Subject: [PATCH 043/156] base-env now compiles svn: r13954 --- collects/typed-scheme/private/base-env.ss | 15 ++++++------ collects/typed-scheme/types/abbrev.ss | 28 +++++++++++++++++++---- 2 files changed, 32 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 35d2481812..29ffe7e09f 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -106,7 +106,7 @@ [((a b c . -> . c) c (-lst a) (-lst b)) c]))] [foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] [filter (-poly (a b) (cl->* - ((make-pred-ty a B b) + ((make-pred-ty (list a) B b) (-lst a) . -> . (-lst b)) @@ -132,8 +132,8 @@ (error (make-Function (list - (make-arr (list Sym -String) (Un) Univ) - (make-arr (list -String) (Un) Univ) + (make-arr (list Sym -String) (Un) #:rest Univ) + (make-arr (list -String) (Un) #:rest Univ) (make-arr (list Sym) (Un))))) [namespace-variable-value @@ -243,9 +243,9 @@ [apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] -[time-apply (-polydots (b a) (((list) (a a) . ->... . b) - (-lst a) - . -> . +[time-apply (-polydots (b a) (make-arr/values + (list ((list) (a a) . ->... . b) + (-lst a)) (-values (list (-pair b (-val '())) N N N))))] [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] @@ -253,7 +253,8 @@ [quotient (-Integer -Integer . -> . -Integer)] [remainder (-Integer -Integer . -> . -Integer)] -[quotient/remainder (-Integer -Integer . -> . (-values (list -Integer -Integer)))] +[quotient/remainder + (make-arr/values (list -Integer -Integer) (-values (list -Integer -Integer)))] ;; parameter stuff diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index aa84eeb08d..7fdfdf216c 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -17,7 +17,7 @@ ;; convenient constructors -(define -values make-Values) + (define -pair make-Pair) (define -val make-Value) (define -Param make-Param) @@ -52,6 +52,10 @@ (c:->* (Type/c) (LFilterSet? LatentObject?) Result?) (make-Result t f o)) +(d/c (-values args) + (c:-> (listof Type/c) Values?) + (make-Values (for/list ([i args]) (-result i)))) + ;; basic types (define make-promise-ty @@ -151,14 +155,30 @@ (d/c (make-arr* dom rng #:rest [rest #f] #:drest [drest #f] #:kws [kws null] #:filters [filters -no-lfilter] #:object [obj -no-lobj]) - (c:->* ((listof Type/c) Type/c) + (c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c)) (#:rest Type/c #:drest (cons/c Type/c symbol?) #:kws (listof Keyword?) #:filters LFilterSet? #:object LatentObject?) arr?) - (make-arr dom (-values (list (-result rng filters obj))) rest drest (sort #:key Keyword-kw kws keyword* ((listof Type/c) (or/c ValuesDots? Values?)) + (#:rest Type/c + #:drest (cons/c Type/c symbol?) + #:kws (listof Keyword?) + #:filters LFilterSet? + #:object LatentObject?) + arr?) + (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword* (syntax-rules (:) @@ -167,7 +187,7 @@ [(_ dom rst rng) (make-Function (list (make-arr* dom rng #:rest rst)))] [(_ dom rng : filters) - (make-Function (list (make-arr* dom rng #f #:filters filters)))] + (make-Function (list (make-arr* dom rng #:filters filters)))] [(_ dom rst rng : filters) (make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))])) From 00721c10c80eae7fe51bea7593c1cab181820716 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 19:49:20 +0000 Subject: [PATCH 044/156] all of private, and tc-structs, now compiles svn: r13956 --- .../typed-scheme/private/base-special-env.ss | 8 +++--- collects/typed-scheme/private/parse-type.ss | 8 ++---- collects/typed-scheme/private/prims.ss | 2 +- .../typed-scheme/private/type-annotation.ss | 4 +-- .../typed-scheme/private/type-contract.ss | 25 ++++++++----------- .../typed-scheme/private/type-env-lang.ss | 17 +++++-------- collects/typed-scheme/typecheck/tc-structs.ss | 5 ++-- 7 files changed, 28 insertions(+), 41 deletions(-) diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index beb9051328..6c22040b31 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -16,11 +16,11 @@ ;; these are all for constructing the types given to variables (require (for-syntax scheme/base + (utils tc-utils) (env init-envs) - (except-in (rep effect-rep type-rep) make-arr) - "type-effect-convenience.ss" - (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "union.ss" + (except-in (rep filter-rep object-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]) (typecheck tc-structs))) (define-for-syntax (initialize-others) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 135384af86..c3e9438ee0 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -4,17 +4,13 @@ (require (except-in "../utils/utils.ss" extend id)) (require (except-in (rep type-rep) make-arr) - "type-effect-convenience.ss" - (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - (utils tc-utils) - "union.ss" + (rename-in (types convenience union utils) [make-arr* make-arr]) + (utils tc-utils stxclass-util) syntax/stx stxclass stxclass/util (env type-environments type-name-env type-alias-env) - "type-utils.ss" (prefix-in t: "base-types-extra.ss") scheme/match - "stxclass-util.ss" (for-template scheme/base "base-types-extra.ss")) (define enable-mu-parsing (make-parameter #t)) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 3988110b43..696c9c63cc 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -37,7 +37,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (env type-name-env) "type-contract.ss")) -(require "require-contract.ss" +(require (utils require-contract) (typecheck internal-forms) (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index 637574b4b2..ec556f4d83 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -4,8 +4,8 @@ (require (rep type-rep) (utils tc-utils) (env type-env) - "parse-type.ss" "subtype.ss" - "type-effect-convenience.ss" "resolve-type.ss" "union.ss" + (types subtype union convenience resolve) + (private parse-type) scheme/match mzlib/trace) (provide type-annotation get-type diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index da0990418e..2b0491ea8a 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -6,14 +6,11 @@ (require (rep type-rep) (typecheck internal-forms) - (utils tc-utils) + (utils tc-utils require-contract) (env type-name-env) - "parse-type.ss" - "require-contract.ss" - "resolve-type.ss" - "type-utils.ss" - (only-in "type-effect-convenience.ss" Any-Syntax) - (prefix-in t: "type-effect-convenience.ss") + (types resolve utils) + (prefix-in t: (types convenience)) + (private parse-type) scheme/match syntax/struct syntax/stx @@ -61,7 +58,7 @@ ;; we special-case lists: [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) #`(listof #,(t->c elem-ty))] - [(? (lambda (e) (eq? Any-Syntax e))) #'syntax?] + [(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?] [(Base: sym cnt) cnt] [(Union: elems) (with-syntax @@ -73,13 +70,13 @@ (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f '() _ _) + [(arr: dom (Values: rngs) #f #f '()) (values (map t->c dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f '() _ _) + [(arr: dom rng #f #f '()) (values (map t->c dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f '() _ _) + [(arr: dom (Values: rngs) rst #f '() ) (values (map t->c dom) (map t->c rngs) (t->c rst))] - [(arr: dom rng rst #f '() _ _) + [(arr: dom rng rst #f '()) (values (map t->c dom) (list (t->c rng)) (t->c rst))])) (with-syntax ([(dom* ...) dom*] @@ -91,7 +88,7 @@ #'((dom* ...) () #:rest (listof rst*) . ->* . rng*) #'(dom* ... . -> . rng*)))) (unless (no-duplicates (for/list ([t arrs]) - (match t [(arr: dom _ _ _ _ _ _) (length dom)]))) + (match t [(arr: dom _ _ _ _) (length dom)]))) (exit (fail))) (match (map f arrs) [(list e) e] @@ -116,7 +113,7 @@ [(Struct: _ _ _ _ #f pred? cert) (cert pred?)] [(Syntax: (Base: 'Symbol _)) #'identifier?] [(Syntax: t) - (if (equal? ty Any-Syntax) + (if (equal? ty t:Any-Syntax) #`syntax? #`(syntax/c #,(t->c t)))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] diff --git a/collects/typed-scheme/private/type-env-lang.ss b/collects/typed-scheme/private/type-env-lang.ss index d12fc33cc0..4d74faf309 100644 --- a/collects/typed-scheme/private/type-env-lang.ss +++ b/collects/typed-scheme/private/type-env-lang.ss @@ -2,14 +2,10 @@ (require "../utils/utils.ss") -(require (for-syntax (private type-effect-convenience) - (env init-envs) +(require (for-syntax (env init-envs) scheme/base - (except-in (rep effect-rep type-rep) make-arr) - (except-in "../rep/type-rep.ss" make-arr) - "type-effect-convenience.ss" - (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "union.ss")) + (except-in (rep filter-rep type-rep) make-arr) + (rename-in (types union convenience) [make-arr* make-arr]))) (define-syntax (#%module-begin stx) (syntax-case stx (require) @@ -35,7 +31,6 @@ require (all-from-out scheme/base) (for-syntax - (all-from-out scheme/base - "type-effect-convenience.ss" - "../rep/type-rep.ss" - "union.ss"))) + (types-out convenience union) + (rep-out type-rep) + (all-from-out scheme/base))) diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index b95c06da4b..08bd1e87be 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -2,9 +2,8 @@ (require (except-in "../utils/utils.ss" extend)) (require (rep type-rep) - (private type-effect-convenience - type-utils parse-type - union resolve-type) + (private parse-type) + (types convenience utils union resolve) (env type-env type-environments type-name-env) (utils tc-utils) "def-binding.ss" From 8498619ab87c1b3f01a68cb8f5614ac982be7e4e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 20:26:34 +0000 Subject: [PATCH 045/156] most test suites pass svn: r13958 --- .../typed-scheme/unit-tests/all-tests.ss | 19 ++++++++++--------- .../typed-scheme/unit-tests/infer-tests.ss | 2 +- .../unit-tests/parse-type-tests.ss | 12 +++++------- .../unit-tests/remove-intersect-tests.ss | 6 ++++-- .../typed-scheme/unit-tests/subst-tests.ss | 2 +- .../typed-scheme/unit-tests/subtype-tests.ss | 4 ++-- .../unit-tests/type-annotation-test.ss | 3 ++- 7 files changed, 25 insertions(+), 23 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index ec859fed7f..c32dbfea30 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -3,15 +3,16 @@ (require "test-utils.ss" "planet-requires.ss" - "typecheck-tests.ss" - "subtype-tests.ss" ;; done - "type-equal-tests.ss" ;; done - "remove-intersect-tests.ss" ;; done - "parse-type-tests.ss" ;; done - "type-annotation-test.ss" ;; done - "module-tests.ss" - "subst-tests.ss" - "infer-tests.ss") + ;"typecheck-tests.ss" ;; doesn't compile yet + "subtype-tests.ss" ;; fail + "type-equal-tests.ss" ;; pass + "remove-intersect-tests.ss" ;; pass + "parse-type-tests.ss" ;; pass + "type-annotation-test.ss" ;; fail + "module-tests.ss" ;; pass + "subst-tests.ss" ;; pass + "infer-tests.ss" ;; pass + ) (require (r:infer infer infer-dummy) (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index f792b1efb7..8bcbd305a3 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) (r:infer infer) - (private type-effect-convenience union type-utils) + (types convenience union utils) (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index cfe775ea65..e509fbb7dc 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -3,14 +3,12 @@ (require (utils tc-utils) (env type-alias-env type-environments type-name-env init-envs) (rep type-rep) - (rename-in (private type-comparison parse-type subtype - union type-utils) - [Un t:Un]) - (schemeunit)) - -(require (rename-in (private type-effect-convenience) [-> t:->]) + (rename-in (types comparison subtype union utils convenience) + [Un t:Un] [-> t:->]) (private base-types base-types-extra) - (for-template (private base-types base-types-extra))) + (for-template (private base-types base-types-extra)) + (private parse-type) + (schemeunit)) (provide parse-type-tests) diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index e18cd04b91..53b99e223f 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,8 +1,8 @@ #lang scheme/base (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (r:infer infer) - (private type-effect-convenience remove-intersect subtype union) + (r:infer infer infer-dummy) + (types convenience subtype union remove-intersect) (schemeunit)) (define-syntax (restr-tests stx) @@ -11,6 +11,8 @@ #'(test-suite "Tests for intersect" (test-check (format "Restrict test: ~a ~a" t1 t2) type-compare? (restrict t1 t2) res) ...)])) +(infer-param infer) + (define (restrict-tests) (restr-tests [N (Un N Sym) N] diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 6ac1db6fb3..02a018c787 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (types type-utils type-abbrev) + (types utils abbrev) (schemeunit)) (define-syntax-rule (s img var tgt result) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 719f108bf5..ff8a3b3ae8 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss") -(require (types subtype type-effect-convenience union) +(require (types subtype convenience union) (rep type-rep) (env init-envs type-environments) (r:infer infer infer-dummy) @@ -55,7 +55,7 @@ [(-mu x (Un N (make-Listof x))) (-mu x (Un N Sym (make-Listof x)))] [(-mu x (Un N (make-Listof x))) (-mu y (Un N Sym (make-Listof y)))] ;; a hard one - [-NE -Sexp] + [(-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null)))))) -Sexp] ;; simple function types ((Univ . -> . N) (N . -> . Univ)) [(Univ Univ Univ . -> . N) (Univ Univ N . -> . N)] diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 9f5398e72a..c228501b60 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,7 +1,8 @@ #lang scheme/base (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) -(require (private type-annotation type-effect-convenience parse-type) +(require (private type-annotation parse-type) + (types convenience) (env type-environments type-name-env init-envs) (utils tc-utils) (rep type-rep) From f106e885510ee32b88328abc3f34f762b798ba2f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 4 Mar 2009 20:31:46 +0000 Subject: [PATCH 046/156] remove contract errors svn: r13959 --- collects/tests/typed-scheme/unit-tests/subtype-tests.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index ff8a3b3ae8..1330dc30f0 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -113,10 +113,10 @@ (cl-> [() (-pair N (-v b))] [(N) (-pair N (-v b))])] - [(-poly (a) ((Un (make-Base 'foo #f) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a))) - ((Un (make-Base 'foo #f) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))] - [(-poly (a) ((-struct 'bar #f (list N a) #f #f #f values) . -> . (-lst a))) - ((-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values) . -> . (-lst (-pair N (-v a))))] + [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list N a))) . -> . (-lst a))) + ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list N (-pair N (-v a))))) . -> . (-lst (-pair N (-v a))))] + [(-poly (a) ((-struct 'bar #f (list N a)) . -> . (-lst a))) + ((-struct 'bar #f (list N (-pair N (-v a)))) . -> . (-lst (-pair N (-v a))))] [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))] [(-poly (a) (a . -> . (make-Listof a))) ((-pair N (-v b)) . -> . (make-Listof (-pair N (-v b))))] From 147cac076ca959adfb754a778979621a37d5ce73 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 5 Mar 2009 00:09:43 +0000 Subject: [PATCH 047/156] handle subtyping for varargs functions svn: r13962 --- .../typed-scheme/unit-tests/subtype-tests.ss | 4 +-- collects/typed-scheme/types/subtype.ss | 28 +++++++++++++++---- collects/typed-scheme/utils/utils.ss | 21 ++++++++------ 3 files changed, 37 insertions(+), 16 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 1330dc30f0..69b56012f6 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -33,8 +33,6 @@ (B Univ) (Sym Univ) (-Void Univ) - #;(Sym Dyn) - #;(Dyn N) [N N] [(Un (-pair Univ (-lst Univ)) (-val '())) (-lst Univ)] [(-pair N (-pair N (-pair (-val 'foo) (-val '())))) (-lst Univ)] @@ -113,6 +111,8 @@ (cl-> [() (-pair N (-v b))] [(N) (-pair N (-v b))])] + [(-values (list N)) (-values (list Univ))] + [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list N a))) . -> . (-lst a))) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list N (-pair N (-v a))))) . -> . (-lst (-pair N (-v a))))] [(-poly (a) ((-struct 'bar #f (list N a)) . -> . (-lst a))) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 13d6785253..20570e2bde 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -122,17 +122,30 @@ (define (arr-subtype*/no-fail A0 s t) (with-handlers ([exn:subtype? (lambda _ #f)]) - (match (list s t) + (match* (s t) ;; top for functions is above everything - [(list _ (top-arr:)) A0] - [(list (arr: s1 s2 #f #f s-kws) - (arr: t1 t2 #f #f t-kws)) + [(_ (top-arr:)) A0] + [((arr: s1 s2 #f #f s-kws) + (arr: t1 t2 #f #f t-kws)) (subtype-seq A0 (subtypes* t1 s1) (kw-subtypes* t-kws s-kws) (subtype* s2 t2))] - ;; FIXME - handle varargs - [else + [((arr: s-dom s-rng s-rest #f s-kws) + (arr: t-dom t-rng #f #f t-kws)) + (subtype-seq A0 + (subtypes*/varargs t-dom s-dom s-rest) + (kw-subtypes* t-kws s-kws) + (subtype* s-rng t-rng))] + [((arr: s-dom s-rng s-rest #f s-kws) + (arr: t-dom t-rng t-rest #f t-kws)) + (subtype-seq A0 + (subtypes*/varargs t-dom s-dom s-rest) + (subtype* t-rest s-rest) + (kw-subtypes* t-kws s-kws) + (subtype* s-rng t-rng))] + ;; FIXME - handle dotted varargs + [(_ _) (fail! s t)]))) (define (subtypes/varargs args dom rst) @@ -283,6 +296,9 @@ [(list (Struct: 'Promise _ (list t) _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _)) (subtype* A0 t t*)] ;; subtyping on values is pointwise [(list (Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] + ;; trivial case for Result + [(list (Result: t f o) (Result: t* f o)) + (subtype* A0 t t*)] ;; single values shouldn't actually happen, but they're just like the type [(list t (Values: (list t*))) (int-err "BUG - singleton values type~a" (make-Values (list t*)))] [(list (Values: (list t)) t*) (int-err "BUG - singleton values type~a" (make-Values (list t)))] diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 28a80ce412..658c581b4f 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -29,20 +29,25 @@ at least theoretically. (begin (define-require-syntax (nm stx) (syntax-parse stx - [(_ id:identifier ...) + [(form id:identifier ...) (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax id `(file - ,(path->string - (build-path (collection-path "typed-scheme" - #,(symbol->string (syntax-e #'nm))) - (string-append (symbol->string (syntax-e id)) - ".ss")))) + ,(datum->syntax + #f + (path->string + (build-path (collection-path "typed-scheme" + #,(symbol->string (syntax-e #'nm))) + (string-append (symbol->string (syntax-e id)) + ".ss"))) + id id)) id id)) (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))])) + (syntax-property (syntax/loc stx (combine-in id* ...)) + 'disappeared-use + #'form))])) (define-provide-syntax (nm-out stx) (syntax-parse stx [(_ id:identifier ...) @@ -183,7 +188,7 @@ at least theoretically. [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #f) +(define-for-syntax printing? #t) (define-syntax-rule (defprinter t ...) (begin From 511d641b450b788760ca9207b586fe0792a4744e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 5 Mar 2009 00:33:48 +0000 Subject: [PATCH 048/156] All subtype tests now pass. svn: r13963 --- collects/typed-scheme/infer/infer-dummy.ss | 3 ++- collects/typed-scheme/infer/infer-unit.ss | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/infer/infer-dummy.ss b/collects/typed-scheme/infer/infer-dummy.ss index e87f744f21..1088e741bc 100644 --- a/collects/typed-scheme/infer/infer-dummy.ss +++ b/collects/typed-scheme/infer/infer-dummy.ss @@ -1,8 +1,9 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep) (utils tc-utils)) +(require (rep type-rep) (utils tc-utils) mzlib/trace) (define infer-param (make-parameter (lambda e (int-err "infer not initialized")))) (define (unify X S T) ((infer-param) X S T (make-Univ) null)) +;(trace unify) (provide unify infer-param) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 1a1d55cca7..ea3648b095 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -386,6 +386,10 @@ ([t-arr t-arr] [s-arr s-arr]) (with-handlers ([exn:infer? (lambda (_) #f)]) (cgen/arr V X t-arr s-arr)))))] + ;; this is overly conservative + [((Result: s f o) + (Result: t f o)) + (cg s t)] [(_ _) (cond [(subtype S T) empty] ;; or, nothing worked, and we fail From 6c30e2d9e7c9d983f97092ad3aad8268e0560cb5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Mar 2009 19:50:42 +0000 Subject: [PATCH 049/156] Remove some old debugging printfs in soon-to-be-dead code. Fix some requires. Start implementing metafunctions. Strengthen contracts on filter-sets. Rename N B Sym. svn: r13988 --- collects/typed-scheme/private/base-env.ss | 3 +- .../typed-scheme/private/base-special-env.ss | 6 +- collects/typed-scheme/private/base-types.ss | 6 +- collects/typed-scheme/private/env-lang.ss | 1 + collects/typed-scheme/rep/filter-rep.ss | 48 ++++++++++++-- collects/typed-scheme/rep/rep-utils.ss | 2 +- collects/typed-scheme/typecheck/signatures.ss | 2 +- collects/typed-scheme/typecheck/tc-if-unit.ss | 53 ++-------------- .../typecheck/tc-metafunctions.ss | 62 +++++++++++++++++++ .../typed-scheme/typecheck/tc-toplevel.ss | 5 +- collects/typed-scheme/typed-scheme.ss | 5 +- collects/typed-scheme/types/abbrev.ss | 20 +++--- 12 files changed, 137 insertions(+), 76 deletions(-) create mode 100644 collects/typed-scheme/typecheck/tc-metafunctions.ss diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 29ffe7e09f..98793c5a99 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -9,7 +9,8 @@ (only-in '#%kernel [apply kernel:apply]) scheme/promise (only-in string-constants/private/only-once maybe-print-message) - (only-in scheme/match/runtime match:error)) + (only-in scheme/match/runtime match:error) + (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]))) [raise (Univ . -> . (Un))] diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index 6c22040b31..76a692136c 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -25,8 +25,8 @@ (define-for-syntax (initialize-others) (d-s date - ([second : N] [minute : N] [hour : N] [day : N] [month : N] - [year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N]) + ([second : -Number] [minute : -Number] [hour : -Number] [day : -Number] [month : -Number] + [year : -Number] [weekday : -Number] [year-day : -Number] [dst? : -Boolean] [time-zone-offset : -Number]) ()) (d-s exn ([message : -String] [continuation-marks : Univ]) ()) (d-s (exn:fail exn) () (-String -Cont-Mark-Set)) @@ -65,7 +65,7 @@ ;; make-promise (-poly (a) (-> (-> a) (-Promise a))) ;; language - Sym + -Symbol ;; qq-append (-poly (a b) (cl->* diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index 0cbae61e0b..0d3d23acde 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -1,10 +1,10 @@ #lang s-exp "type-env-lang.ss" -[Number N] +[Number -Number] [Integer -Integer] [Void -Void] -[Boolean B] -[Symbol Sym] +[Boolean -Boolean] +[Symbol -Symbol] [String -String] [Any Univ] [Port -Port] diff --git a/collects/typed-scheme/private/env-lang.ss b/collects/typed-scheme/private/env-lang.ss index 1311e9cae4..434b5f5a1b 100644 --- a/collects/typed-scheme/private/env-lang.ss +++ b/collects/typed-scheme/private/env-lang.ss @@ -31,6 +31,7 @@ (provide #%module-begin require (all-from-out scheme/base) + types rep private utils (for-syntax (types-out convenience union) (all-from-out scheme/base))) diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index e9f70374ba..33d095532e 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -3,6 +3,20 @@ (require scheme/match scheme/contract) (require "rep-utils.ss" "free-variance.ss") +(define Filter/c + (flat-named-contract + 'Filter + (λ (e) + (and (Filter? e) (not (FilterSet? e)))))) + +(define LatentFilter/c + (flat-named-contract + 'LatentFilter + (λ (e) + (and (LatentFilter? e) (not (LFilterSet? e)))))) + +(provide Filter/c LatentFilter/c index/c) + (df Bot () [#:fold-rhs #:base]) (df TypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?]) @@ -17,11 +31,22 @@ (combine-frees (map free-idxs* (cons t p)))] [#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) -(df FilterSet ([thn (listof (and/c Filter? (not/c FilterSet?)))] - [els (listof (and/c Filter? (not/c FilterSet?)))]) +(df FilterSet (thn els) [#:frees (combine-frees (map free-vars* (append thn els))) (combine-frees (map free-idxs* (append thn els)))] - [#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))]) + [#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))] + [#:contract (->d ([t (cond [(ormap Bot? t) + (list/c Bot?)] + [(ormap Bot? e) + (list/c)] + [else (listof Filter/c)])] + [e (cond [(ormap Bot? e) + (list/c Bot?)] + [(ormap Bot? t) + (list/c)] + [else (listof Filter/c)])]) + () + [result FilterSet?])]) (define index/c (or/c natural-number/c keyword?)) @@ -35,8 +60,19 @@ [#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))] [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)]) -(dlf LFilterSet ([thn (listof (and/c LatentFilter? (not/c LFilterSet?)))] - [els (listof (and/c LatentFilter? (not/c LFilterSet?)))]) +(dlf LFilterSet (thn els) [#:frees (combine-frees (map free-vars* (append thn els))) (combine-frees (map free-idxs* (append thn els)))] - [#:fold-rhs (*LFilterSet (map latentfilter-rec-id thn) (map latentfilter-rec-id els))]) + [#:fold-rhs (*LFilterSet (map latentfilter-rec-id thn) (map latentfilter-rec-id els))] + [#:contract (->d ([t (cond [(ormap LBot? t) + (list/c LBot?)] + [(ormap LBot? e) + (list/c)] + [else (listof LatentFilter/c)])] + [e (cond [(ormap LBot? e) + (list/c LBot?)] + [(ormap LBot? t) + (list/c)] + [else (listof LatentFilter/c)])]) + () + [result LFilterSet?])]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 3de0e278e8..9c1d66af7a 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -95,7 +95,7 @@ [provides (if #'no-provide? #'(begin) #`(begin - (provide ex pred acc ...) + (provide #;nm ex pred acc ...) (p/c (rename *maker maker *maker-cnt))))] [intern (let ([mk (lambda (int) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index 530ad0094c..ec810d1067 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -2,7 +2,7 @@ (require scheme/unit scheme/contract "../utils/utils.ss") (require (rep type-rep) (utils unit-utils) - (private type-utils)) + (types utils)) (provide (all-defined-out)) (define-signature typechecker^ diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index cc87ca8b13..24bb6cd2df 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -2,13 +2,12 @@ (require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - (rep type-rep effect-rep) - (private type-effect-convenience subtype union type-utils type-comparison mutated-vars) + (rep type-rep filter-rep object-rep) + (rename-in (types convenience subtype union utils comparison remove-intersect) + [remove *remove]) (env lexical-env) - (only-in (private remove-intersect) - [remove *remove]) (r:infer infer) - (utils tc-utils) + (utils tc-utils mutated-vars) syntax/kerncase mzlib/trace mzlib/plt-match) @@ -24,17 +23,14 @@ ;; neccessary for handling true/false effects ;; Boolean Expr listof[Effect] option[type] -> TC-Result (define (tc-expr/eff t/f expr effs expected) - #;(printf "tc-expr/eff : ~a~n" (syntax-object->datum expr)) ;; this flag represents whether the refinement proves that this expression cannot be executed (let ([flag (box #f)]) ;; this does the operation on the old type ;; type-op : (Type Type -> Type) Type -> _ Type -> Type (define ((type-op f t) _ old) (let ([new-t (f old t)]) - ;(printf "new-t ~a~n" new-t) ;; if this operation produces an uninhabitable type, then this expression can't be executed (when (type-equal? new-t (Un)) - ;(printf "setting flag!~n") (set-box! flag #t)) ;; have to return something here, so that we can continue typechecking new-t)) @@ -87,16 +83,10 @@ ;; the main function (define (tc/if-twoarm tst thn els) - #;(printf "tc-if/twoarm~n") ;; check in the context of the effects, and return (match-let* ([(tc-result: tst-ty tst-thn-eff tst-els-eff) (tc-expr tst)] [(tc-result: thn-ty thn-thn-eff thn-els-eff) (tc-expr/eff #t thn tst-thn-eff #f)] - #;[_ (printf "v is ~a~n" v)] - #;[c (current-milliseconds)] [(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff #f)]) - #;(printf "tst thn-eff: ~a~ntst els-eff: ~a~n" tst-thn-eff tst-els-eff) - #;(printf "thn ty:~a thn-eff: ~a thn els-eff: ~a~n" thn-ty thn-thn-eff thn-els-eff) - #;(printf "els ty:~a thn-eff: ~a els els-eff: ~a~n" els-ty els-thn-eff els-els-eff) (match* (els-ty thn-thn-eff thn-els-eff els-thn-eff els-els-eff) ;; this is the case for `or' ;; the then branch has to be #t @@ -106,7 +96,6 @@ ;; FIXME - mzscheme's or macro doesn't match this! [(_ (list (True-Effect:)) (list (True-Effect:)) (list (Restrict-Effect: t v)) (list (Remove-Effect: t v*))) (=> unmatch) - #;(printf "or branch~n") (match (list tst-thn-eff tst-els-eff) ;; check that the test was also a simple predicate [(list (list (Restrict-Effect: s u)) (list (Remove-Effect: s u*))) @@ -126,7 +115,6 @@ [_ (unmatch)])] ;; this is the case for `and' [(_ _ _ (list (False-Effect:)) (list (False-Effect:))) - #;(printf "and branch~n") (ret (Un (-val #f) thn-ty) ;; we change variable effects to type effects in the test, ;; because only the boolean result of the test is used @@ -136,41 +124,17 @@ (list))] ;; if the else branch can never happen, just use the effect of the then branch [((Union: (list)) _ _ _ _) - #;(printf "and branch~n") - (ret thn-ty - ;; we change variable effects to type effects in the test, - ;; because only the boolean result of the test is used - ;; whereas, the actual value of the then branch is returned, not just the boolean result - (append #;(map var->type-eff tst-thn-eff) thn-thn-eff) - ;; no else effects for and, because any branch could have been false - (append #;(map var->type-eff tst-els-eff) thn-els-eff))] + (ret thn-ty thn-thn-eff thn-els-eff)] ;; otherwise this expression has no effects [(_ _ _ _ _) - #;(printf "if base case:~a ~n" (syntax-object->datum tst)) - #;(printf "els-ty ~a ~a~n" - els-ty c) - #;(printf "----------------------~nels-ty ~a ~nUn~a~n ~a~n" - els-ty (Un thn-ty els-ty) c) (ret (Un thn-ty els-ty))]))) ;; checking version (define (tc/if-twoarm/check tst thn els expected) - #;(printf "tc-if/twoarm/check~n") ;; check in the context of the effects, and return (match-let* ([(tc-result: tst-ty tst-thn-eff tst-els-eff) (tc-expr tst)] - #;[_ (printf "got to here 0~n")] [(tc-result: thn-ty thn-thn-eff thn-els-eff) (tc-expr/eff #t thn tst-thn-eff expected)] - #;[_ (printf "v is ~a~n" v)] - #;[c (current-milliseconds)] - #;[_ (printf "got to here 1~n")] - [(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff expected)] - #;[_ (printf "got to here 2~n")]) - #;(printf "check: v now is ~a~n" (ret els-ty els-thn-eff els-els-eff)) - #;(printf "els-ty ~a ~a~n" - els-ty c) - #;(printf "tst/check thn-eff: ~a~ntst els-eff: ~a~n" tst-thn-eff tst-els-eff) - #;(printf "thn/check thn-eff: ~a~nthn els-eff: ~a~n" thn-thn-eff thn-els-eff) - #;(printf "els/check thn-eff: ~a~nels els-eff: ~a~n" els-thn-eff els-els-eff) + [(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff expected)]) (match* (els-ty thn-thn-eff thn-els-eff els-thn-eff els-els-eff) ;; this is the case for `or' ;; the then branch has to be #t @@ -180,7 +144,6 @@ ;; FIXME - mzscheme's or macro doesn't match this! [(_ (list (True-Effect:)) (list (True-Effect:)) (list (Restrict-Effect: t v)) (list (Remove-Effect: t v*))) (=> unmatch) - ;(printf "or branch~n") (match (list tst-thn-eff tst-els-eff) ;; check that the test was also a simple predicate [(list (list (Restrict-Effect: s u)) (list (Remove-Effect: s u*))) @@ -202,7 +165,6 @@ [_ (unmatch)])] ;; this is the case for `and' [(_ _ _ (list (False-Effect:)) (list (False-Effect:))) - #;(printf "and branch~n") (let ([t (Un thn-ty (-val #f))]) (check-below t expected) (ret t @@ -226,6 +188,3 @@ (let ([t (Un thn-ty els-ty)]) (check-below t expected) (ret t))]))) - - -;) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss new file mode 100644 index 0000000000..5382d22c96 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -0,0 +1,62 @@ +#lang scheme/base + +(require "../utils/utils.ss") +(require (rename-in (types subtype convenience remove-intersect) + [-> -->] + [->* -->*] + [one-of/c -one-of/c]) + (rep type-rep) + scheme/contract scheme/match + stxclass/util + (for-syntax scheme/base)) + +;; this implements the sequence invariant described on the first page relating to Bot +(define (lcombine l1 l2) + (cond [(memq (make-LBot) l1) + (make-LFilterSet (list (make-LBot)) null)] + [(memq (make-LBot) l2) + (make-LFilterSet null (list (make-LBot)))] + [else (make-LFilterSet l1 l2)])) + +(define (combine l1 l2) + (cond [(memq (make-Bot) l1) + (make-FilterSet (list (make-Bot)) null)] + [(memq (make-Bot) l2) + (make-FilterSet null (list (make-Bot)))] + [else (make-FilterSet l1 l2)])) + +(define/contract (abstract-filter x idx fs) + (-> identifier? index/c FilterSet? LFilterSet?) + (match fs + [(FilterSet: f+ f-) + (lcombine + (apply append (for/list ([f f+]) (abo x idx f))) + (apply append (for/list ([f f-]) (abo x idx f))))])) + +(define/contract (abo x idx f) + (-> identifier? index/c Filter/c (or/c '() (list/c LatentFilter/c))) + (define-match-expander =x + (lambda (stx) #'(? (lambda (id) (free-identifier=? id x))))) + (match f + [(Bot:) (list (make-LBot))] + [(TypeFilter: t p (=x)) (list (make-LTypeFilter t p))] + [(NotTypeFilter: t p (=x)) (list (make-LNotTypeFilter t p))] + [_ null])) + +(define/contract (apply-filter lfs t o) + (-> LFilterSet? Type/c Object?) + (match lfs + [(LFilterSet: lf+ lf-) + (combine + (apply append (for/list ([lf lf+]) (apo lf t o))) + (apply append (for/list ([lf lf-]) (apo lf t o))))])) + +(define/contract (apo lf s o) + (-> LatentFilter/c Type/c Object? (or/c '() (list/c Filter/c))) + (match* (lf s o) + [((LBot:) _ _) (list (make-Bot))] + [((LNotTypeFilter: (? (lambda (t) (subtype s t))) (list) _) _ _) (list (make-Bot))] + [((LTypeFilter: (? (lambda (t) (not (overlap s t)))) (list) _) _ _) (list (make-Bot))] + [(_ _ (Empty:)) null] + [((LTypeFilter: t pi* _) _ (Path: pi x)) (make-TypeFilter t (append pi* pi) x)] + [((LNotTypeFilter: t pi* _) _ (Path: pi x)) (make-NotTypeFilter t (append pi* pi) x)])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index f0553c1e21..937568aab1 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -8,9 +8,10 @@ "signatures.ss" "tc-structs.ss" (rep type-rep) - (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract) + (types utils convenience) + (private parse-type type-annotation type-contract) (env type-env init-envs type-name-env type-alias-env) - (utils tc-utils) + (utils tc-utils mutated-vars) "provide-handling.ss" "def-binding.ss" (for-template diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index c5054fce78..d6bb00ec51 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -2,10 +2,11 @@ (require (rename-in "utils/utils.ss" [infer r:infer])) -(require (private #;base-env base-types) +(require (private base-types) (for-syntax scheme/base - (private type-utils type-contract type-effect-convenience) + (private type-contract) + (types utils convenience) (typecheck typechecker provide-handling) (env type-environments type-name-env type-alias-env) (r:infer infer) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 7fdfdf216c..5db79868df 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -66,10 +66,10 @@ (define -Listof (-poly (list-elem) (make-Listof list-elem))) -(define N (make-Base 'Number #'number?)) +(define -Number (make-Base 'Number #'number?)) (define -Integer (make-Base 'Integer #'exact-integer?)) -(define B (make-Base 'Boolean #'boolean?)) -(define Sym (make-Base 'Symbol #'symbol?)) +(define -Boolean (make-Base 'Boolean #'boolean?)) +(define -Symbol (make-Base 'Symbol #'symbol?)) (define -Void (make-Base 'Void #'void?)) (define -Bytes (make-Base 'Bytes #'bytes?)) (define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?)))) @@ -99,24 +99,24 @@ (define Any-Syntax (-mu x (-Syntax (*Un - N - B - Sym + -Number + -Boolean + -Symbol -String -Keyword (-mu y (*Un (-val '()) (-pair x (*Un x y)))) (make-Vector x) (make-Box x))))) -(define Ident (-Syntax Sym)) +(define Ident (-Syntax -Symbol)) -(define -Sexp (-mu x (*Un (-val null) N B Sym -String (-pair x x)))) +(define -Sexp (-mu x (*Un (-val null) -Number -Boolean -Symbol -String (-pair x x)))) (define -Port (*Un -Output-Port -Input-Port)) (define -Pathlike (*Un -String -Path)) (define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same))) (define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String)) -(define -Byte N) +(define -Byte -Number) (define -no-lfilter (make-LFilterSet null null)) (define -no-filter (make-FilterSet null null)) @@ -249,7 +249,7 @@ (case-lambda [(in out t) (->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))] - [(t) (make-pred-ty (list Univ) B t)])) + [(t) (make-pred-ty (list Univ) -Boolean t)])) (define (opt-fn args opt-args result) From e2a017f331b09745540bf47873cd9f1539f878ca Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Mar 2009 19:51:33 +0000 Subject: [PATCH 050/156] fix typo svn: r13989 --- collects/typed-scheme/typecheck/tc-metafunctions.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 5382d22c96..4081a3ad8d 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -44,7 +44,7 @@ [_ null])) (define/contract (apply-filter lfs t o) - (-> LFilterSet? Type/c Object?) + (-> LFilterSet? Type/c Object? FilterSet?) (match lfs [(LFilterSet: lf+ lf-) (combine From d293635cb7f2894111ec06339422a24c7fb7ef39 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Mar 2009 20:54:39 +0000 Subject: [PATCH 051/156] combine-filter update svn: r13992 --- collects/typed-scheme/typecheck/tc-envops.ss | 44 +++++++++++++++++++ .../typecheck/tc-metafunctions.ss | 35 +++++++++++++-- 2 files changed, 75 insertions(+), 4 deletions(-) create mode 100644 collects/typed-scheme/typecheck/tc-envops.ss diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss new file mode 100644 index 0000000000..ba63189562 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -0,0 +1,44 @@ +#lang scheme/base + +(require (rename-in "../utils/utils.ss" [infer infer-in])) +(require (rename-in (types subtype convenience remove-intersect) + [-> -->] + [->* -->*] + [one-of/c -one-of/c]) + (infer-in infer) + (rep type-rep) + scheme/contract scheme/match + stxclass/util + (for-syntax scheme/base)) + +(define (replace-nth l i f) + (cond [(null? l) (error 'replace-nth "list not long enough" l i f)] + [(zero? i) (cons (f (car l)) (cdr l))] + [else (cons (car l) (replace-nth (cdr l) (sub1 i) f))])) + +(define/contract (update t lo) + (Type/c Filter/c . -> . Type/c) + (match* (t lo) + ;; pair ops + [((Pair: t s) (TypeFilter: u (list* (CarPE:) rst) x)) + (make-Pair (update t (make-TypeFilter u rst x)) s)] + [((Pair: t s) (NotTypeFilter: u (list* (CarPE:) rst) x)) + (make-Pair (update t (make-NotTypeFilter u rst x)) s)] + [((Pair: t s) (TypeFilter: u (list* (CarPE:) rst) x)) + (make-Pair t (update s (make-TypeFilter u rst x)))] + [((Pair: t s) (NotTypeFilter: u (list* (CdrPE:) rst) x)) + (make-Pair t (update s (make-NotTypeFilter u rst x)))] + + ;; struct ops + [((Struct: nm par flds proc poly pred cert) + (TypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) + (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-TypeFilter u rst x)))))] + [((Struct: nm par flds proc poly pred cert) + (NotTypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) + (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-NotTypeFilter u rst x)))))] + + ;; otherwise + [(t (TypeFilter: u (list) _)) + (restrict t u)] + [(t (NotTypeFilter: u (list) _)) + (remove t u)])) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 4081a3ad8d..96258fd04a 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -39,8 +39,8 @@ (lambda (stx) #'(? (lambda (id) (free-identifier=? id x))))) (match f [(Bot:) (list (make-LBot))] - [(TypeFilter: t p (=x)) (list (make-LTypeFilter t p))] - [(NotTypeFilter: t p (=x)) (list (make-LNotTypeFilter t p))] + [(TypeFilter: t p (=x)) (list (make-LTypeFilter t p idx))] + [(NotTypeFilter: t p (=x)) (list (make-LNotTypeFilter t p idx))] [_ null])) (define/contract (apply-filter lfs t o) @@ -58,5 +58,32 @@ [((LNotTypeFilter: (? (lambda (t) (subtype s t))) (list) _) _ _) (list (make-Bot))] [((LTypeFilter: (? (lambda (t) (not (overlap s t)))) (list) _) _ _) (list (make-Bot))] [(_ _ (Empty:)) null] - [((LTypeFilter: t pi* _) _ (Path: pi x)) (make-TypeFilter t (append pi* pi) x)] - [((LNotTypeFilter: t pi* _) _ (Path: pi x)) (make-NotTypeFilter t (append pi* pi) x)])) \ No newline at end of file + [((LTypeFilter: t pi* _) _ (Path: pi x)) (list (make-TypeFilter t (append pi* pi) x))] + [((LNotTypeFilter: t pi* _) _ (Path: pi x)) (list (make-NotTypeFilter t (append pi* pi) x))])) + +(define-match-expander T-FS: + (lambda (stx) #'(FilterSet: _ (list (Bot:))))) +(define-match-expander F-FS: + (lambda (stx) #'(FilterSet: (list (Bot:)) _))) + +(define/contract (combine-filter f1 f2 f3) + (FilterSet? FilterSet? FilterSet? . -> . FilterSet?) + (match* (f1 f2 f3) + [(f (T-FS:) (F-FS:)) f] ;; the student expansion + [((T-FS:) f _) f] + [((F-FS:) _ f) f] + ;; skipping the general or/predicate rule because it's really complicated + ;; or/predicate special case for one elem lists + ;; note that we are relying on equal? on identifiers here + [((FilterSet: (list (TypeFilter: t pi x)) (list (NotTypeFilter: t pi x))) + (T-FS:) + (FilterSet: (list (TypeFilter: s pi x)) (list (NotTypeFilter: s pi x)))) + (make-FilterSet (list (make-TypeFilter (Un t s) pi x)) (list (make-NotTypeFilter (Un t s) pi x)))] + ;; or + [((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (combine null (append f1- f3-))] + ;; and + [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) (combine (append f1+ f2+) null)] + [(f f* f*) f*] + [(_ _ _) + ;; could intersect f2 and f3 here + (make-FilterSet null null)])) \ No newline at end of file From aa32d9b928c7edaf68356775659dde96096b4123 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Mar 2009 21:27:05 +0000 Subject: [PATCH 052/156] fix bugs add env+ svn: r13994 --- collects/typed-scheme/env/lexical-env.ss | 10 +++++----- collects/typed-scheme/env/type-environments.ss | 5 ++++- collects/typed-scheme/typecheck/tc-envops.ss | 11 ++++++++++- 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 04ddc7a93c..9998ad3c99 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -23,8 +23,8 @@ ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifer -> Type -(define (lookup-type/lexical i) - (lookup (lexical-env) i +(define (lookup-type/lexical i [env (lexical-env)]) + (lookup env i (lambda (i) (lookup-type i (lambda () (cond [(lookup (dotted-env) i (lambda _ #f)) @@ -35,7 +35,7 @@ ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment -(define (update-type/lexical f i) +(define (update-type/lexical f i [env (lexical-env)]) ;; do the updating on the given env ;; (identifier type -> type) identifier environment -> environment (define (update f k env) @@ -48,9 +48,9 @@ ;; check if i is ever the target of a set! (if (is-var-mutated? i) ;; if it is, we do nothing - (lexical-env) + env ;; otherwise, refine the type - (update f i (lexical-env)))) + (update f i env))) ;; convenience macro for typechecking in the context of an updated env (define-syntax with-update-type/lexical diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 8095c8063c..57c04ee62c 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -2,12 +2,14 @@ (provide current-tvars extend + env? lookup make-empty-env extend-env extend/values dotted-env initial-tvar-env + env-map with-dotted-env/extend) (require (prefix-in r: "../utils/utils.ss")) @@ -29,7 +31,8 @@ ;; the environment for types of ... variables (define dotted-env (make-parameter (make-empty-env free-identifier=?))) - +(define (env-map f env) + (make-env (env-eq? env) (map f (env-l env)))) ;; extend that works on single arguments (define (extend e k v) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index ba63189562..2b4f8496d4 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -1,12 +1,13 @@ #lang scheme/base (require (rename-in "../utils/utils.ss" [infer infer-in])) -(require (rename-in (types subtype convenience remove-intersect) +(require (rename-in (types subtype convenience remove-intersect union) [-> -->] [->* -->*] [one-of/c -one-of/c]) (infer-in infer) (rep type-rep) + (only-in (env type-environments lexical-env) env? update-type/lexical env-map) scheme/contract scheme/match stxclass/util (for-syntax scheme/base)) @@ -42,3 +43,11 @@ (restrict t u)] [(t (NotTypeFilter: u (list) _)) (remove t u)])) + +(define/contract (env+ env fs) + (env? (listof Filter/c) . -> . env?) + (for/fold ([Γ env]) ([f fs]) + (match f + [(Bot:) (env-map (lambda (_) (Un)) Γ)] + [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) + (update-type/lexical (lambda (x t) (update t f)) x Γ)]))) From 2dbd82e587a87663afacefc5524553c4fc2246ed Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Mar 2009 22:25:19 +0000 Subject: [PATCH 053/156] Add provides Use Type/c instead fo Type? in contracts New if typechecking. match expanders for tc-result. svn: r13996 --- collects/typed-scheme/typecheck/signatures.ss | 30 +++++++------- collects/typed-scheme/typecheck/tc-envops.ss | 2 + .../typecheck/tc-metafunctions.ss | 4 +- collects/typed-scheme/typecheck/tc-new-if.ss | 39 +++++++++++++++++++ collects/typed-scheme/types/utils.ss | 24 +++++++++--- 5 files changed, 77 insertions(+), 22 deletions(-) create mode 100644 collects/typed-scheme/typecheck/tc-new-if.ss diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index ec810d1067..76c69b1b25 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -11,39 +11,39 @@ (define-signature tc-expr^ ([cnt tc-expr (syntax? . -> . tc-result?)] - [cnt tc-expr/check (syntax? Type? . -> . tc-result?)] - [cnt tc-expr/check/t (syntax? Type? . -> . Type?)] - [cnt check-below (->d ([s (or/c Type? tc-result?)] [t Type?]) () [_ (if (Type? s) Type? tc-result?)])] - [cnt tc-literal (any/c . -> . Type?)] + [cnt tc-expr/check (syntax? Type/c . -> . tc-result?)] + [cnt tc-expr/check/t (syntax? Type/c . -> . Type/c)] + [cnt check-below (->d ([s (or/c Type/c tc-result?)] [t Type/c]) () [_ (if (Type/c s) Type/c tc-result?)])] + [cnt tc-literal (any/c . -> . Type/c)] [cnt tc-exprs ((listof syntax?) . -> . tc-result?)] - [cnt tc-exprs/check ((listof syntax?) Type? . -> . tc-result?)] - [cnt tc-expr/t (syntax? . -> . Type?)])) + [cnt tc-exprs/check ((listof syntax?) Type/c . -> . tc-result?)] + [cnt tc-expr/t (syntax? . -> . Type/c)])) (define-signature check-subforms^ ([cnt check-subforms/ignore (syntax? . -> . any)] [cnt check-subforms/with-handlers (syntax? . -> . any)] - [cnt check-subforms/with-handlers/check (syntax? Type? . -> . any)])) + [cnt check-subforms/with-handlers/check (syntax? Type/c . -> . any)])) (define-signature tc-if^ ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/if-twoarm/check (syntax? syntax? syntax? Type? . -> . tc-result?)])) + [cnt tc/if-twoarm/check (syntax? syntax? syntax? Type/c . -> . tc-result?)])) (define-signature tc-lambda^ ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/lambda/check (syntax? syntax? syntax? Type? . -> . tc-result?)] - [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type?) Type? . -> . Type?)])) + [cnt tc/lambda/check (syntax? syntax? syntax? Type/c . -> . tc-result?)] + [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) Type/c . -> . Type/c)])) (define-signature tc-app^ ([cnt tc/app (syntax? . -> . tc-result?)] - [cnt tc/app/check (syntax? Type? . -> . tc-result?)] - [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-result?) (or/c #f Type?) . -> . tc-result?)])) + [cnt tc/app/check (syntax? Type/c . -> . tc-result?)] + [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-result?) (or/c #f Type/c) . -> . tc-result?)])) (define-signature tc-let^ ([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-result?)] [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/let-values/check (syntax? syntax? syntax? syntax? Type? . -> . tc-result?)] - [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? Type? . -> . tc-result?)])) + [cnt tc/let-values/check (syntax? syntax? syntax? syntax? Type/c . -> . tc-result?)] + [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? Type/c . -> . tc-result?)])) (define-signature tc-dots^ - ([cnt tc/dots (syntax? . -> . (values Type? symbol?))])) + ([cnt tc/dots (syntax? . -> . (values Type/c symbol?))])) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index 2b4f8496d4..a7fa27867a 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -12,6 +12,8 @@ stxclass/util (for-syntax scheme/base)) +(provide env+) + (define (replace-nth l i f) (cond [(null? l) (error 'replace-nth "list not long enough" l i f)] [(zero? i) (cons (f (car l)) (cdr l))] diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 96258fd04a..090e60045a 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rename-in (types subtype convenience remove-intersect) +(require (rename-in (types subtype convenience remove-intersect union) [-> -->] [->* -->*] [one-of/c -one-of/c]) @@ -10,6 +10,8 @@ stxclass/util (for-syntax scheme/base)) +(provide combine-filter apply-filter abstract-filter) + ;; this implements the sequence invariant described on the first page relating to Bot (define (lcombine l1 l2) (cond [(memq (make-LBot) l1) diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss new file mode 100644 index 0000000000..95b70021cd --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -0,0 +1,39 @@ +#lang scheme/unit + + +(require (rename-in "../utils/utils.ss" [infer r:infer])) +(require "signatures.ss" + (rep type-rep filter-rep object-rep) + (rename-in (types convenience subtype union utils comparison remove-intersect) + [remove *remove]) + (env lexical-env) + (r:infer infer) + (utils tc-utils mutated-vars) + (typecheck tc-envops tc-metafunctions) + syntax/kerncase + mzlib/trace + mzlib/plt-match) + +;; if typechecking +(import tc-expr^) +(export tc-if^) + +(define (tc/if-twoarm tst thn els [expected #f]) + (define (tc e) (if expected (tc-expr/check e expected) (tc-expr e))) + (match (tc-expr tst) + [(list (tc-result: _ (and f1 (FilterSet: fs+ fs-)) _)) + (match-let ([(tc-results: ts fs2 _) (with-lexical-env (env+ (lexical-env) fs+) (tc thn))] + [(tc-results: us fs3 _) (with-lexical-env (env+ (lexical-env) fs-) (tc els))]) + ;; if we have the same number of values in both cases + (cond [(= (length ts) (length us)) + (for/list ([t ts] [u us] [f2 fs2] [f3 fs3]) + (ret (Un t u) (combine-filter f1 f2 f2)))] + [else + (tc-error/expr #:ret (ret Err) + "Expected the same number of values from both branches of if expression, but got ~a and ~a" + (length ts) (length us))]))] + [(tc-results: t _ _) + (tc-error/expr #:ret (ret (or expected Err)) + "Test expression expects one value, given ~a" t)])) + +(define tc/if-twoarm/check tc/if-twoarm) \ No newline at end of file diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index d92760d7de..202c74149e 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -167,6 +167,17 @@ ;; this structure represents the result of typechecking an expression (d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent) +(define-struct tc-result (t f o) #:transparent #:omit-define-values) + +(define-match-expander tc-result: + (syntax-parser + [(_ tp fp op) #'(struct tc-result (tp fp op))])) + +(define-match-expander tc-results: + (syntax-parser + [(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))])) + +(provide tc-result: tc-results:) ;; convenience function for returning the result of typechecking an expression (define ret @@ -175,7 +186,10 @@ (list (make-tc-result t (make-FilterSet null null) (make-Empty))) (for/list ([i t]) (make-tc-result i (make-FilterSet null null) (make-Empty))))] - [(t f) (error 'ret "two arguments not supported")] + [(t f) (if (Type? t) + (list (make-tc-result t f (make-Empty))) + (for/list ([i t] [f f]) + (make-tc-result i f (make-Empty))))] [(t f o) (if (and (list? t) (list? f) (list? o)) (map make-tc-result t f o) @@ -187,11 +201,9 @@ ([f (if (list? t) (listof FilterSet?) FilterSet?)] - [o (if (or (list? f) (FilterSet? f)) - (if (list? t) - (listof Object?) - Object?) - (lambda (e) (eq? e f)))]) + [o (if (list? t) + (listof Object?) + Object?)]) [_ (listof tc-result?)])]) (define (subst v t e) (substitute t v e)) From d1ac259bcc5fc8cf5c9b6a94910b0c42f585dbf6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Mar 2009 23:37:05 +0000 Subject: [PATCH 054/156] try to fix this test svn: r13999 --- collects/tests/typed-scheme/unit-tests/all-tests.ss | 2 +- collects/tests/typed-scheme/unit-tests/type-annotation-test.ss | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index c32dbfea30..32f70592d1 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -4,7 +4,7 @@ "test-utils.ss" "planet-requires.ss" ;"typecheck-tests.ss" ;; doesn't compile yet - "subtype-tests.ss" ;; fail + "subtype-tests.ss" ;; pass "type-equal-tests.ss" ;; pass "remove-intersect-tests.ss" ;; pass "parse-type-tests.ss" ;; pass diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index c228501b60..12992f649c 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) -(require (private type-annotation parse-type) +(require (private type-annotation parse-type base-types) (types convenience) (env type-environments type-name-env init-envs) (utils tc-utils) @@ -18,6 +18,7 @@ (namespace-attach-module ons 'scheme/base ns) (namespace-require 'scheme/base) (namespace-require 'typed-scheme/private/prims) + (namespace-require 'typed-scheme/private/base-types) (expand 'ann-stx)))) ty)) From 18e03efc840e0df5dec1a6333a0d6ba42fc10bb1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 7 Mar 2009 22:51:54 +0000 Subject: [PATCH 055/156] New true-filter and false-filter abbrevs Fix for Stevie's d-s/c fix. tc-expr now compiles svn: r14007 --- .../typed-scheme/typecheck/tc-expr-unit.ss | 37 ++++++++++++------- collects/typed-scheme/types/abbrev.ss | 4 ++ collects/typed-scheme/types/utils.ss | 7 ++-- 3 files changed, 31 insertions(+), 17 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 133e87c649..d83daf0dd4 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -1,14 +1,14 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [private r:private])) +(require (rename-in "../utils/utils.ss" [private private-in])) (require syntax/kerncase scheme/match "signatures.ss" - (r:private type-utils type-effect-convenience union subtype - parse-type type-annotation stxclass-util) - (rep type-rep effect-rep) - (utils tc-utils) + (types utils convenience union subtype) + (private-in parse-type type-annotation) + (rep type-rep) + (utils tc-utils stxclass-util) (env lexical-env) (only-in (env type-environments) lookup current-tvars extend-env) scheme/private/class-internal @@ -23,12 +23,18 @@ ;; return the type of a literal value ;; scheme-value -> type -(define (tc-literal v-stx) +(define (tc-literal v-stx [expected #f]) + (define-syntax-class exp + (pattern i + #:when expected + #:with datum (syntax-e #'i) + #:when (subtype (-val #'datum) expected))) (syntax-parse v-stx + [i:exp expected] [i:boolean (-val #'i.datum)] [i:identifier (-val #'i.datum)] [i:exact-integer -Integer] - [i:number N] + [i:number -Number] [i:str -String] [i:char -Char] [i:keyword (-val #'i.datum)] @@ -99,12 +105,15 @@ ;; tc-id : identifier -> tc-result (define (tc-id id) (let* ([ty (lookup-type/lexical id)]) - (ret ty (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id))))) + (ret ty + (make-LFilterSet (list (make-NotTypeFilter (-val #f) null id)) + (list (make-TypeFilter (-val #f) null id))) + (make-Path null id)))) ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) - [(tc-result: t) t] + [(tc-result: t _ _) t] [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) (define (tc-expr/check/t e t) @@ -148,9 +157,9 @@ (int-err "internal error: ignore-some")) (check-below ty expected))] ;; data - [(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))] - [(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))] - [(quote val) (ret (tc-literal #'val))] + [(quote #f) (ret (-val #f) false-filter)] + [(quote #t) (ret (-val #t) true-filter)] + [(quote val) (ret (tc-literal #'val expected))] ;; syntax [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))] ;; mutation! @@ -232,8 +241,8 @@ ty)] ;; data - [(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))] - [(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))] + [(quote #f) (ret (-val #f) false-filter)] + [(quote #t) (ret (-val #t) true-filter)] [(quote val) (ret (tc-literal #'val))] ;; syntax diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 5db79868df..9db1bd41f2 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -24,6 +24,7 @@ (define -box make-Box) (define -vec make-Vector) (define -LFS make-LFilterSet) +(define -FS make-FilterSet) (define-syntax *Un (syntax-rules () @@ -251,6 +252,9 @@ (->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))] [(t) (make-pred-ty (list Univ) -Boolean t)])) +(define true-filter (-FS (list) (list (make-Bot)))) +(define false-filter (-FS (list (make-Bot)) (list))) + (define (opt-fn args opt-args result) (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 202c74149e..ca955b60a2 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -167,15 +167,16 @@ ;; this structure represents the result of typechecking an expression (d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent) -(define-struct tc-result (t f o) #:transparent #:omit-define-values) (define-match-expander tc-result: (syntax-parser - [(_ tp fp op) #'(struct tc-result (tp fp op))])) + [(_ tp fp op) #'(struct tc-result (tp fp op))] + [(_ tp) #'(struct tc-result (tp _ _))])) (define-match-expander tc-results: (syntax-parser - [(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))])) + [(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))] + [(_ tp) #'(list (struct tc-result (tp _ _)) (... ...))])) (provide tc-result: tc-results:) From 8b7497cccfa8dcc264bf16f90641f2f3f99084b2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 7 Mar 2009 23:19:41 +0000 Subject: [PATCH 056/156] everything except lambda, app units work svn: r14008 --- .../typecheck/check-subforms-unit.ss | 4 ++-- .../typed-scheme/typecheck/defstruct-unit.ss | 21 ------------------- .../typed-scheme/typecheck/tc-dots-unit.ss | 2 +- .../typed-scheme/typecheck/tc-let-unit.ss | 3 ++- 4 files changed, 5 insertions(+), 25 deletions(-) delete mode 100644 collects/typed-scheme/typecheck/defstruct-unit.ss diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss index 3dd9208d83..3e93d5eaa3 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -4,7 +4,7 @@ (require syntax/kerncase scheme/match "signatures.ss" - (private type-utils type-effect-convenience union subtype) + (types utils convenience union subtype) (utils tc-utils) (rep type-rep)) @@ -18,7 +18,7 @@ (define body-ty #f) (define (get-result-ty t) (match t - [(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)] + [(Function: (list (arr: _ (Values: (list (Result: rngs _ _))) #f _ '()) ...)) (apply Un rngs)] [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)])) (let loop ([form form]) (parameterize ([current-orig-stx form]) diff --git a/collects/typed-scheme/typecheck/defstruct-unit.ss b/collects/typed-scheme/typecheck/defstruct-unit.ss deleted file mode 100644 index 3fed9fb241..0000000000 --- a/collects/typed-scheme/typecheck/defstruct-unit.ss +++ /dev/null @@ -1,21 +0,0 @@ -#lang scheme/base -(require mzlib/struct mzlib/unit) -(provide #;(all-defined)) - -(define-syntax defstructs/sig/unit - (syntax-rules (define-struct/properties) - [(_ signame unitname (imps ...) - def - (define-struct/properties nm1 (flds1 ...) props #f) - (define-struct/properties (nm par) (flds ...) () #f) ...) - (begin - (define-signature signame - ((struct nm1 (flds1 ...)) - (struct nm (flds ...)) ...)) - (define-unit unitname - (import imps ...) - (export signame) - def - (define-struct/properties nm1 (flds1 ...) props #f) - (define-struct (nm par) (flds ...) #f) ...))])) - diff --git a/collects/typed-scheme/typecheck/tc-dots-unit.ss b/collects/typed-scheme/typecheck/tc-dots-unit.ss index 2aa1b38220..eb5e9c2f3a 100644 --- a/collects/typed-scheme/typecheck/tc-dots-unit.ss +++ b/collects/typed-scheme/typecheck/tc-dots-unit.ss @@ -4,7 +4,7 @@ (require "signatures.ss" (utils tc-utils) (env type-environments) - (private type-utils) + (types utils) (rep type-rep) syntax/kerncase scheme/match) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 9bf2bf3fa7..c8a3a1ce10 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -2,7 +2,8 @@ (require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - (private type-effect-convenience type-annotation parse-type type-utils) + (types utils convenience) + (private type-annotation parse-type) (env lexical-env type-alias-env type-env) syntax/free-vars mzlib/trace From 058e78ab17c0b749196849660d3d580c08df6c9a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 11 Mar 2009 00:15:13 +0000 Subject: [PATCH 057/156] tc-lambda-unit now compiles generalize tc-results to handle drest svn: r14044 --- .../typed-scheme/typecheck/tc-lambda-unit.ss | 56 +++++++------------ collects/typed-scheme/types/utils.ss | 36 +++++++----- 2 files changed, 42 insertions(+), 50 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index d0d4d7244b..8dd8e447b4 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -4,28 +4,30 @@ (require "signatures.ss" mzlib/trace scheme/list - (except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests - (private type-effect-convenience type-annotation union type-utils) + (rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c]) + (except-in (rep type-rep) make-arr) + (rename-in (types convenience utils union) + [make-arr* make-arr]) + (private type-annotation) (env type-environments lexical-env) (utils tc-utils) - mzlib/plt-match - (only-in (private type-effect-convenience) [make-arr* make-arr])) + mzlib/plt-match) (require (for-template scheme/base "internal-forms.ss")) (import tc-expr^) (export tc-lambda^) -(define (remove-var id thns elss) - (let/ec exit - (define (fail) (exit #f)) - (define (rv e) - (match e - [(Var-True-Effect: v) (if (free-identifier=? v id) (make-Latent-Var-True-Effect) (fail))] - [(Var-False-Effect: v) (if (free-identifier=? v id) (make-Latent-Var-False-Effect) (fail))] - [(or (True-Effect:) (False-Effect:)) e] - [(Restrict-Effect: t v) (if (free-identifier=? v id) (make-Latent-Restrict-Effect t) (fail))] - [(Remove-Effect: t v) (if (free-identifier=? v id) (make-Latent-Remove-Effect t) (fail))])) - (cons (map rv thns) (map rv elss)))) +(d-s/c lam-result ([args (listof (list identifier? Type/c))] + [kws (listof (list keyword? Type/c boolean?))] + [rest (or/c #f Type/c)] + [drest (or/c #f (cons symbol? Type/c))] + [body (listof tc-result?)]) + #:transparent) + +(d/c (abstract-filters lr) + (--> lam-result? arr?) + (when (and rest drest) + (int-err 'abstract-filters "rest and drest both provided"))) (define (expected-str tys-len rest-ty drest arg-len rest) (format "Expected function with ~a argument~a~a, but got function with ~a argument~a~a" @@ -56,15 +58,7 @@ arg-list arg-types (match (tc-exprs/check (syntax->list body) ret-ty) [(tc-result: t thn els) - (cond - ;; this is T-AbsPred - ;; if this function takes only one argument, and all the effects are about that one argument - [(and (not rest-ty) (not drest) (= 1 (length arg-list)) (remove-var (car arg-list) thn els)) - => (lambda (thn/els) (make-arr arg-types t rest-ty drest (car thn/els) (cdr thn/els)))] - ;; otherwise, the simple case - [else (make-arr arg-types t rest-ty drest null null)])] - [t (int-err "bad match - not a tc-result: ~a ~a ~a" t ret-ty (syntax->datum body))]))) - #;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list) + (make-arr arg-types t rest-ty drest null null)]))) (when (or (not (= arg-len tys-len)) (and rest (and (not rest-ty) (not drest)))) @@ -109,23 +103,13 @@ [(args ...) (let* ([arg-list (syntax->list #'(args ...))] [arg-types (get-types arg-list #:default Univ)]) - #;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list) (with-lexical-env/extend arg-list arg-types (match (tc-exprs (syntax->list body)) - [(tc-result: t thn els) - (cond - ;; this is T-AbsPred - ;; if this function takes only one argument, and all the effects are about that one argument - [(and (= 1 (length arg-list)) (remove-var (car arg-list) thn els)) - => (lambda (thn/els) (make-arr arg-types t #f (car thn/els) (cdr thn/els)))] - ;; otherwise, the simple case - [else (make-arr arg-types t)])] - [t (int-err "bad match - not a tc-result: ~a no ret-ty" t)])))] + [(tc-result: t thn els) (make-arr arg-types t)])))] [(args ... . rest) (let* ([arg-list (syntax->list #'(args ...))] [arg-types (get-types arg-list #:default Univ)]) - #;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) (cons #'rest arg-list)) (cond [(dotted? #'rest) => @@ -175,7 +159,7 @@ (let loop ([expected expected]) (match expected [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests '() _ _) ...)) + [(Function: (list (arr: argss rets rests drests '()) ...)) (for ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest)) expected] diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index ca955b60a2..43e20803db 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -167,6 +167,7 @@ ;; this structure represents the result of typechecking an expression (d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent) +(d-s/c tc-results ([ts (listof tc-result?)] [drest (or/c (cons/c symbol? Type/c) #f)])) (define-match-expander tc-result: (syntax-parser @@ -175,26 +176,33 @@ (define-match-expander tc-results: (syntax-parser - [(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))] - [(_ tp) #'(list (struct tc-result (tp _ _)) (... ...))])) + [(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) #f))] + [(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) #f))])) (provide tc-result: tc-results:) ;; convenience function for returning the result of typechecking an expression (define ret (case-lambda [(t) - (if (Type? t) - (list (make-tc-result t (make-FilterSet null null) (make-Empty))) - (for/list ([i t]) - (make-tc-result i (make-FilterSet null null) (make-Empty))))] - [(t f) (if (Type? t) - (list (make-tc-result t f (make-Empty))) - (for/list ([i t] [f f]) - (make-tc-result i f (make-Empty))))] - [(t f o) - (if (and (list? t) (list? f) (list? o)) - (map make-tc-result t f o) - (list (make-tc-result t f o)))])) + (make-tc-results + (if (Type? t) + (list (make-tc-result t (make-FilterSet null null) (make-Empty))) + (for/list ([i t]) + (make-tc-result i (make-FilterSet null null) (make-Empty)))) + #f)] + [(t f) + (make-tc-results + (if (Type? t) + (list (make-tc-result t f (make-Empty))) + (for/list ([i t] [f f]) + (make-tc-result i f (make-Empty)))) + #f)] + [(t f o) + (make-tc-results + (if (and (list? t) (list? f) (list? o)) + (map make-tc-result t f o) + (list (make-tc-result t f o))) + #f)])) (p/c [ret From c51dd1e8b058b99367a7a0fb8df4135f04cfcd4c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 11 Mar 2009 19:11:50 +0000 Subject: [PATCH 058/156] new version of abstract-filters that handles multiple values/arguments properly strengthen contracts improve match expanders svn: r14057 --- collects/typed-scheme/rep/object-rep.ss | 4 +- .../typecheck/tc-metafunctions.ss | 48 ++++++++++++++----- collects/typed-scheme/types/utils.ss | 5 +- 3 files changed, 42 insertions(+), 15 deletions(-) diff --git a/collects/typed-scheme/rep/object-rep.ss b/collects/typed-scheme/rep/object-rep.ss index 4a6f10a28c..afd87e320e 100644 --- a/collects/typed-scheme/rep/object-rep.ss +++ b/collects/typed-scheme/rep/object-rep.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss") +(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss" "filter-rep.ss") (dpe CarPE () [#:fold-rhs #:base]) (dpe CdrPE () [#:fold-rhs #:base]) @@ -17,6 +17,6 @@ (dlo LEmpty () [#:fold-rhs #:base]) -(dlo LPath ([p (listof PathElem?)] [idx natural-number/c]) +(dlo LPath ([p (listof PathElem?)] [idx index/c]) [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] [#:fold-rhs (*LPath (map pathelem-rec-id p) idx)]) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 090e60045a..350e7d378f 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rename-in (types subtype convenience remove-intersect union) +(require (rename-in (types subtype convenience remove-intersect union utils) [-> -->] [->* -->*] [one-of/c -one-of/c]) @@ -27,22 +27,48 @@ (make-FilterSet null (list (make-Bot)))] [else (make-FilterSet l1 l2)])) -(define/contract (abstract-filter x idx fs) - (-> identifier? index/c FilterSet? LFilterSet?) +(d/c (abstract-filters keys ids results) + (-> (listof index/c) (listof identifier?) tc-results? (or/c Values? ValuesDots?)) + (define (mk l [drest #f]) + (if drest (make-ValuesDots l (car drest) (cdr drest)) (make-Values l))) + (match results + [(tc-results: ts fs os dty dbound) + (make-ValuesDots + (for/list ([t ts] + [f fs] + [o os]) + (make-Result t (abstract-filter ids keys f) (abstract-object ids keys o))))])) + +(define/contract (abstract-object ids keys o) + (-> (listof identifier?) (listof index/c) Object? LatentObject?) + (define (lookup y) + (for/first ([x ids] [i keys] #:when (free-identifier=? x y)) i)) + (define-match-expander lookup: + (syntax-rules () + [(_ i) (app lookup (? values i))])) + (match o + [(Path: p (lookup: idx)) (make-LPath p idx)] + [_ (make-LEmpty)])) + +(define/contract (abstract-filter ids keys fs) + (-> (listof identifier?) (listof index/c) FilterSet? LFilterSet?) (match fs [(FilterSet: f+ f-) (lcombine - (apply append (for/list ([f f+]) (abo x idx f))) - (apply append (for/list ([f f-]) (abo x idx f))))])) + (apply append (for/list ([f f+]) (abo ids keys f))) + (apply append (for/list ([f f-]) (abo ids keys f))))])) -(define/contract (abo x idx f) - (-> identifier? index/c Filter/c (or/c '() (list/c LatentFilter/c))) - (define-match-expander =x - (lambda (stx) #'(? (lambda (id) (free-identifier=? id x))))) +(define/contract (abo xs idxs f) + (-> (listof identifier?) (listof index/c) Filter/c (or/c '() (list/c LatentFilter/c))) + (define (lookup y) + (for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) i)) + (define-match-expander lookup: + (syntax-rules () + [(_ i) (app lookup (? values i))])) (match f [(Bot:) (list (make-LBot))] - [(TypeFilter: t p (=x)) (list (make-LTypeFilter t p idx))] - [(NotTypeFilter: t p (=x)) (list (make-LNotTypeFilter t p idx))] + [(TypeFilter: t p (lookup: idx)) (list (make-LTypeFilter t p idx))] + [(NotTypeFilter: t p (lookup: idx)) (list (make-LNotTypeFilter t p idx))] [_ null])) (define/contract (apply-filter lfs t o) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 43e20803db..0c4af4ee67 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -167,7 +167,7 @@ ;; this structure represents the result of typechecking an expression (d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent) -(d-s/c tc-results ([ts (listof tc-result?)] [drest (or/c (cons/c symbol? Type/c) #f)])) +(d-s/c tc-results ([ts (listof tc-result?)] [drest (or/c (cons/c Type/c symbol?) #f)]) #:transparent) (define-match-expander tc-result: (syntax-parser @@ -177,9 +177,10 @@ (define-match-expander tc-results: (syntax-parser [(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) #f))] + [(_ tp fp op dty dbound) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) (cons dty dbound)))] [(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) #f))])) -(provide tc-result: tc-results:) +(provide tc-result: tc-results: tc-result? tc-results?) ;; convenience function for returning the result of typechecking an expression (define ret From c4f5fd3773100a15690ef37c1f3f7b331db64d03 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 12 Mar 2009 15:27:24 +0000 Subject: [PATCH 059/156] more work on lambda svn: r14073 --- .../typed-scheme/typecheck/tc-lambda-unit.ss | 69 ++++++++++++------- .../typecheck/tc-metafunctions.ss | 9 ++- 2 files changed, 53 insertions(+), 25 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 8dd8e447b4..d443fd77bc 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -2,8 +2,10 @@ (require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" + "tc-metafunctions.ss" mzlib/trace scheme/list + stxclass/util (rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c]) (except-in (rep type-rep) make-arr) (rename-in (types convenience utils union) @@ -18,16 +20,22 @@ (export tc-lambda^) (d-s/c lam-result ([args (listof (list identifier? Type/c))] - [kws (listof (list keyword? Type/c boolean?))] + [kws (listof (list keyword? identifier? Type/c boolean?))] [rest (or/c #f Type/c)] [drest (or/c #f (cons symbol? Type/c))] - [body (listof tc-result?)]) + [body tc-results?]) #:transparent) -(d/c (abstract-filters lr) - (--> lam-result? arr?) - (when (and rest drest) - (int-err 'abstract-filters "rest and drest both provided"))) +(define (lam-result->type lr) + (match lr + [(struct lam-result ((list (list arg-ids arg-tys) ...) (list (list kw kw-id kw-ty req?) ...) rest drest body)) + (make-arr arg-tys + (abstract-filters (append (for/list ([i (in-naturals)] [_ arg-ids]) i) kw) + (append arg-ids kw-id) + body) + #:kws (map make-Keyword kw kw-ty req?) + #:rest rest + #:drest drest)])) (define (expected-str tys-len rest-ty drest arg-len rest) (format "Expected function with ~a argument~a~a, but got function with ~a argument~a~a" @@ -41,7 +49,7 @@ (if (= arg-len 1) "" "s") (if rest " and a rest arg" ""))) -;; listof[id] option[id] block listof[type] option[type] option[(cons type var)] type +;; listof[id] option[id] block listof[type] option[type] option[(cons type var)] type -> lam-result (define (check-clause arg-list rest body arg-tys rest-ty drest ret-ty) (let* ([arg-len (length arg-list)] [tys-len (length arg-tys)] @@ -56,9 +64,8 @@ (define (check-body) (with-lexical-env/extend arg-list arg-types - (match (tc-exprs/check (syntax->list body) ret-ty) - [(tc-result: t thn els) - (make-arr arg-types t rest-ty drest null null)]))) + (make lam-result (map list arg-list arg-types) null rest-ty drest + (tc-exprs/check (syntax->list body) ret-ty)))) (when (or (not (= arg-len tys-len)) (and rest (and (not rest-ty) (not drest)))) @@ -89,7 +96,7 @@ ;; typecheck a single lambda, with argument list and body ;; drest-ty and drest-bound are both false or not false -;; syntax-list[id] block listof[type] type option[type] option[(cons type var)] -> arr +;; syntax-list[id] block listof[type] type option[type] option[(cons type var)] -> lam-result (define (tc/lambda-clause/check args body arg-tys ret-ty rest-ty drest) (syntax-case args () [(args* ...) @@ -97,7 +104,7 @@ [(args* ... . rest) (check-clause (syntax->list #'(args* ...)) #'rest body arg-tys rest-ty drest ret-ty)])) -;; syntax-list[id] block -> arr +;; syntax-list[id] block -> lam-result (define (tc/lambda-clause args body) (syntax-case args () [(args ...) @@ -105,8 +112,12 @@ [arg-types (get-types arg-list #:default Univ)]) (with-lexical-env/extend arg-list arg-types - (match (tc-exprs (syntax->list body)) - [(tc-result: t thn els) (make-arr arg-types t)])))] + (make lam-result + (map list arg-list arg-types) + null + #f + #f + (tc-exprs (syntax->list body)))))] [(args ... . rest) (let* ([arg-list (syntax->list #'(args ...))] [arg-types (get-types arg-list #:default Univ)]) @@ -129,19 +140,30 @@ (parameterize ([dotted-env (extend-env (list #'rest) (list (cons rest-type bound)) (dotted-env))]) - (match-let ([(tc-result: t thn els) (tc-exprs (syntax->list body))]) - (make-arr-dots arg-types t rest-type bound))))))] + (make lam-result + (map list arg-list arg-types) + null + #f + (cons bound rest-type) + (tc-exprs (syntax->list body)))))))] [else (let ([rest-type (get-type #'rest #:default Univ)]) (with-lexical-env/extend (cons #'rest arg-list) (cons (make-Listof rest-type) arg-types) - (match-let ([(tc-result: t thn els) (tc-exprs (syntax->list body))]) - (make-arr arg-types t rest-type))))]))])) + (make lam-result + (map list arg-list arg-types) + null + rest-type + #f + (tc-exprs (syntax->list body)))))]))])) + + +;; FIXED TO HERE ;(trace tc-args) -;; tc/mono-lambda : syntax-list syntax-list -> Funty +;; tc/mono-lambda : syntax-list syntax-list -> (listof lam-result) ;; typecheck a sequence of case-lambda clauses (define (tc/mono-lambda formals bodies expected) (define (syntax-len s) @@ -159,10 +181,9 @@ (let loop ([expected expected]) (match expected [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests '()) ...)) - (for ([args argss] [ret rets] [rest rests] [drest drests]) - (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest)) - expected] + [(Function: (list (arr: argss rets rests drests '()) ...)) + (for/list ([args argss] [ret rets] [rest rests] [drest drests]) + (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))] [t (let ([t (tc/mono-lambda formals bodies #f)]) (check-below t expected))])) (let loop ([formals (syntax->list formals)] @@ -172,7 +193,7 @@ [nums-seen null]) (cond [(null? formals) - (make-Function (map tc/lambda-clause (reverse formals*) (reverse bodies*)))] + (map tc/lambda-clause (reverse formals*) (reverse bodies*))] [(memv (syntax-len (car formals)) nums-seen) ;; we check this clause, but it doesn't contribute to the overall type (tc/lambda-clause (car formals) (car bodies)) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 350e7d378f..e9ba260829 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -10,7 +10,7 @@ stxclass/util (for-syntax scheme/base)) -(provide combine-filter apply-filter abstract-filter) +(provide combine-filter apply-filter abstract-filter abstract-filters) ;; this implements the sequence invariant described on the first page relating to Bot (define (lcombine l1 l2) @@ -34,6 +34,13 @@ (match results [(tc-results: ts fs os dty dbound) (make-ValuesDots + (for/list ([t ts] + [f fs] + [o os]) + (make-Result t (abstract-filter ids keys f) (abstract-object ids keys o))) + dty dbound)] + [(tc-results: ts fs os) + (make-Values (for/list ([t ts] [f fs] [o os]) From 537d267314bbf5e74230460874b9af89a43bfacf Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 16 Mar 2009 15:28:29 +0000 Subject: [PATCH 060/156] disable application checking, `3' now typechecks svn: r14128 --- collects/typed-scheme/typecheck/signatures.ss | 34 +++++++++---------- .../typed-scheme/typecheck/tc-expr-unit.ss | 30 ++++++++++------ .../typed-scheme/typecheck/tc-lambda-unit.ss | 6 ++-- .../typed-scheme/typecheck/tc-new-app-unit.ss | 18 ++++++++++ .../typed-scheme/typecheck/tc-toplevel.ss | 2 +- .../typed-scheme/typecheck/typechecker.ss | 4 +-- collects/typed-scheme/types/utils.ss | 9 +++-- 7 files changed, 67 insertions(+), 36 deletions(-) create mode 100644 collects/typed-scheme/typecheck/tc-new-app-unit.ss diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index 76c69b1b25..c68b5e95e1 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -10,13 +10,13 @@ [cnt tc-toplevel-form (syntax? . -> . any)])) (define-signature tc-expr^ - ([cnt tc-expr (syntax? . -> . tc-result?)] - [cnt tc-expr/check (syntax? Type/c . -> . tc-result?)] + ([cnt tc-expr (syntax? . -> . tc-results?)] + [cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)] [cnt tc-expr/check/t (syntax? Type/c . -> . Type/c)] - [cnt check-below (->d ([s (or/c Type/c tc-result?)] [t Type/c]) () [_ (if (Type/c s) Type/c tc-result?)])] - [cnt tc-literal (any/c . -> . Type/c)] - [cnt tc-exprs ((listof syntax?) . -> . tc-result?)] - [cnt tc-exprs/check ((listof syntax?) Type/c . -> . tc-result?)] + [cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])] + ;[cnt tc-literal (any/c . -> . Type/c)] + [cnt tc-exprs ((listof syntax?) . -> . tc-results?)] + [cnt tc-exprs/check ((listof syntax?) Type/c . -> . tc-results?)] [cnt tc-expr/t (syntax? . -> . Type/c)])) (define-signature check-subforms^ @@ -25,24 +25,24 @@ [cnt check-subforms/with-handlers/check (syntax? Type/c . -> . any)])) (define-signature tc-if^ - ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/if-twoarm/check (syntax? syntax? syntax? Type/c . -> . tc-result?)])) + ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-results?)] + [cnt tc/if-twoarm/check (syntax? syntax? syntax? Type/c . -> . tc-results?)])) (define-signature tc-lambda^ - ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/lambda/check (syntax? syntax? syntax? Type/c . -> . tc-result?)] + ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-results?)] + [cnt tc/lambda/check (syntax? syntax? syntax? Type/c . -> . tc-results?)] [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) Type/c . -> . Type/c)])) (define-signature tc-app^ - ([cnt tc/app (syntax? . -> . tc-result?)] - [cnt tc/app/check (syntax? Type/c . -> . tc-result?)] - [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-result?) (or/c #f Type/c) . -> . tc-result?)])) + ([cnt tc/app (syntax? . -> . tc-results?)] + [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)] + [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-results?) (or/c #f Type/c) . -> . tc-results?)])) (define-signature tc-let^ - ([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-result?)] - [cnt tc/let-values/check (syntax? syntax? syntax? syntax? Type/c . -> . tc-result?)] - [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? Type/c . -> . tc-result?)])) + ([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-results?)] + [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-results?)] + [cnt tc/let-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)] + [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)])) (define-signature tc-dots^ ([cnt tc/dots (syntax? . -> . (values Type/c symbol?))])) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index d83daf0dd4..ae1ebf768d 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -3,7 +3,7 @@ (require (rename-in "../utils/utils.ss" [private private-in])) (require syntax/kerncase - scheme/match + scheme/match (prefix-in - scheme/contract) "signatures.ss" (types utils convenience union subtype) (private-in parse-type type-annotation) @@ -23,7 +23,8 @@ ;; return the type of a literal value ;; scheme-value -> type -(define (tc-literal v-stx [expected #f]) +(d/c (tc-literal v-stx [expected #f]) + (-->* (syntax?) ((-or/c #f Type/c)) Type/c) (define-syntax-class exp (pattern i #:when expected @@ -45,7 +46,7 @@ [(i ...) (-Tuple (map tc-literal (syntax->list #'(i ...))))] [i #:declare i (3d vector?) - (make-Vector (apply Un (map tc-literal (vector->list #'i.datum))))] + (make-Vector (apply Un (map tc-literal (vector->list #'i.datum))))] [_ Univ])) @@ -120,15 +121,20 @@ (match (tc-expr/check e t) [(tc-result: t) t])) -;; check-below : (/\ (Result Type -> Result) +;; check-below : (/\ (Results Type -> Result) +;; (Results Results -> Result) ;; (Type Type -> Type)) (define (check-below tr1 expected) - (match (list tr1 expected) - [(list (tc-result: t1 te1 ee1) t2) + (match* (tr1 expected) + [((tc-results: t1) (tc-results: t2)) + (unless (andmap subtype t1 t2) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (ret expected)] + [((tc-result1: t1) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) (ret expected)] - [(list t1 t2) + [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr"Expected ~a, but got ~a" t2 t1)) expected])) @@ -159,7 +165,9 @@ ;; data [(quote #f) (ret (-val #f) false-filter)] [(quote #t) (ret (-val #t) true-filter)] - [(quote val) (ret (tc-literal #'val expected))] + [(quote val) (match expected + [(tc-result1: t) + (ret (tc-literal #'val t))])] ;; syntax [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))] ;; mutation! @@ -314,9 +322,9 @@ (tc-expr/check form ann))] [else (internal-tc-expr form)])]) (match ty - [(tc-result: t eff1 eff2) - (let ([ty* (do-inst form t)]) - (ret ty* eff1 eff2))])))) + [(tc-results: ts fs os) + (let ([ts* (do-inst form ts)]) + (ret ts fs os))])))) (define (tc/send rcvr method args [expected #f]) (match (tc-expr rcvr) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index d443fd77bc..c6dbd98474 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -19,10 +19,10 @@ (import tc-expr^) (export tc-lambda^) -(d-s/c lam-result ([args (listof (list identifier? Type/c))] - [kws (listof (list keyword? identifier? Type/c boolean?))] +(d-s/c lam-result ([args (listof (list/c identifier? Type/c))] + [kws (listof (list/c keyword? identifier? Type/c boolean?))] [rest (or/c #f Type/c)] - [drest (or/c #f (cons symbol? Type/c))] + [drest (or/c #f (cons/c symbol? Type/c))] [body tc-results?]) #:transparent) diff --git a/collects/typed-scheme/typecheck/tc-new-app-unit.ss b/collects/typed-scheme/typecheck/tc-new-app-unit.ss new file mode 100644 index 0000000000..a29568b275 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-new-app-unit.ss @@ -0,0 +1,18 @@ +#lang scheme/unit + +(require "signatures.ss" "../utils/utils.ss") +(require (utils tc-utils)) + +(import tc-expr^ tc-lambda^ tc-dots^) +(export tc-app^) + +(define (tc/app . args) + (int-err "tc/app NYI")) + +(define (tc/app/check . args) + (int-err "tc/app/check NYI")) + +(define (tc/funapp . args) + (int-err "tc/funapp NYI")) + + diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 937568aab1..fce1a1a30e 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -161,7 +161,7 @@ [(define-values (var ...) expr) (let* ([vars (syntax->list #'(var ...))] [ts (map lookup-type vars)]) - (tc-expr/check #'expr (-values ts))) + (tc-expr/check #'expr (ret ts))) (void)] ;; to handle the top-level, we have to recur into begins diff --git a/collects/typed-scheme/typecheck/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss index ed935ff901..2f41a66a9e 100644 --- a/collects/typed-scheme/typecheck/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -5,11 +5,11 @@ mzlib/trace (only-in scheme/unit provide-signature-elements) "signatures.ss" "tc-toplevel.ss" - "tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss" + "tc-new-if.ss" "tc-lambda-unit.ss" "tc-new-app-unit.ss" "tc-let-unit.ss" "tc-dots-unit.ss" "tc-expr-unit.ss" "check-subforms-unit.ss") (provide-signature-elements typechecker^ tc-expr^) (define-values/link-units/infer - tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@) + tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-new-app@ tc-let@ tc-expr@ check-subforms@) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 0c4af4ee67..facbcf88ad 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -180,7 +180,12 @@ [(_ tp fp op dty dbound) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) (cons dty dbound)))] [(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) #f))])) -(provide tc-result: tc-results: tc-result? tc-results?) +(define-match-expander tc-result1: + (syntax-parser + [(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op))) #f))] + [(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _))) #f))])) + +(provide tc-result: tc-results: tc-result1: tc-result? tc-results?) ;; convenience function for returning the result of typechecking an expression (define ret @@ -214,7 +219,7 @@ [o (if (list? t) (listof Object?) Object?)]) - [_ (listof tc-result?)])]) + [_ tc-results?])]) (define (subst v t e) (substitute t v e)) From fcc2a24545b0b4f71052457acdf8097f084a4b27 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 25 Mar 2009 01:07:34 +0000 Subject: [PATCH 061/156] sync ts to trunk svn: r14257 --- .../typed-scheme/env/type-environments.ss | 14 ++++ collects/typed-scheme/private/base-env.ss | 39 ++++++++++- collects/typed-scheme/private/parse-type.ss | 37 ++++++++++ .../typed-scheme/private/type-contract.ss | 33 +++++---- collects/typed-scheme/ts-reference.scrbl | 53 +++++++++++++- .../typecheck/provide-handling.ss | 12 ++-- .../typed-scheme/typecheck/tc-app-unit.ss | 13 ++++ collects/typed-scheme/types/abbrev.ss | 1 + collects/typed-scheme/utils/poly-c.ss | 70 +++++++++++++++++++ collects/typed-scheme/utils/utils.ss | 4 +- 10 files changed, 254 insertions(+), 22 deletions(-) create mode 100644 collects/typed-scheme/utils/poly-c.ss diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 57c04ee62c..a5cf6e460e 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -10,6 +10,9 @@ dotted-env initial-tvar-env env-map + env-filter + env-vals + env-keys+vals with-dotted-env/extend) (require (prefix-in r: "../utils/utils.ss")) @@ -19,6 +22,17 @@ ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) +(define (env-vals e) + (map cdr (env-l e))) + +(define (env-keys+vals e) + (env-l e)) + +(define (env-filter f e) + (match e + [(struct env (eq? l)) + (make-env eq? (filter f l))])) + ;; the initial type variable environment - empty ;; this is used in the parsing of types (define initial-tvar-env (make-env eq? '())) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 98793c5a99..2ce9716030 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -102,10 +102,14 @@ [fold-right (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a)) ((-lst b) b) . ->... . c))] [foldl - (-poly (a b c) + (-poly (a b c d) (cl-> [((a b . -> . b) b (-lst a)) b] - [((a b c . -> . c) c (-lst a) (-lst b)) c]))] -[foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] + [((a b c . -> . c) c (-lst a) (-lst b)) c] + [((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))] +[foldr (-poly (a b c d) + (cl-> [((a b . -> . b) b (-lst a)) b] + [((a b c . -> . c) c (-lst a) (-lst b)) c] + [((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))] [filter (-poly (a b) (cl->* ((make-pred-ty (list a) B b) (-lst a) @@ -537,6 +541,10 @@ [maybe-print-message (-String . -> . -Void)] +[list->string ((-lst -Char) . -> . -String)] +[string->list (-String . -> . (-lst -Char))] +[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))] + ;; scheme/list [last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . @@ -567,3 +575,28 @@ [real->decimal-string (N [-Nat] . ->opt . -String)] [current-continuation-marks (-> -Cont-Mark-Set)] + +;; scheme/path + +[explode-path (-Pathlike . -> . (-lst (Un -Path (-val 'up) (-val 'same))))] +[find-relative-path (-Pathlike -Pathlike . -> . -Path)] +[simple-form-path (-Pathlike . -> . -Path)] +[normalize-path (cl->* (-Pathlike . -> . -Path) + (-Pathlike -Pathlike . -> . -Path))] +[filename-extension (-Pathlike . -> . (-opt -Bytes))] +[file-name-from-path (-Pathlike . -> . (-opt -Path))] +[path-only (-Pathlike . -> . -Path)] +[some-system-path->string (-Path . -> . -String)] +[string->some-system-path + (-String (Un (-val 'unix) (-val 'windows)) . -> . -Path)] + +;; scheme/math + +[sgn (-Real . -> . -Real)] +[pi N] +[sqr (N . -> . N)] +[sgn (N . -> . N)] +[conjugate (N . -> . N)] +[sinh (N . -> . N)] +[cosh (N . -> . N)] +[tanh (N . -> . N)] \ No newline at end of file diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index c3e9438ee0..0f8be85bb6 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -346,6 +346,26 @@ (current-tvars))]) (parse-type #'rest)) (syntax-e #'bound)))))))] + [(dom ... rest ::: -> rng) + (and (eq? (syntax-e #'->) '->) + (eq? (syntax-e #':::) '...)) + (begin + (add-type-name-reference #'->) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-Function + (list + (make-arr-dots (map parse-type (syntax->list #'(dom ...))) + (parse-type #'rng) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'rest)) + var))))))] ;; has to be below the previous one [(dom ... -> rng) (eq? (syntax-e #'->) '->) @@ -365,6 +385,23 @@ (current-tvars))]) (parse-type #'dty)) (syntax-e #'bound))))] + [(values tys ... dty dd) + (and (eq? (syntax-e #'values) 'values) + (eq? (syntax-e #'dd) '...)) + (begin + (add-type-name-reference #'values) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'dty)) + var))))] [(values tys ...) (eq? (syntax-e #'values) 'values) (-values (map parse-type (syntax->list #'(tys ...))))] diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 2b0491ea8a..930437b763 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -17,7 +17,7 @@ mzlib/trace scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) - (for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c))) + (for-template scheme/base scheme/contract (utils poly-c) (only-in scheme/class object% is-a?/c subclass?/c))) (define (define/fixup-contract? stx) (or (syntax-property stx 'typechecker:contract-def) @@ -51,7 +51,9 @@ (define (type->contract ty fail) (define vars (make-parameter '())) (let/cc exit - (let t->c ([ty ty]) + (let loop ([ty ty] [pos? #t]) + (define (t->c t) (loop t pos?)) + (define (t->c/neg t) (loop t (not pos?))) (match ty [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))] [(Univ:) #'any/c] @@ -71,13 +73,13 @@ (define-values (dom* rngs* rst) (match a [(arr: dom (Values: rngs) #f #f '()) - (values (map t->c dom) (map t->c rngs) #f)] + (values (map t->c/neg dom) (map t->c rngs) #f)] [(arr: dom rng #f #f '()) - (values (map t->c dom) (list (t->c rng)) #f)] + (values (map t->c/neg dom) (list (t->c rng)) #f)] [(arr: dom (Values: rngs) rst #f '() ) - (values (map t->c dom) (map t->c rngs) (t->c rst))] + (values (map t->c/neg dom) (map t->c rngs) (t->c/neg rst))] [(arr: dom rng rst #f '()) - (values (map t->c dom) (list (t->c rng)) (t->c rst))])) + (values (map t->c/neg dom) (list (t->c rng)) (t->c/neg rst))])) (with-syntax ([(dom* ...) dom*] [rng* (match rngs* @@ -99,12 +101,22 @@ #`(cons/c #,(t->c t1) #,(t->c t2))] [(Opaque: p? cert) #`(flat-contract #,(cert p?))] - [(F: v) (cond [(assoc v (vars)) => cadr] + [(F: v) (cond [(assoc v (vars)) => (if pos? second third)] [else (int-err "unknown var: ~a" v)])] + [(Poly: vs (and b (Function: _))) + (match-let ([(Poly-names: vs-nm _) ty]) + (with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '+)))] + [(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '-)))]) + (parameterize ([vars (append (map list + vs + (syntax->list #'(vs+ ...)) + (syntax->list #'(vs- ...))) + (vars))]) + #`(poly/c ([vs- vs+] ...) #,(t->c b)))))] [(Mu: n b) (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) - (parameterize ([vars (cons (list n #'n*) (vars))]) + (parameterize ([vars (cons (list n #'n* #'n*) (vars))]) #`(flat-rec-contract n* #,(t->c b)))))] [(Value: #f) #'false/c] [(Instance: _) #'(is-a?/c object%)] @@ -112,10 +124,7 @@ [(Value: '()) #'null?] [(Struct: _ _ _ _ #f pred? cert) (cert pred?)] [(Syntax: (Base: 'Symbol _)) #'identifier?] - [(Syntax: t) - (if (equal? ty t:Any-Syntax) - #`syntax? - #`(syntax/c #,(t->c t)))] + [(Syntax: t) #`(syntax/c #,(t->c t))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] [(Param: in out) #`(parameter/c #,(t->c out))] [(Hashtable: k v) #`hash?] diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index 102a13e905..c2982e2546 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -1,7 +1,10 @@ #lang scribble/doc -@begin[(require scribble/manual) - (require (for-label typed-scheme))] +@begin[(require scribble/manual scribble/eval + scheme/sandbox) + (require (for-label typed-scheme + scheme/list srfi/14 + version/check))] @begin[ (define (item* header . args) (apply item @bold[header]{: } args)) @@ -52,6 +55,8 @@ The following base types are parameteric in their type arguments. the first is the type the parameter accepts, and the second is the type returned.} @defform[(Pair s t)]{is the pair containing @scheme[s] as the @scheme[car] and @scheme[t] as the @scheme[cdr]} +@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type + @scheme[k] and value type @scheme[v].} @subsubsub*section{Type Constructors} @@ -245,3 +250,47 @@ known to Typed Scheme, either via @scheme[define-struct:] or Like @scheme[do], but each @scheme[id] having the associated type @scheme[t], and the final body @scheme[expr] having the type @scheme[u]. } + +@section{Libraries Provided With Typed Scheme} + +The @schememodname[typed-scheme] language corresponds to the +@schememodname[scheme/base] language---that is, any identifier provided +by @schememodname[scheme/base], such as @scheme[mod] is available by default in +@schememodname[typed-scheme]. + +@schememod[typed-scheme +(modulo 12 2) +] + +Any value provided by @schememodname[scheme] is available by simply +@scheme[require]ing it; use of @scheme[require/typed] is not +neccessary. + +@schememod[typed-scheme +(require scheme/list) +(display (first (list 1 2 3))) +] + +Some libraries have counterparts in the @schemeidfont{typed} +collection, which provide the same exports as the untyped versions. +Such libraries include @schememodname[srfi/14], +@schememodname[net/url], and many others. + +@schememod[typed-scheme +(require typed/srfi/14) +(char-set= (string->char-set "hello") + (string->char-set "olleh")) +] + +To participate in making more libraries available, please visit +@link["http://www.ccs.neu.edu/home/samth/adapt/"]{here}. + + +Other libraries can be used with Typed Scheme via +@scheme[require/typed]. + +@schememod[typed-scheme +(require/typed version/check + [check-version (-> (U Symbol (Listof Any)))]) +(check-version) +] diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 791d6384d7..66b3576a13 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -54,15 +54,18 @@ (define/contract cnt-id #,cnt id) (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer #'id) - (make-rename-transformer #'cnt-id))) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t)) + (make-rename-transformer (syntax-property #'cnt-id + 'not-free-identifier=? #t)))) (#%provide (rename export-id out-id)))))] [else (with-syntax ([(export-id) (generate-temporaries #'(id))]) #`(begin (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer #'id) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t)) (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))) (provide (rename-out [export-id out-id]))))])))] [(mem? internal-id stx-defs) @@ -76,7 +79,8 @@ (if (unbox typed-context?) (begin (add-alias #'export-id #'id) - (make-rename-transformer #'id)) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t))) (lambda (stx) (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))) (provide (rename-out [export-id out-id]))))))] diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index dbe864f112..61b4f54be6 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -342,6 +342,19 @@ drest-bound (subst-all (alist-delete drest-bound substitution eq?) (car rngs*)))))] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (do-apply-log substitution 'dots 'dots) + (ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result: (PolyDots: vars (Function: '()))) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 9db1bd41f2..07e0362760 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -96,6 +96,7 @@ (define Err (make-Error)) (define -Nat -Integer) +(define -Real -Number) (define Any-Syntax (-mu x diff --git a/collects/typed-scheme/utils/poly-c.ss b/collects/typed-scheme/utils/poly-c.ss new file mode 100644 index 0000000000..695a85dc50 --- /dev/null +++ b/collects/typed-scheme/utils/poly-c.ss @@ -0,0 +1,70 @@ +#lang scheme/base + +(require scheme/contract (for-syntax scheme/base)) + +(provide memory/c apply/c poly/c) + +(with-contract + poly-internals + ([memory/c + (->* + [] + [ #:name any/c + #:to any/c + #:from any/c + #:weak boolean? + #:equal (or/c 'eq 'eqv 'equal) + #:table (-> (and/c hash? (not/c immutable?))) ] + (values flat-contract? flat-contract?))] + [apply/c (->* [any/c] [#:name any/c] contract?)]) + + (define (memory/c + #:name [name "memory/c"] + #:to [to (format "~a:to" name)] + #:from [from (format "~a:from" name)] + #:weak [weak? #t] + #:equal [equal 'eq] + #:table [make-table + (case equal + [(eq) (if weak? make-weak-hasheq make-hasheq)] + [(eqv) (if weak? make-weak-hasheqv make-hasheqv)] + [(equal) (if weak? make-weak-hash make-hash)])]) + (let* ([table (make-table)]) + (values + (flat-named-contract from + (lambda (v) (hash-set! table v #t) #t)) + (flat-named-contract to + (lambda (v) (hash-ref table v #f)))))) + + (define (apply/c c + #:name [name (build-compound-type-name 'apply/c c)]) + (make-proj-contract + name + (lambda (pos neg src name2) + (lambda (p) + (let* ([ctc (coerce-contract 'apply/c c)] + [thunk (lambda () ((((proj-get ctc) ctc) pos neg src name2) p))]) + (make-keyword-procedure + (lambda (keys vals . args) (keyword-apply (thunk) keys vals args)) + (case-lambda + [() ((thunk))] + [(a) ((thunk) a)] + [(a b) ((thunk) a b)] + [(a b c) ((thunk) a b c)] + [(a b c d) ((thunk) a b c d)] + [(a b c d e) ((thunk) a b c d e)] + [(a b c d e f) ((thunk) a b c d e f)] + [(a b c d e f g) ((thunk) a b c d e f g)] + [(a b c d e f g h) ((thunk) a b c d e f g h)] + [args (apply (thunk) args)]))))) + procedure?))) + +(define-syntax (poly/c stx) + (syntax-case stx () + [(_ opts ... ([c- c+] ...) c) + (quasisyntax/loc stx + (apply/c + #:name (quote #,stx) + (recursive-contract + (let-values ([(c- c+) (memory/c #:from 'c- #:to 'c+ opts ...)] ...) + c))))])) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 658c581b4f..a2503c86e9 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -20,7 +20,9 @@ at least theoretically. in-list-forever extend debug - in-syntax) + in-syntax + symbol-append + rep utils typecheck infer env private) (define-syntax (define-requirer stx) (syntax-parse stx From ebdd60a3a3cbdc7904f71c93316379caf866afdf Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 30 Mar 2009 12:51:02 +0000 Subject: [PATCH 062/156] fix some small bugs svn: r14352 --- collects/typed-scheme/env/type-environments.ss | 11 +++++++---- collects/typed-scheme/typecheck/tc-expr-unit.ss | 4 ++-- collects/typed-scheme/typecheck/tc-new-if.ss | 11 ++++++----- 3 files changed, 15 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index a5cf6e460e..1c9bca9503 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -1,10 +1,14 @@ #lang scheme/base +(require scheme/contract + (prefix-in r: "../utils/utils.ss") + scheme/match + (except-in (r:utils tc-utils) make-env)) + (provide current-tvars extend env? lookup - make-empty-env extend-env extend/values dotted-env @@ -15,9 +19,8 @@ env-keys+vals with-dotted-env/extend) -(require (prefix-in r: "../utils/utils.ss")) -(require scheme/match - (except-in (r:utils tc-utils) make-env)) +(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)] + []) ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index ae1ebf768d..328e373b6a 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -114,8 +114,8 @@ ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) - [(tc-result: t _ _) t] - [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) + [(tc-result1: t _ _) t] + [t (int-err "tc-expr returned ~a, not a single tc-result, for ~a" t (syntax->datum e))])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss index 95b70021cd..dcd423df98 100644 --- a/collects/typed-scheme/typecheck/tc-new-if.ss +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -21,19 +21,20 @@ (define (tc/if-twoarm tst thn els [expected #f]) (define (tc e) (if expected (tc-expr/check e expected) (tc-expr e))) (match (tc-expr tst) - [(list (tc-result: _ (and f1 (FilterSet: fs+ fs-)) _)) + [(tc-result1: _ (and f1 (FilterSet: fs+ fs-)) _) (match-let ([(tc-results: ts fs2 _) (with-lexical-env (env+ (lexical-env) fs+) (tc thn))] [(tc-results: us fs3 _) (with-lexical-env (env+ (lexical-env) fs-) (tc els))]) ;; if we have the same number of values in both cases (cond [(= (length ts) (length us)) - (for/list ([t ts] [u us] [f2 fs2] [f3 fs3]) - (ret (Un t u) (combine-filter f1 f2 f2)))] + (ret (for/list ([t ts] [u us]) (Un t u)) + (for/list ([f2 fs2] [f3 fs3]) + (combine-filter f1 f2 f2)))] [else - (tc-error/expr #:ret (ret Err) + (tc-error/expr #:return (ret Err) "Expected the same number of values from both branches of if expression, but got ~a and ~a" (length ts) (length us))]))] [(tc-results: t _ _) - (tc-error/expr #:ret (ret (or expected Err)) + (tc-error/expr #:return (ret (or expected Err)) "Test expression expects one value, given ~a" t)])) (define tc/if-twoarm/check tc/if-twoarm) \ No newline at end of file From b53fda900046e3c4ac647eaf65d007dfa1984f93 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 16 Apr 2009 18:33:20 +0000 Subject: [PATCH 063/156] update date svn: r14529 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 7341e33be3..5aa9e7c22e 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1,7 +1,7 @@ #lang scheme/base (provide stamp) (define stamp - (string-append "2mar2009 " + (string-append "14apr2009 " (let ([s "$URL$"]) (substring s 6 From 1edf62a912ac0468c2a995043c58826607d645dc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 24 Apr 2009 21:21:06 +0000 Subject: [PATCH 064/156] resolve conflicts svn: r14598 --- collects/typed-scheme/env/init-envs.ss | 3 + collects/typed-scheme/env/lexical-env.ss | 2 +- collects/typed-scheme/env/type-env.ss | 2 +- collects/typed-scheme/env/type-name-env.ss | 2 +- collects/typed-scheme/infer/infer-unit.ss | 3 + collects/typed-scheme/infer/infer.ss | 7 +- collects/typed-scheme/private/base-env.ss | 27 ++++- collects/typed-scheme/private/parse-type.ss | 9 +- collects/typed-scheme/private/prims.ss | 9 +- .../typed-scheme/private/type-contract.ss | 7 +- .../typed-scheme/private/typed-renaming.ss | 20 ++++ collects/typed-scheme/rep/type-rep.ss | 15 ++- collects/typed-scheme/ts-guide.scrbl | 4 +- collects/typed-scheme/ts-reference.scrbl | 17 ++- .../typed-scheme/typecheck/internal-forms.ss | 2 + .../typecheck/provide-handling.ss | 43 ++++--- .../typed-scheme/typecheck/tc-app-unit.ss | 6 +- .../typed-scheme/typecheck/tc-expr-unit.ss | 2 +- collects/typed-scheme/typecheck/tc-structs.ss | 6 +- .../typed-scheme/typecheck/tc-toplevel.ss | 13 ++- .../typed-scheme/typecheck/typechecker.ss | 6 +- collects/typed-scheme/utils/unit-utils.ss | 109 +----------------- 22 files changed, 160 insertions(+), 154 deletions(-) create mode 100644 collects/typed-scheme/private/typed-renaming.ss diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index dc5dc33090..396c94c4e4 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -29,6 +29,9 @@ `(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))] [(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))] diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 9998ad3c99..07f8134c09 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -31,7 +31,7 @@ => (lambda (a) (-lst (substitute Univ (cdr a) (car a))))] - [else (lookup-fail (syntax-e i))])))))) + [else (lookup-fail i)])))))) ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index dda31d6679..444aeebd73 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -39,7 +39,7 @@ ;; given an identifier, return the type associated with it ;; if none found, calls lookup-fail ;; identifier -> type -(define (lookup-type id [fail-handler (lambda () (lookup-fail (syntax-e id)))]) +(define (lookup-type id [fail-handler (lambda () (lookup-type-fail id))]) (let ([v (module-identifier-mapping-get the-mapping id fail-handler)]) (if (box? v) (unbox v) v))) diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index 4c35e9d694..7c41a3dec4 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -35,7 +35,7 @@ ;; given an identifier, return the type associated with it ;; optional argument is failure continuation - default calls lookup-fail ;; identifier (-> error) -> type -(define (lookup-type-name id [k (lambda () (lookup-fail (syntax-e id)))]) +(define (lookup-type-name id [k (lambda () (lookup-type-fail id))]) (begin0 (module-identifier-mapping-get the-mapping id k) (add-type-name-reference id))) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index ea3648b095..18ff9b6548 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -243,6 +243,9 @@ [(a a) empty] [(_ (Univ:)) empty] + [((Refinement: S _ _) T) + (cg S T)] + [((F: (? (lambda (e) (memq e X)) v)) S) (when (match S [(F: v*) diff --git a/collects/typed-scheme/infer/infer.ss b/collects/typed-scheme/infer/infer.ss index b8c3788381..c660783ed0 100644 --- a/collects/typed-scheme/infer/infer.ss +++ b/collects/typed-scheme/infer/infer.ss @@ -3,10 +3,11 @@ (require (except-in "../utils/utils.ss" infer)) (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" "restrict.ss" "promote-demote.ss" - (only-in scheme/unit provide-signature-elements) + (only-in scheme/unit provide-signature-elements + define-values/invoke-unit/infer link) (utils unit-utils)) (provide-signature-elements restrict^ infer^) -(define-values/link-units/infer - infer@ constraints@ dmap@ restrict@ promote-demote@) +(define-values/invoke-unit/infer + (link infer@ constraints@ dmap@ restrict@ promote-demote@)) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 2ce9716030..3b6ce0806f 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -418,11 +418,12 @@ [symbol->string (Sym . -> . -String)] [vector-length (-poly (a) ((-vec a) . -> . -Integer))] -[call-with-input-file (-poly (a) (cl-> [(-String (-Port . -> . a)) a] - [(-String (-Port . -> . a) Sym) a]))] +[call-with-input-file (-poly (a) (-String (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] +[call-with-output-file (-poly (a) (-String (-Output-Port . -> . a) + #:exists (one-of/c error 'append 'update 'replace 'truncate 'truncate/replace) #f + #:mode (Un (-val 'binary) (-val 'text)) #f + . ->key . a))] -[call-with-output-file (-poly (a) (cl-> [(-String (-Port . -> . a)) a] - [(-String (-Port . -> . a) Sym) a]))] [current-output-port (-Param -Output-Port -Output-Port)] [current-error-port (-Param -Output-Port -Output-Port)] [current-input-port (-Param -Input-Port -Input-Port)] @@ -544,11 +545,29 @@ [list->string ((-lst -Char) . -> . -String)] [string->list (-String . -> . (-lst -Char))] [sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))] +[find-system-path (Sym . -> . -Path)] + +;; scheme/cmdline + +[parse-command-line + (let ([mode-sym (one-of/c 'once-each 'once-any 'multi 'final 'help-labels)]) + (-polydots (b a) + (cl->* (-Pathlike + (Un (-lst -String) (-vec -String)) + (-lst (-pair mode-sym (-lst (-lst Univ)))) + ((list Univ) [a a] . ->... . b) + (-lst -String) + . -> . b))))] ;; scheme/list [last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . (Un (-pair a a) (-pair a (-val '())))))] +[remove-duplicates + (-poly (a) + (cl->* + ((-lst a) . -> . (-lst a)) + ((-lst a) (a a . -> . Univ) . -> . (-lst a))))] ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 0f8be85bb6..ef555e6cc6 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -8,7 +8,7 @@ (utils tc-utils stxclass-util) syntax/stx stxclass stxclass/util - (env type-environments type-name-env type-alias-env) + (env type-environments type-name-env type-alias-env lexical-env) (prefix-in t: "base-types-extra.ss") scheme/match (for-template scheme/base "base-types-extra.ss")) @@ -296,6 +296,13 @@ (map list (map syntax-e (syntax->list #'(mname ...))) (map parse-type (syntax->list #'(mty ...)))))] + [(Refinement p?) + (and (eq? (syntax-e #'Refinement) 'Refinement) + (identifier? #'p?)) + (match (lookup-type/lexical #'p?) + [(and t (Function: (list (arr: (list dom) rng #f #f '() _ _)))) + (make-Refinement dom #'p? (syntax-local-certifier))] + [t (tc-error "cannot declare refinement for non-predicate ~a" t)])] [(Instance t) (eq? (syntax-e #'Instance) 'Instance) (let ([v (parse-type #'t)]) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 696c9c63cc..a5ec8287d1 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -343,7 +343,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (list #'struct-info #'maker #'pred - (list #'sel ...) + (reverse (list #'sel ...)) (list mut ...) #f)))) #,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) @@ -407,4 +407,9 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ [i:id t] ...) (syntax/loc stx (begin (: i t) ... - (provide i ...)))])) \ No newline at end of file + (provide i ...)))])) + +(define-syntax (declare-refinement stx) + (syntax-parse stx + [(_ p:id) + (quasisyntax/loc stx #,(internal #'(declare-refinement-internal p)))])) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 930437b763..87377316e5 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -62,6 +62,8 @@ #`(listof #,(t->c elem-ty))] [(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?] [(Base: sym cnt) cnt] + [(Refinement: par p? cert) + #`(and/c #,(t->c par) (flat-contract #,(cert p?)))] [(Union: elems) (with-syntax ([cnts (map t->c elems)]) @@ -100,7 +102,7 @@ [(Pair: t1 t2) #`(cons/c #,(t->c t1) #,(t->c t2))] [(Opaque: p? cert) - #`(flat-contract #,(cert p?))] + #`(flat-named-contract (quote #,(syntax-e p?)) #,(cert p?))] [(F: v) (cond [(assoc v (vars)) => (if pos? second third)] [else (int-err "unknown var: ~a" v)])] [(Poly: vs (and b (Function: _))) @@ -122,7 +124,8 @@ [(Instance: _) #'(is-a?/c object%)] [(Class: _ _ _) #'(subclass?/c object%)] [(Value: '()) #'null?] - [(Struct: _ _ _ _ #f pred? cert) (cert pred?)] + [(Struct: _ _ _ _ #f pred? cert) + #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))] [(Syntax: (Base: 'Symbol _)) #'identifier?] [(Syntax: t) #`(syntax/c #,(t->c t))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] diff --git a/collects/typed-scheme/private/typed-renaming.ss b/collects/typed-scheme/private/typed-renaming.ss new file mode 100644 index 0000000000..39f6bfaf72 --- /dev/null +++ b/collects/typed-scheme/private/typed-renaming.ss @@ -0,0 +1,20 @@ +#lang scheme/base + +(require (for-syntax scheme/base)) + +(provide make-typed-renaming get-alternate) + +;; target : identifier +;; alternate : identifier +(define-struct typed-renaming (target alternate) + #:property prop:rename-transformer 0) + +;; identifier -> identifier +;; get the alternate field of the renaming, if it exists +(define (get-alternate id) + (define-values (v new-id) (syntax-local-value/immediate id (lambda _ (values #f #f)))) + (cond [(typed-renaming? v) + (typed-renaming-alternate v)] + [(rename-transformer? v) + (get-alternate (rename-transformer-target v))] + [else id])) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index bfd1605f45..754884c03f 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -201,7 +201,7 @@ poly? pred-id cert)] - [#:key (gensym)]) + [#:key #f #;(gensym)]) ;; v : Scheme Value @@ -243,6 +243,17 @@ ;; value : Type (dt Hashtable ([key Type/c] [value Type/c]) [#:key 'hash]) +;; parent : Type +;; pred : Identifier +;; cert : Certifier +(dt Refinement (parent pred cert) + [#:key (Type-key parent)] + [#:intern (list parent (hash-id pred))] + [#:fold-rhs (*Refinement (type-rec-id parent) pred cert)] + [#:frees (free-vars* parent) + (free-idxs* parent)]) + + ;; t : Type (dt Syntax ([t Type/c]) [#:key 'syntax]) @@ -400,7 +411,7 @@ (map sb kws))] [#:ValuesDots rs dty dbound (*ValuesDots (map sb rs) - (sb dty) + (sb dty) (if (eqv? dbound (+ count outer)) (F-n image) dbound))] [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))] [#:PolyDots n body* diff --git a/collects/typed-scheme/ts-guide.scrbl b/collects/typed-scheme/ts-guide.scrbl index 079a86fb02..d3af990ca0 100644 --- a/collects/typed-scheme/ts-guide.scrbl +++ b/collects/typed-scheme/ts-guide.scrbl @@ -62,11 +62,11 @@ typed-scheme There are two differences between these programs: -@itemize{ +@itemize[ @item*[@elem{The Language}]{@schememodname[scheme] has been replaced by @schememodname[typed-scheme].} @item*[@elem{The Type Annotation}]{We have added a type annotation -for the @scheme[fib] function, using the @scheme[:] form.} } +for the @scheme[fib] function, using the @scheme[:] form.} ] In general, these are most of the changes that have to be made to a PLT Scheme program to transform it into a Typed Scheme program. diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index c2982e2546..d2911b682b 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -87,7 +87,7 @@ The following base types are parameteric in their type arguments. types @scheme[t ...]. This can only appear as the return type of a function.} @defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing only that value} -@defform/none['sym]{where @scheme[sym] is a symbol, is the singleton type containing only that symbol} +@defform/none['val]{where @scheme[val] is a Scheme value, is the singleton type containing only that value} @defform/none[i]{where @scheme[i] is an identifier can be a reference to a type name or a type variable} @defform[(Rec n t)]{is a recursive type where @scheme[n] is bound to the @@ -294,3 +294,18 @@ Other libraries can be used with Typed Scheme via [check-version (-> (U Symbol (Listof Any)))]) (check-version) ] + +@section{Typed Scheme Syntax Without Type Checking} + +@defmodulelang[typed-scheme/no-check] + +On occasions where the Typed Scheme syntax is useful, but actual +typechecking is not desired, the @schememodname[typed-scheme/no-check] +language is useful. It provides the same bindings and syntax as Typed +Scheme, but does no type checking. + +Examples: + +@schememod[typed-scheme/no-check +(: x Number) +(define x "not-a-number")] \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/internal-forms.ss b/collects/typed-scheme/typecheck/internal-forms.ss index b85dd96c1e..a0ce6e9cb0 100644 --- a/collects/typed-scheme/typecheck/internal-forms.ss +++ b/collects/typed-scheme/typecheck/internal-forms.ss @@ -11,4 +11,6 @@ define-typed-struct-internal define-typed-struct/exec-internal assert-predicate-internal + declare-refinement-internal :-internal) + diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 66b3576a13..c214937592 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -5,7 +5,7 @@ syntax/kerncase syntax/boundmap (env type-name-env type-alias-env) mzlib/trace - (private type-contract) + (private type-contract typed-renaming) (rep type-rep) (utils tc-utils) "def-binding.ss") @@ -13,7 +13,8 @@ (require (for-template scheme/base scheme/contract)) -(provide remove-provides provide? generate-prov) +(provide remove-provides provide? generate-prov + get-alternate) (define (provide? form) (kernel-syntax-case form #f @@ -24,6 +25,12 @@ (define (remove-provides forms) (filter (lambda (e) (not (provide? e))) (syntax->list forms))) + +(define (renamer id #:alt [alt #f]) + (if alt + (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) + (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) + (define (generate-prov stx-defs val-defs) (define mapping (make-free-identifier-mapping)) (lambda (form) @@ -54,35 +61,35 @@ (define/contract cnt-id #,cnt id) (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer (syntax-property #'id - 'not-free-identifier=? #t)) - (make-rename-transformer (syntax-property #'cnt-id - 'not-free-identifier=? #t)))) + (renamer #'id #:alt #'cnt-id) + (renamer #'cnt-id))) (#%provide (rename export-id out-id)))))] [else - (with-syntax ([(export-id) (generate-temporaries #'(id))]) - #`(begin + (with-syntax ([(export-id error-id) (generate-temporaries #'(id id))]) + #`(begin + (define-syntax error-id + (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer (syntax-property #'id - 'not-free-identifier=? #t)) - (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))) + (renamer #'id #:alt #'error-id) + (renamer #'error-id))) (provide (rename-out [export-id out-id]))))])))] [(mem? internal-id stx-defs) => (lambda (b) (with-syntax ([id internal-id] [out-id external-id]) - (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]) - #`(begin + (with-syntax ([(export-id error-id) (generate-temporaries #'(id id))]) + #`(begin + (define-syntax error-id + (lambda (stx) + (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))) (define-syntax export-id (if (unbox typed-context?) - (begin + (begin (add-alias #'export-id #'id) - (make-rename-transformer (syntax-property #'id - 'not-free-identifier=? #t))) - (lambda (stx) - (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))) + (renamer #'id #:alt #'error-id)) + (renamer #'error-id))) (provide (rename-out [export-id out-id]))))))] [(eq? (syntax-e internal-id) (syntax-e external-id)) #`(provide #,internal-id)] diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 61b4f54be6..63db7660b9 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -576,7 +576,7 @@ [c:lv-clause #:with (#%plain-app reverse n:id) #'c.e #:with (v) #'(c.v ...) - #:when (free-identifier=? name #'v) + #:when (free-identifier=? name #'n) (type-annotation #'v)] [_ #f])) (syntax-parse stx @@ -757,8 +757,8 @@ (match (tc-expr #'fn) [(tc-result: (Function: arities)) (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] - [t (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" t)])] + [(tc-result: t) (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 328e373b6a..9640ef5a90 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -136,7 +136,7 @@ (ret expected)] [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr"Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected])) (define (tc-expr/check form expected) diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 4c6b019b4c..395a82bdc2 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -86,6 +86,7 @@ (define (mk/register-sty nm flds parent parent-field-types types #:wrapper [wrapper values] #:type-wrapper [type-wrapper values] + #:pred-wrapper [pred-wrapper values] #:mutable [setters? #f] #:proc-ty [proc-ty #f] #:maker [maker* #f] @@ -104,6 +105,7 @@ (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? #:wrapper wrapper #:type-wrapper type-wrapper + #:pred-wrapper pred-wrapper #:maker (or maker* maker) #:constructor-return cret)))) @@ -113,6 +115,7 @@ (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? #:wrapper [wrapper values] #:type-wrapper [type-wrapper values] + #:pred-wrapper [pred-wrapper values] #:maker [maker* #f] #:constructor-return [cret #f]) ;; create the approriate names that define-struct will bind @@ -125,7 +128,7 @@ (list (cons (or maker* maker) (wrapper (->* external-fld-types (if cret cret name)))) (cons pred - (make-pred-ty (wrapper name)))) + (make-pred-ty (pred-wrapper name)))) (map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent) (if setters? (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) @@ -167,6 +170,7 @@ ;; wrap everything in the approriate forall #:wrapper (lambda (t) (make-Poly tvars t)) #:type-wrapper (lambda (t) (make-App t new-tvars #f)) + #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (list t Univ)) t)) #:poly? #t)) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index fce1a1a30e..e881e3e48a 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -10,7 +10,7 @@ (rep type-rep) (types utils convenience) (private parse-type type-annotation type-contract) - (env type-env init-envs type-name-env type-alias-env) + (env type-env init-envs type-name-env type-alias-env lexical-env) (utils tc-utils mutated-vars) "provide-handling.ss" "def-binding.ss" @@ -39,6 +39,17 @@ ;; type aliases have already been handled by an earlier pass [(define-values () (begin (quote-syntax (define-type-alias-internal nm ty)) (#%plain-app values))) (list)] + + ;; declare-refinement + [(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values))) + (match (lookup-type/lexical #'pred) + [(and t (Function: (list (arr: (list dom) rng #f #f '() _ _)))) + (register-type #'pred + (make-pred-ty (list dom) + rng + (make-Refinement dom #'pred (syntax-local-certifier)))) + (list)] + [t (tc-error "cannot declare refinement for non-predicate ~a" t)])] ;; require/typed [(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values))) diff --git a/collects/typed-scheme/typecheck/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss index 2f41a66a9e..bfa104fe82 100644 --- a/collects/typed-scheme/typecheck/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -3,8 +3,10 @@ (require "../utils/utils.ss") (require (utils unit-utils) mzlib/trace - (only-in scheme/unit provide-signature-elements) - "signatures.ss" "tc-toplevel.ss" + (only-in scheme/unit + provide-signature-elements + define-values/invoke-unit/infer link) + "signatures.ss" "tc-toplevel.ss" "tc-new-if.ss" "tc-lambda-unit.ss" "tc-new-app-unit.ss" "tc-let-unit.ss" "tc-dots-unit.ss" "tc-expr-unit.ss" "check-subforms-unit.ss") diff --git a/collects/typed-scheme/utils/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss index 728edcd193..77b19a08ca 100644 --- a/collects/typed-scheme/utils/unit-utils.ss +++ b/collects/typed-scheme/utils/unit-utils.ss @@ -1,113 +1,6 @@ #lang scheme/base -(require scheme/unit - (for-syntax - scheme/base - (only-in srfi/1/list s:member delete-duplicates) - scheme/unit-exptime - scheme/match)) - -(provide define-values/link-units/infer) - -(define-syntax (define-values/link-units/infer stx) - ;; construct something we can put in the imports/exports clause from the datum - (define (datum->sig-elem d) - (if (car d) - (quasisyntax/loc (cdr d) (tag . #,(cdr d))) - (cdr d))) - - ;; identifier -> (list (listof imports) (listof exports)) - (define (get-sigs id) - (define-values (imps exps) (unit-static-signatures id id)) - (list imps exps)) - - ;; flatten one level of a list - ;; listof[listof[a]] -> listof[a] - (define (flatten l) (apply append l)) - - ;; returns two lists of sig-elems - (define (get-all-sigs ids) - (define imps/exps (map get-sigs ids)) - (define-values (imps exps) (values (map car imps/exps) (map cadr imps/exps))) - (values (flatten imps) (flatten exps))) - - ;; construct the runtime code - ;; takes 3 lists of identifiers and a syntax object for location info - (define (mk imports exports units stx) - (quasisyntax/loc stx - (begin (define-compound-unit/infer new-unit@ - (import #,@imports) - (export #,@exports) - (link #,@units)) - (define-values/invoke-unit/infer new-unit@)))) - - ;; compares two signature datums for equality - (define (sig=? sig1 sig2) - (and (eq? (car sig1) (car sig2)) - (or (symbol? (car sig1)) (not (car sig1))) - (bound-identifier=? (cdr sig1) (cdr sig2)))) - - ;; is imp in the list of exports? - (define (sig-in-sigs? imp exps) - (for/or ([e exps]) (sig=? imp e))) - - ;; produce the imports not satisfied by the exports, and all the exports - ;; exports should not have duplicates - (define (imps/exps-from-units units) - (let-values ([(imps exps) (get-all-sigs units)]) - (let* ([exps* (map datum->sig-elem exps)] - [imps* (map datum->sig-elem (filter (lambda (imp) (not (sig-in-sigs? imp exps))) imps))]) - (values imps* exps*)))) - - (define (duplicates? sigs) - (for/or ([s sigs] - #:when - (> 1 (length (for/list ([s* sigs] #:when (free-identifier=? s s*)) s*)))) - s)) - - (syntax-case stx (import export) - ;; here the exports are specified - they ought to be a subset of the allowable exports - [(_ (export . sigs) . units) - (let*-values ([(units) (syntax->list #'units)] - [(imps exps) (imps/exps-from-units units)]) - (mk imps (syntax->list #'sigs) units stx))] - ;; here we just export everything that's available - [(_ . units) - (andmap identifier? (syntax->list #'units)) - (let*-values ([(units) (syntax->list #'units)] - [(imps exps) (imps/exps-from-units units)]) - (cond [(duplicates? exps) - => - (lambda (d) - (raise-syntax-error #f (format "multiple units export the signature ~a" d) stx))] - [else - (mk (delete-duplicates imps) exps units stx)]))])) +(require scheme/unit (for-syntax scheme/base)) -;; Tests -#| -(define-signature x^ (x)) -(define-signature y^ (y)) -(define-signature z^ (z)) - -(define-unit y@ - (import z^) - (export y^) - (define y (* 2 z))) - -(define-unit x@ - (import y^) - (export x^) - (define (x) (+ y 1))) - -(define z 45) - -(define-values/link-units/infer (export x^) x@ y@) -(define-signature y^ (y)) - (define-unit x@ (import y^) (export)) - (define-unit z@ (import y^) (export)) - (define-values/link-units/infer x@ z@) - -;(define-values/link-units/infer x@ y@) -|# From 994f0205f49bb8960b118ca0dda8dae740b1ab1c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 24 Apr 2009 21:30:18 +0000 Subject: [PATCH 065/156] fix conflicts svn: r14601 --- collects/typed-scheme/env/lexical-env.ss | 6 +++--- collects/typed-scheme/private/base-env.ss | 7 ++++++- collects/typed-scheme/typecheck/tc-app-unit.ss | 15 +++++++++++++-- collects/typed-scheme/typecheck/tc-if-unit.ss | 6 ++++-- 4 files changed, 26 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 07f8134c09..b61332399a 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -23,7 +23,7 @@ ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifer -> Type -(define (lookup-type/lexical i [env (lexical-env)]) +(define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f]) (lookup env i (lambda (i) (lookup-type i (lambda () @@ -31,7 +31,7 @@ => (lambda (a) (-lst (substitute Univ (cdr a) (car a))))] - [else (lookup-fail i)])))))) + [else ((or fail lookup-fail) i)])))))) ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment @@ -41,7 +41,7 @@ (define (update f k env) (parameterize ([current-orig-stx k]) - (let* ([v (lookup-type/lexical k)] + (let* ([v (lookup-type/lexical k env #:fail (lambda _ Univ))] [new-v (f k v)] [new-env (extend env k new-v)]) new-env))) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 3b6ce0806f..17e73dbfcf 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -9,7 +9,7 @@ (only-in '#%kernel [apply kernel:apply]) scheme/promise (only-in string-constants/private/only-once maybe-print-message) - (only-in scheme/match/runtime match:error) + (only-in scheme/match/runtime match:error matchable? match-equality-test) (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]))) [raise (Univ . -> . (Un))] @@ -146,6 +146,8 @@ [(Sym B -Namespace (-> Univ)) Univ])] [match:error (Univ . -> . (Un))] +[match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))] +[matchable? (make-pred-ty (Un -String -Bytes))] [display (cl-> [(Univ) -Void] [(Univ -Port) -Void])] [write (cl-> [(Univ) -Void] [(Univ -Port) -Void])] [print (cl-> [(Univ) -Void] [(Univ -Port) -Void])] @@ -568,6 +570,9 @@ (cl->* ((-lst a) . -> . (-lst a)) ((-lst a) (a a . -> . Univ) . -> . (-lst a))))] +[append-map + (-polydots (c a b) ((list ((list a) (b b) . ->... . (-lst c)) (-lst a)) + ((-lst b) b) . ->... .(-lst c)))] ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 63db7660b9..e0a64c4c64 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -21,7 +21,7 @@ (only-in scheme/private/class-internal make-object do-make-object))) (require (r:infer constraint-structs)) -(import tc-expr^ tc-lambda^ tc-dots^) +(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) ;; comparators that inform the type system @@ -779,6 +779,13 @@ (match-let* ([ft (tc-expr #'f)] [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) (ret (Un (-val #f) t)))))] + ;; infer for ((lambda + [(#%plain-app (#%plain-lambda (x ...) . body) args ...) + (= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + (tc/let-values/check #'((x) ...) #'(args ...) #'body + #'(let-values ([(x) args] ...) . body) + expected)] ;; default case [(#%plain-app f args ...) (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) @@ -804,7 +811,11 @@ (ret expected))] ;; special case when argument needs inference [_ - (let ([ts (map (compose generalize tc-expr/t) (syntax->list actuals))]) + (let ([ts (for/list ([ac (syntax->list actuals)] + [f (syntax->list args)]) + (or + (type-annotation f #:infer #t) + (generalize (tc-expr/t ac))))]) (tc/rec-lambda/check form args body lp ts expected) (ret expected))])) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index 24bb6cd2df..3d077cdcde 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -41,7 +41,8 @@ (syntax-rules () [(check-rest f v) (with-update-type/lexical f v (loop (cdr effs)))] - [(check-rest f t v) (check-rest (type-op f t) v)])) + [(check-rest f t v) + (check-rest (type-op f t) v)])) (if (null? effs) ;; base case (let* ([reachable? (not (unbox flag))]) @@ -79,7 +80,8 @@ ;; just replace the type of v with (-val #f) [(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)] ;; v cannot have type (-val #f) - [(Var-True-Effect: v) (check-rest *remove (-val #f) v)]))))) + [(Var-True-Effect: v) + (check-rest *remove (-val #f) v)]))))) ;; the main function (define (tc/if-twoarm tst thn els) From 8cbdf3ee951ce80178ff79b135906cb3d56c5a7e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 16:06:54 +0000 Subject: [PATCH 066/156] compiles again svn: r14625 --- collects/typed-scheme/env/type-env.ss | 2 +- .../typed-scheme/env/type-environments.ss | 7 +-- collects/typed-scheme/private/parse-type.ss | 2 +- .../typed-scheme/typecheck/tc-toplevel.ss | 9 +-- .../typed-scheme/typecheck/typechecker.ss | 4 +- collects/typed-scheme/types/utils.ss | 59 +++++++++++-------- 6 files changed, 48 insertions(+), 35 deletions(-) diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index 444aeebd73..34da01ba0d 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -3,7 +3,7 @@ (require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap (utils tc-utils) - (types utils)) + (types utils)) (provide register-type finish-register-type diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 1c9bca9503..b62d7d024a 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -19,9 +19,6 @@ env-keys+vals with-dotted-env/extend) -(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)] - []) - ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) @@ -76,7 +73,7 @@ ;; elements are not lists, or all at once, if the elements are lists (define (extend/values kss vss env) (foldr (lambda (ks vs env) - (cond [(and (list? ks) (list? vs)) + (cond [(and (list? ks) (list? vs)) (extend-env ks vs env)] [(or (list? ks) (list? vs)) (int-err "not both lists in extend/values: ~a ~a" ks vs)] @@ -87,3 +84,5 @@ (define-syntax with-dotted-env/extend (syntax-rules () [(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)])) + +(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)]) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index ef555e6cc6..d86e12a48d 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -300,7 +300,7 @@ (and (eq? (syntax-e #'Refinement) 'Refinement) (identifier? #'p?)) (match (lookup-type/lexical #'p?) - [(and t (Function: (list (arr: (list dom) rng #f #f '() _ _)))) + [(and t (Function: (list (arr: (list dom) _ #f #f '())))) (make-Refinement dom #'p? (syntax-local-certifier))] [t (tc-error "cannot declare refinement for non-predicate ~a" t)])] [(Instance t) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index e881e3e48a..dd771af2b8 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -10,9 +10,9 @@ (rep type-rep) (types utils convenience) (private parse-type type-annotation type-contract) - (env type-env init-envs type-name-env type-alias-env lexical-env) - (utils tc-utils mutated-vars) - "provide-handling.ss" + (env type-env init-envs type-name-env type-alias-env lexical-env) + (utils tc-utils mutated-vars) + "provide-handling.ss" "def-binding.ss" (for-template "internal-forms.ss" @@ -41,9 +41,10 @@ (list)] ;; declare-refinement + ;; FIXME - this sucks and should die [(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values))) (match (lookup-type/lexical #'pred) - [(and t (Function: (list (arr: (list dom) rng #f #f '() _ _)))) + [(and t (Function: (list (arr: (list dom) rng #f #f '())))) (register-type #'pred (make-pred-ty (list dom) rng diff --git a/collects/typed-scheme/typecheck/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss index bfa104fe82..524c161bb1 100644 --- a/collects/typed-scheme/typecheck/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -13,5 +13,5 @@ (provide-signature-elements typechecker^ tc-expr^) -(define-values/link-units/infer - tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-new-app@ tc-let@ tc-expr@ check-subforms@) +(define-values/invoke-unit/infer + (link tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-new-app@ tc-let@ tc-expr@ check-subforms@)) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index facbcf88ad..8d86e992b0 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -29,7 +29,8 @@ (struct-out DottedBoth) just-Dotted? tc-error/expr - lookup-fail) + lookup-fail + lookup-type-fail) ;; substitute : Type Name Type -> Type @@ -38,7 +39,7 @@ (if (hash-ref (free-vars* target) name #f) (type-case (#:Type sb #:LatentFilter (sub-lf sb)) target - [#:Union tys (Un (map sb tys))] + [#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] [#:arr dom rng rest drest kws (begin @@ -83,7 +84,7 @@ (map sb dom) ;; We need to recur first, just to expand out any dotted usages of this. (let ([expanded (sb (car drest))]) - (map (lambda (img) (substitute img name expanded)) images))) + (map (lambda (img) (substitute img name expanded)) images))) (sb rng) rimage #f @@ -190,25 +191,25 @@ ;; convenience function for returning the result of typechecking an expression (define ret (case-lambda [(t) - (make-tc-results - (if (Type? t) - (list (make-tc-result t (make-FilterSet null null) (make-Empty))) - (for/list ([i t]) - (make-tc-result i (make-FilterSet null null) (make-Empty)))) - #f)] - [(t f) - (make-tc-results - (if (Type? t) - (list (make-tc-result t f (make-Empty))) - (for/list ([i t] [f f]) - (make-tc-result i f (make-Empty)))) - #f)] - [(t f o) - (make-tc-results - (if (and (list? t) (list? f) (list? o)) - (map make-tc-result t f o) - (list (make-tc-result t f o))) - #f)])) + (make-tc-results + (if (Type? t) + (list (make-tc-result t (make-FilterSet null null) (make-Empty))) + (for/list ([i t]) + (make-tc-result i (make-FilterSet null null) (make-Empty)))) + #f)] + [(t f) + (make-tc-results + (if (Type? t) + (list (make-tc-result t f (make-Empty))) + (for/list ([i t] [f f]) + (make-tc-result i f (make-Empty)))) + #f)] + [(t f o) + (make-tc-results + (if (and (list? t) (list? f) (list? o)) + (map make-tc-result t f o) + (list (make-tc-result t f o))) + #f)])) (p/c [ret @@ -254,4 +255,16 @@ return) ;; error for unbound variables -(define (lookup-fail e) (tc-error/expr "unbound identifier ~a" e)) +(define (lookup-fail e) + (match (identifier-binding e) + ['lexical (int-err "untyped lexical variable ~a" (syntax-e e))] + [#f (int-err "untyped top-level variable ~a" (syntax-e e))] + [(list _ _ nominal-source-mod nominal-source-id _ _ _) + (let-values ([(x y) (module-path-index-split nominal-source-mod)]) + (cond [(and (not x) (not y)) + (tc-error/expr "untyped identifier ~a" (syntax-e e))] + [else + (tc-error/expr "untyped identifier ~a imported from module <~a>" (syntax-e e) x)]))])) + +(define (lookup-type-fail i) + (tc-error/expr "~a is not bound as a type" (syntax-e i))) From f2bffcabab6e027a2cd59dc78ab0fd5a77be99c7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 18:26:00 +0000 Subject: [PATCH 067/156] Sync to trunk again. Fix require/contract. Subtyping, printing for refinements. svn: r14626 --- collects/typed-scheme/env/type-name-env.ss | 2 +- collects/typed-scheme/infer/infer-unit.ss | 6 ++-- collects/typed-scheme/ts-reference.scrbl | 2 +- collects/typed-scheme/types/printer.ss | 2 ++ collects/typed-scheme/types/subtype.ss | 2 ++ .../typed-scheme/utils/require-contract.ss | 31 ++++++++++++++++--- 6 files changed, 35 insertions(+), 10 deletions(-) diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index 7c41a3dec4..69b9882579 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -46,6 +46,6 @@ (define (type-name-env-map f) (module-identifier-mapping-map the-mapping f)) -(define (add-alias from to) +(define (add-alias from to) (when (lookup-type-name to (lambda () #f)) (register-resolved-type-alias from (make-Name to)))) \ No newline at end of file diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 18ff9b6548..20bbf1f274 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -242,10 +242,10 @@ (S T) [(a a) empty] [(_ (Univ:)) empty] - + [((Refinement: S _ _) T) (cg S T)] - + [((F: (? (lambda (e) (memq e X)) v)) S) (when (match S [(F: v*) @@ -260,7 +260,7 @@ [_ #f]) (fail! S T)) (singleton (var-promote S V) v Univ)] - + ;; two unions with the same number of elements, so we just try to unify them pairwise #;[((Union: l1) (Union: l2)) (=> unmatch) diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index d2911b682b..14e73bdb6e 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -40,7 +40,7 @@ @defidform[Namespace] @defidform[EOF] @defidform[Char])]{ -These types represent primitive Scheme data.} +These types represent primitive Scheme data. Note that @scheme[Integer] represents exact integers.} @defidform[Any]{Any Scheme value. All other types are subtypes of @scheme[Any].} diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 7bef89b314..6d919bf664 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -181,6 +181,8 @@ [(Result: t (LFilterSet: (list) (list)) (LEmpty:)) (fp "~a" t)] [(Result: t fs (LEmpty:)) (fp "(~a : ~a)" t fs)] [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] + [(Refinement: parent p? _) + (fp "(Refinement ~a ~a)" parent (syntax-e p?))] [else (fp "Unknown Type: ~a" (struct->vector c))] )) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 20570e2bde..14f2ab3c0d 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -226,6 +226,8 @@ (unmatch)) ;(printf "Poly: ~n~a ~n~a~n" b1 (subst-all (map list ms (map make-F ns)) b2)) (subtype* A0 b1 (subst-all (map list ms (map make-F ns)) b2))] + [(list (Refinement: par _ _) t) + (subtype* A0 par t)] ;; use unification to see if we can use the polytype here [(list (Poly: vs b) s) (=> unmatch) diff --git a/collects/typed-scheme/utils/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss index 73570ff2b7..eb9bbff4ca 100644 --- a/collects/typed-scheme/utils/require-contract.ss +++ b/collects/typed-scheme/utils/require-contract.ss @@ -1,6 +1,9 @@ #lang scheme/base -(require scheme/contract (for-syntax scheme/base syntax/kerncase)) +(require scheme/contract (for-syntax scheme/base syntax/kerncase + "../utils/tc-utils.ss" + (prefix-in tr: "../private/typed-renaming.ss"))) + (provide require/contract define-ignored) (define-syntax (define-ignored stx) @@ -20,12 +23,30 @@ 'inferred-name (syntax-e #'name)))])])) + +(define-syntax (get-alternate stx) + (syntax-case stx () + [(_ id) + (tr:get-alternate #'id)])) + (define-syntax (require/contract stx) (syntax-case stx () [(require/contract nm cnt lib) (identifier? #'nm) - #`(begin (require (only-in lib [nm tmp])) - (define-ignored nm (contract cnt tmp '(interface for #,(syntax->datum #'nm)) 'never-happen (quote-syntax nm))))] + (begin + #`(begin (require (only-in lib [nm tmp])) + (define-ignored nm + (contract cnt + (get-alternate tmp) + '(interface for #,(syntax->datum #'nm)) + 'never-happen + (quote-syntax nm)))))] [(require/contract (orig-nm nm) cnt lib) - #`(begin (require (only-in lib [orig-nm tmp])) - (define-ignored nm (contract cnt tmp '#,(syntax->datum #'nm) 'never-happen (quote-syntax nm))))])) + (begin + #`(begin (require (only-in lib [orig-nm tmp])) + (define-ignored nm + (contract cnt + (get-alternate tmp) + '#,(syntax->datum #'nm) + 'never-happen + (quote-syntax nm)))))])) From 18f89c73e43e160c26a3f42d6d118f022ac3814a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 20:11:57 +0000 Subject: [PATCH 068/156] two fixes svn: r14629 --- collects/typed-scheme/typecheck/tc-expr-unit.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 9640ef5a90..1abb555079 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -129,7 +129,7 @@ [((tc-results: t1) (tc-results: t2)) (unless (andmap subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - (ret expected)] + expected] [((tc-result1: t1) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) @@ -139,6 +139,7 @@ (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected])) +;; tc-expr/check : syntax tc-results -> tc-results (define (tc-expr/check form expected) (parameterize ([current-orig-stx form]) ;(printf "form: ~a~n" (syntax-object->datum form)) @@ -149,8 +150,7 @@ [ret (lambda args (define te (apply ret args)) - (check-below te expected) - (ret expected))]) + (check-below te expected))]) (kernel-syntax-case* form #f (letrec-syntaxes+values find-method/who) ;; letrec-syntaxes+values is not in kernel-syntax-case literals [stx From 4d8ba2bca691a99f48a332b1c3cc4dab7f61d7dd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 20:15:14 +0000 Subject: [PATCH 069/156] use correct constructor svn: r14630 --- collects/typed-scheme/typecheck/tc-expr-unit.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 1abb555079..dd4edaa512 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -107,8 +107,8 @@ (define (tc-id id) (let* ([ty (lookup-type/lexical id)]) (ret ty - (make-LFilterSet (list (make-NotTypeFilter (-val #f) null id)) - (list (make-TypeFilter (-val #f) null id))) + (make-FilterSet (list (make-NotTypeFilter (-val #f) null id)) + (list (make-TypeFilter (-val #f) null id))) (make-Path null id)))) ;; typecheck an expression, but throw away the effect From 9853ae1f0f0d7c4791bc2237ab8183f6102ffa50 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 21:16:34 +0000 Subject: [PATCH 070/156] Lots more fixes svn: r14631 --- .../typed-scheme/typecheck/tc-expr-unit.ss | 83 ++++++++++--------- .../typed-scheme/typecheck/tc-lambda-unit.ss | 31 ++++--- collects/typed-scheme/typed-scheme.ss | 43 +++++----- collects/typed-scheme/types/abbrev.ss | 4 +- collects/typed-scheme/types/printer.ss | 3 +- 5 files changed, 86 insertions(+), 78 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index dd4edaa512..9dbc9eab15 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -62,44 +62,51 @@ [#f null] [(cons a b) (cons a (loop b))] [e (list e)]))) - (for/fold ([ty ty]) - ([inst (in-improper-stx inst)]) - (cond [(not inst) ty] - [(not (or (Poly? ty) (PolyDots? ty))) - (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)] - - [(and (Poly? ty) - (not (= (length (syntax->list inst)) (Poly-n ty)))) + (match ty + [(list ty) + (list + (for/fold ([ty ty]) + ([inst (in-improper-stx inst)]) + (cond [(not inst) ty] + [(not (or (Poly? ty) (PolyDots? ty))) + (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)] + [(and (Poly? ty) + (not (= (length (syntax->list inst)) (Poly-n ty)))) + (tc-error/expr #:return (Un) + "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" + ty (Poly-n ty) (length (syntax->list inst)))] + [(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty))))) + ;; we can provide 0 arguments for the ... var + (tc-error/expr #:return (Un) + "Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a" + ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))] + [(PolyDots? ty) + ;; In this case, we need to check the last thing. If it's a dotted var, then we need to + ;; use instantiate-poly-dotted, otherwise we do the normal thing. + (let-values ([(all-but-last last-stx) (split-last (syntax->list inst))]) + (match (syntax-e last-stx) + [(cons last-ty-stx (? identifier? last-id-stx)) + (unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f))) + (tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx))) + (if (= (length all-but-last) (sub1 (PolyDots-n ty))) + (let* ([last-id (syntax-e last-id-stx)] + [last-ty + (parameterize ([current-tvars (extend-env (list last-id) + (list (make-DottedBoth (make-F last-id))) + (current-tvars))]) + (parse-type last-ty-stx))]) + (instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id)) + (tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" + ty (sub1 (PolyDots-n ty)) (length all-but-last)))] + [_ + (instantiate-poly ty (map parse-type (syntax->list inst)))]))] + [else + (instantiate-poly ty (map parse-type (syntax->list inst)))])))] + [_ (if inst (tc-error/expr #:return (Un) - "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" - ty (Poly-n ty) (length (syntax->list inst)))] - [(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty))))) - ;; we can provide 0 arguments for the ... var - (tc-error/expr #:return (Un) - "Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a" - ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))] - [(PolyDots? ty) - ;; In this case, we need to check the last thing. If it's a dotted var, then we need to - ;; use instantiate-poly-dotted, otherwise we do the normal thing. - (let-values ([(all-but-last last-stx) (split-last (syntax->list inst))]) - (match (syntax-e last-stx) - [(cons last-ty-stx (? identifier? last-id-stx)) - (unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f))) - (tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx))) - (if (= (length all-but-last) (sub1 (PolyDots-n ty))) - (let* ([last-id (syntax-e last-id-stx)] - [last-ty - (parameterize ([current-tvars (extend-env (list last-id) - (list (make-DottedBoth (make-F last-id))) - (current-tvars))]) - (parse-type last-ty-stx))]) - (instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id)) - (tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" - ty (sub1 (PolyDots-n ty)) (length all-but-last)))] - [_ - (instantiate-poly ty (map parse-type (syntax->list inst)))]))] - [else - (instantiate-poly ty (map parse-type (syntax->list inst)))]))) + "Cannot instantiate expression that produces ~a values" + (if (null? ty) 0 "multiple")) + ty)])) ;; typecheck an identifier ;; the identifier has variable effect @@ -324,7 +331,7 @@ (match ty [(tc-results: ts fs os) (let ([ts* (do-inst form ts)]) - (ret ts fs os))])))) + (ret ts* fs os))])))) (define (tc/send rcvr method args [expected #f]) (match (tc-expr rcvr) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index c6dbd98474..5a61406940 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -204,21 +204,6 @@ (cons (car bodies) bodies*) (cons (syntax-len (car formals)) nums-seen))])))) -;; tc/lambda : syntax syntax-list syntax-list -> tc-result -(define (tc/lambda form formals bodies) - (tc/lambda/internal form formals bodies #f)) - -;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic -;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result -(define (tc/lambda/internal form formals bodies expected) - (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) - (tc/plambda form formals bodies expected) - (ret (tc/mono-lambda formals bodies expected)))) - -;; tc/lambda : syntax syntax-list syntax-list Type -> tc-result -(define (tc/lambda/check form formals bodies expected) - (tc/lambda/internal form formals bodies expected)) - ;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; formals and bodies must by syntax-lists (define (tc/plambda form formals bodies expected) @@ -279,7 +264,21 @@ (unless (check-below (tc/plambda form formals bodies #f) expected) (tc-error/expr #:return (ret expected) "Expected a value of type ~a, but got a polymorphic function." expected)) (ret expected)])) - + +;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic +;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result +(define (tc/lambda/internal form formals bodies expected) + (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) + (tc/plambda form formals bodies expected) + (ret (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))))) + +;; tc/lambda : syntax syntax-list syntax-list -> tc-result +(define (tc/lambda form formals bodies) + (tc/lambda/internal form formals bodies #f)) + +;; tc/lambda/check : syntax syntax-list syntax-list Type -> tc-result +(define (tc/lambda/check form formals bodies expected) + (tc/lambda/internal form formals bodies expected)) ;; form : a syntax object for error reporting ;; formals : the formal arguments to the loop diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index d6bb00ec51..5a43f819f0 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -4,6 +4,7 @@ (require (private base-types) (for-syntax + (except-in stxclass id) scheme/base (private type-contract) (types utils convenience) @@ -117,28 +118,28 @@ [expanded-module-stx body2])] ;; typecheck the body, and produce syntax-time code that registers types [let ([type (tc-toplevel-form body2)])]) - (kernel-syntax-case body2 #f - [(head . _) - (or (free-identifier=? #'head #'define-values) - (free-identifier=? #'head #'define-syntaxes) - (free-identifier=? #'head #'require) - (free-identifier=? #'head #'provide) - (free-identifier=? #'head #'begin) - (void? type) - (type-equal? -Void (tc-result-t type))) + (define-syntax-class invis-kw + #:literals (define-values define-syntaxes require provide begin) + (pattern define-values) + (pattern define-syntaxes) + (pattern require) + (pattern provide) + (pattern begin)) + (syntax-parse body2 + [(head:invis-kw . _) body2] - ;; construct code to print the type - [_ - (nest - ([with-syntax ([b body2] - [ty-str (match type - [(tc-result: t) - (format "- : ~a\n" t)] - [x (int-err "bad type result: ~a" x)])])]) - #`(let ([v b] [type 'ty-str]) - (begin0 - v - (printf type))))]))])) + [_ (let ([ty-str (match type + [(tc-result1: t) + (if (type-equal? t -Void) + #f + (format "- : ~a\n" t))] + [x (int-err "bad type result: ~a" x)])]) + (if #'ty-str + #`(let ([v #,body2] [type '#,ty-str]) + (begin0 + v + (printf type))) + body2))]))])) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 07e0362760..165dbb6c94 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -158,8 +158,8 @@ #:rest [rest #f] #:drest [drest #f] #:kws [kws null] #:filters [filters -no-lfilter] #:object [obj -no-lobj]) (c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c)) - (#:rest Type/c - #:drest (cons/c Type/c symbol?) + (#:rest (or/c #f Type/c) + #:drest (or/c #f (cons/c Type/c symbol?)) #:kws (listof Keyword?) #:filters LFilterSet? #:object LatentObject?) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 6d919bf664..fee5aa4575 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -141,7 +141,8 @@ [(Box: e) (fp "(Box ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pair ~a ~a)" l r)] - [(F: nm) (fp "~a" nm)] + [(F: nm) (fp "~a" nm)] + [(Values: (list v)) (fp "~a" v)] [(Values: (list v ...)) (fp "~a" (cons 'values v))] [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))] [(Param: in out) From af7b966c82cf3ed41ec4a3acf37e5503033ce912 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 21:58:35 +0000 Subject: [PATCH 071/156] more contracts more fixes svn: r14632 --- collects/typed-scheme/env/type-environments.ss | 5 +++-- collects/typed-scheme/typecheck/tc-envops.ss | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index b62d7d024a..3a0b5679a1 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -20,7 +20,7 @@ with-dotted-env/extend) ;; eq? has the type of equal?, and l is an alist (with conses!) -(define-struct env (eq? l)) +(r:d-s/c env ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)])) (define (env-vals e) (map cdr (env-l e))) @@ -45,7 +45,8 @@ ;; the environment for types of ... variables (define dotted-env (make-parameter (make-empty-env free-identifier=?))) -(define (env-map f env) +(define/contract (env-map f env) + ((pair? . -> . pair?) env? . -> . env?) (make-env (env-eq? env) (map f (env-l env)))) ;; extend that works on single arguments diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index a7fa27867a..292391ed00 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -50,6 +50,6 @@ (env? (listof Filter/c) . -> . env?) (for/fold ([Γ env]) ([f fs]) (match f - [(Bot:) (env-map (lambda (_) (Un)) Γ)] + [(Bot:) (env-map (lambda (x) (cons (car x) (Un))) Γ)] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) (update-type/lexical (lambda (x t) (update t f)) x Γ)]))) From dfbfc371e25badd5bae47a0f099466e19fe2010a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 22:24:47 +0000 Subject: [PATCH 072/156] more printer improvements svn: r14633 --- collects/typed-scheme/types/printer.ss | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index fee5aa4575..5aa5fcc454 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -89,7 +89,15 @@ (fp "~a* " rest)) (when drest (fp "~a ... ~a " (car drest) (cdr drest))) - (fp "-> ~a" rng) + (match rng + [(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:)))) + (fp "-> ~a" t)] + [(Values: (list (Result: t fs (LEmpty:)))) + (fp "-> ~a : ~a" t fs)] + [(Values: (list (Result: t lf lo))) + (fp "-> ~a : ~a ~a" t lf lo)] + [_ + (fp "-> ~a" rng)]) (fp ")")])) (define (tuple? t) (match t From 2e2e9b8acf4cb8e48327f4f29229577bee19a006 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 22:44:42 +0000 Subject: [PATCH 073/156] fixes for plambda svn: r14634 --- collects/typed-scheme/test.ss | 11 ++++++++ .../typed-scheme/typecheck/tc-lambda-unit.ss | 25 +++++++++++-------- 2 files changed, 25 insertions(+), 11 deletions(-) create mode 100644 collects/typed-scheme/test.ss diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss new file mode 100644 index 0000000000..a5354a7f8c --- /dev/null +++ b/collects/typed-scheme/test.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(define: x : (U Number #f) 1) +(if x #{x :: Number} 1) +(lambda () 1) +(lambda: ([y : Number]) (if #t y y)) + +(plambda: (a) ([y : Number]) (if y #t #f)) +(plambda: (a) ([y : a]) y) +(plambda: (a) ([y : a]) y) +(plambda: () ([y : Boolean]) (if y #t #f)) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 5a61406940..8309340ca4 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -204,12 +204,15 @@ (cons (car bodies) bodies*) (cons (syntax-len (car formals)) nums-seen))])))) +(define (tc/mono-lambda/type formals bodies expected) + (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) + ;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; formals and bodies must by syntax-lists (define (tc/plambda form formals bodies expected) (define (maybe-loop form formals bodies expected) (match expected - [(Function: _) (tc/mono-lambda formals bodies expected)] + [(Function: _) (tc/mono-lambda/type formals bodies expected)] [(or (Poly: _ _) (PolyDots: _ _)) (tc/plambda form formals bodies expected)])) (match expected @@ -224,7 +227,7 @@ [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) (maybe-loop form formals bodies expected*))]) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) - (ret expected))] + expected)] [(PolyDots-names: (list ns ... dvar) expected*) (let-values ([(tvars dotted) @@ -242,7 +245,7 @@ new-tvars) (current-tvars))]) (maybe-loop form formals bodies expected*))]) - (ret expected)))] + expected))] [#f (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda))) [(list tvars ... dotted-var '...) @@ -251,26 +254,26 @@ [ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars) (cons (make-Dotted (make-F dotted-var)) new-tvars) (current-tvars))]) - (tc/mono-lambda formals bodies #f))]) - (ret (make-PolyDots (append literal-tvars (list dotted-var)) ty)))] + (tc/mono-lambda/type formals bodies #f))]) + (make-PolyDots (append literal-tvars (list dotted-var)) ty))] [tvars (let* ([literal-tvars tvars] [new-tvars (map make-F literal-tvars)] [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) - (tc/mono-lambda formals bodies #f))]) + (tc/mono-lambda/type formals bodies #f))]) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) - (ret (make-Poly literal-tvars ty)))])] + (make-Poly literal-tvars ty))])] [_ (unless (check-below (tc/plambda form formals bodies #f) expected) - (tc-error/expr #:return (ret expected) "Expected a value of type ~a, but got a polymorphic function." expected)) - (ret expected)])) + (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected)) + expected])) ;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic ;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result (define (tc/lambda/internal form formals bodies expected) (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) - (tc/plambda form formals bodies expected) - (ret (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))))) + (ret (tc/plambda form formals bodies expected)) + (ret (tc/mono-lambda/type formals bodies expected)))) ;; tc/lambda : syntax syntax-list syntax-list -> tc-result (define (tc/lambda form formals bodies) From 5a49e92de7e48a52482a3287846a8a37b8d42de4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 27 Apr 2009 23:25:34 +0000 Subject: [PATCH 074/156] lots of let improvements and check rationalization svn: r14635 --- collects/typed-scheme/test.ss | 11 ++++++++++ collects/typed-scheme/typecheck/signatures.ss | 8 ++++---- .../typed-scheme/typecheck/tc-expr-unit.ss | 20 +++++++++++-------- .../typed-scheme/typecheck/tc-let-unit.ss | 3 ++- 4 files changed, 29 insertions(+), 13 deletions(-) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index a5354a7f8c..90be8df4a1 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -9,3 +9,14 @@ (plambda: (a) ([y : a]) y) (plambda: (a) ([y : a]) y) (plambda: () ([y : Boolean]) (if y #t #f)) + +#{(if #t #t #t) :: Boolean} + +(let () 3) +(let ([x 1] [y 2]) x) +#{(let ([x 1] [y 2]) x) :: Number} +(let: ([x : Number 1] [y : Integer 2]) x) +#{(let: ([x : Integer 1] [y : Integer 2]) x) :: Integer} + +#{(let*: ([x : Number 1] [x : Integer 2]) x) :: Integer} + diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index c68b5e95e1..577dbd2b98 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -12,11 +12,11 @@ (define-signature tc-expr^ ([cnt tc-expr (syntax? . -> . tc-results?)] [cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)] - [cnt tc-expr/check/t (syntax? Type/c . -> . Type/c)] + [cnt tc-expr/check/t (syntax? tc-results? . -> . Type/c)] [cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])] ;[cnt tc-literal (any/c . -> . Type/c)] [cnt tc-exprs ((listof syntax?) . -> . tc-results?)] - [cnt tc-exprs/check ((listof syntax?) Type/c . -> . tc-results?)] + [cnt tc-exprs/check ((listof syntax?) tc-results? . -> . tc-results?)] [cnt tc-expr/t (syntax? . -> . Type/c)])) (define-signature check-subforms^ @@ -26,11 +26,11 @@ (define-signature tc-if^ ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-results?)] - [cnt tc/if-twoarm/check (syntax? syntax? syntax? Type/c . -> . tc-results?)])) + [cnt tc/if-twoarm/check (syntax? syntax? syntax? tc-results? . -> . tc-results?)])) (define-signature tc-lambda^ ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-results?)] - [cnt tc/lambda/check (syntax? syntax? syntax? Type/c . -> . tc-results?)] + [cnt tc/lambda/check (syntax? syntax? syntax? tc-results? . -> . tc-results?)] [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) Type/c . -> . Type/c)])) (define-signature tc-app^ diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 9dbc9eab15..aaee854b5e 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -126,7 +126,7 @@ (define (tc-expr/check/t e t) (match (tc-expr/check e t) - [(tc-result: t) t])) + [(tc-result1: t) t])) ;; check-below : (/\ (Results Type -> Result) ;; (Results Results -> Result) @@ -146,6 +146,10 @@ (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected])) +(define (tc-expr/check/type form expected) + #;(syntax? Type/c . -> . tc-results?) + (tc-expr/check form (ret expected))) + ;; tc-expr/check : syntax tc-results -> tc-results (define (tc-expr/check form expected) (parameterize ([current-orig-stx form]) @@ -194,8 +198,8 @@ (check-below (tc-id #'x) expected)] ;; w-c-m [(with-continuation-mark e1 e2 e3) - (begin (tc-expr/check #'e1 Univ) - (tc-expr/check #'e2 Univ) + (begin (tc-expr/check/type #'e1 Univ) + (tc-expr/check/type #'e2 Univ) (tc-expr/check #'e3 expected))] ;; application [(#%plain-app . _) (tc/app/check form expected)] @@ -264,8 +268,8 @@ [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))] ;; w-c-m [(with-continuation-mark e1 e2 e3) - (begin (tc-expr/check #'e1 Univ) - (tc-expr/check #'e2 Univ) + (begin (tc-expr/check/type #'e1 Univ) + (tc-expr/check/type #'e2 Univ) (tc-expr #'e3))] ;; lambda [(#%plain-lambda formals . body) @@ -326,7 +330,7 @@ (int-err "bad form input to tc-expr: ~a" form)) ;; typecheck form (let ([ty (cond [(type-ascription form) => (lambda (ann) - (tc-expr/check form ann))] + (tc-expr/check/type form ann))] [else (internal-tc-expr form)])]) (match ty [(tc-results: ts fs os) @@ -353,11 +357,11 @@ (define (tc-exprs exprs) (cond [(null? exprs) (ret -Void)] [(null? (cdr exprs)) (tc-expr (car exprs))] - [else (tc-expr/check (car exprs) Univ) + [else (tc-expr/check/type (car exprs) Univ) (tc-exprs (cdr exprs))])) (define (tc-exprs/check exprs expected) (cond [(null? exprs) (check-below (ret -Void) expected)] [(null? (cdr exprs)) (tc-expr/check (car exprs) expected)] - [else (tc-expr/check (car exprs) Univ) + [else (tc-expr/check/type (car exprs) Univ) (tc-exprs/check (cdr exprs) expected)])) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index c8a3a1ce10..81ae266815 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -126,7 +126,8 @@ ;; the types of the exprs #;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)] ;; the annotated types of the name (possibly using the inferred types) - [types (for/list ([name names] [e exprs]) (get-type/infer name e (tc-expr-t/maybe-expected expected) tc-expr/check/t))] + [types (for/list ([name names] [e exprs]) (get-type/infer name e (tc-expr-t/maybe-expected expected) + (lambda (e t) (tc-expr/check/t e (ret t)))))] ;; the clauses for error reporting [clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])]) (do-check void names types form types body clauses expected))) From 9118e9ef1263e0d92959b8b96f81c25684e67204 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 28 Apr 2009 14:24:09 +0000 Subject: [PATCH 075/156] Fixes for letrec. svn: r14638 --- collects/typed-scheme/test.ss | 19 ++++++++++ .../typed-scheme/typecheck/tc-lambda-unit.ss | 35 +++++++++---------- .../typed-scheme/typecheck/tc-let-unit.ss | 7 ++-- collects/typed-scheme/utils/utils.ss | 2 +- 4 files changed, 40 insertions(+), 23 deletions(-) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index 90be8df4a1..bf99f4870f 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -19,4 +19,23 @@ #{(let: ([x : Integer 1] [y : Integer 2]) x) :: Integer} #{(let*: ([x : Number 1] [x : Integer 2]) x) :: Integer} +#{(let*: ([x : Number 1] [x : Integer 2]) #{x :: Integer}) :: Integer} + +#{(letrec: ([x : Integer 1] [y : Integer 2]) #{x :: Integer}) :: Integer} +(letrec: ([x : Integer 1] [y : Integer 2]) #{x :: Integer}) +(let () + (define x 1) + (define y 2) + x) +(letrec: ([z : (-> Any) (lambda () z)]) 1) +(letrec: ([z : (-> Any) (lambda () w)] + [w : (-> Any) (lambda () z)]) z) +(let () + (define: (z) : Any w) + (define: (w) : Any z) + z) +(let () + (define: (z [x : Number]) : Any w) + (define: (w) : Any z) + z) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 8309340ca4..969c7fc8f5 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -175,6 +175,19 @@ [(pair? (syntax-e s)) (+ 1 (loop (cdr (syntax-e s))))] [else 1]))])) + (define (go formals bodies formals* bodies* nums-seen) + (cond + [(null? formals) + (map tc/lambda-clause (reverse formals*) (reverse bodies*))] + [(memv (syntax-len (car formals)) nums-seen) + ;; we check this clause, but it doesn't contribute to the overall type + (tc/lambda-clause (car formals) (car bodies)) + (go (cdr formals) (cdr bodies) formals* bodies* nums-seen)] + [else + (go (cdr formals) (cdr bodies) + (cons (car formals) formals*) + (cons (car bodies) bodies*) + (cons (syntax-len (car formals)) nums-seen))])) (if (and expected (= 1 (length (syntax->list formals)))) ;; special case for not-case-lambda @@ -184,25 +197,9 @@ [(Function: (list (arr: argss rets rests drests '()) ...)) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))] - [t (let ([t (tc/mono-lambda formals bodies #f)]) - (check-below t expected))])) - (let loop ([formals (syntax->list formals)] - [bodies (syntax->list bodies)] - [formals* null] - [bodies* null] - [nums-seen null]) - (cond - [(null? formals) - (map tc/lambda-clause (reverse formals*) (reverse bodies*))] - [(memv (syntax-len (car formals)) nums-seen) - ;; we check this clause, but it doesn't contribute to the overall type - (tc/lambda-clause (car formals) (car bodies)) - (loop (cdr formals) (cdr bodies) formals* bodies* nums-seen)] - [else - (loop (cdr formals) (cdr bodies) - (cons (car formals) formals*) - (cons (car bodies) bodies*) - (cons (syntax-len (car formals)) nums-seen))])))) + ;; FIXME - is this right? + [_ (go (syntax->list formals) (syntax->list bodies) null null null)])) + (go (syntax->list formals) (syntax->list bodies) null null null))) (define (tc/mono-lambda/type formals bodies expected) (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 81ae266815..06083a25cd 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -29,7 +29,7 @@ (for-each expr->type clauses exprs - (map -values types)) + (map ret types)) (if expected (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body))))) @@ -73,7 +73,7 @@ (tc-expr/check e (mk expecteds)) (tc-expr e))) (match tcr - [(tc-result: t) t])) + [(tc-result1: t) t])) (define (tc/letrec-values/internal namess exprs body form expected) (let* ([names (map syntax->list (syntax->list namess))] @@ -100,7 +100,8 @@ ;; then check this expression separately (with-lexical-env/extend (list (car names)) - (list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) tc-expr/check/t)) + (list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) + (lambda (e t) (tc-expr/check/t e (ret t))))) (loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))] [else ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index a2503c86e9..a321e257d2 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -190,7 +190,7 @@ at least theoretically. [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #t) +(define-for-syntax printing? #f) (define-syntax-rule (defprinter t ...) (begin From 077574cfe1192c2004b2b1528c103f6b58524359 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 28 Apr 2009 14:48:53 +0000 Subject: [PATCH 076/156] more fixes for lambda with expected svn: r14639 --- collects/typed-scheme/test.ss | 5 +++++ collects/typed-scheme/typecheck/tc-expr-unit.ss | 14 ++++++++++++-- collects/typed-scheme/typecheck/tc-lambda-unit.ss | 5 ++++- collects/typed-scheme/types/printer.ss | 3 ++- collects/typed-scheme/utils/utils.ss | 2 +- 5 files changed, 24 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index bf99f4870f..ea249073ad 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -38,4 +38,9 @@ (define: (z [x : Number]) : Any w) (define: (w) : Any z) z) +(case-lambda: [() 1] + [([x : Number]) x]) +;; Error +#;#{(case-lambda: [() 1] + [([x : Number]) x]) :: String} diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index aaee854b5e..075cc095c0 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -130,6 +130,7 @@ ;; check-below : (/\ (Results Type -> Result) ;; (Results Results -> Result) +;; (Type Results -> Type) ;; (Type Type -> Type)) (define (check-below tr1 expected) (match* (tr1 expected) @@ -137,10 +138,19 @@ (unless (andmap subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected] - [((tc-result1: t1) (? Type? t2)) + [((tc-result1: t1 f o) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - (ret expected)] + (ret t2 f o)] + [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:))) + (unless (subtype t1 t2) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + t1] + [((? Type? t1) (tc-result1: t2 f o)) + (if (subtype t1 t2) + (tc-error/expr "Expected result with filter ~a and object ~a, got ~a" f o t1) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + t1] [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 969c7fc8f5..ae4f4296dd 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -202,7 +202,10 @@ (go (syntax->list formals) (syntax->list bodies) null null null))) (define (tc/mono-lambda/type formals bodies expected) - (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) + (define t (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) + (if expected + (check-below t expected) + t)) ;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; formals and bodies must by syntax-lists diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 5aa5fcc454..cc5b3673c3 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -150,7 +150,8 @@ [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pair ~a ~a)" l r)] [(F: nm) (fp "~a" nm)] - [(Values: (list v)) (fp "~a" v)] + ;; FIXME + ;[(Values: (list v)) (fp "~a" v)] [(Values: (list v ...)) (fp "~a" (cons 'values v))] [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))] [(Param: in out) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index a321e257d2..a2503c86e9 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -190,7 +190,7 @@ at least theoretically. [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #f) +(define-for-syntax printing? #t) (define-syntax-rule (defprinter t ...) (begin From 7b6702c9e77f1ea1e4adcf52c62cd4fa74cd1a44 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 28 Apr 2009 14:56:18 +0000 Subject: [PATCH 077/156] fix subtyping w/ filters svn: r14640 --- collects/typed-scheme/test.ss | 5 +++++ collects/typed-scheme/typecheck/tc-expr-unit.ss | 10 +++++----- collects/typed-scheme/types/subtype.ss | 9 +++++++++ 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index ea249073ad..097675c064 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -43,4 +43,9 @@ ;; Error #;#{(case-lambda: [() 1] [([x : Number]) x]) :: String} +#{(lambda: ([x : Number]) 1) :: (Number -> Number)} +#{(lambda: ([x : Number]) 1) :: Any} +#{(lambda: ([x : Number]) 1) :: (Integer -> Any)} +#{(lambda: ([x : Number]) x) :: (Number -> Number)} +#{(lambda: ([x : Number]) x) :: (Integer -> Any)} diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 075cc095c0..c1fb45ec57 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -136,24 +136,24 @@ (match* (tr1 expected) [((tc-results: t1) (tc-results: t2)) (unless (andmap subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) expected] [((tc-result1: t1 f o) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) (ret t2 f o)] [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:))) (unless (subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "3 Expected ~a, but got ~a" t2 t1)) t1] [((? Type? t1) (tc-result1: t2 f o)) (if (subtype t1 t2) (tc-error/expr "Expected result with filter ~a and object ~a, got ~a" f o t1) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "4 Expected ~a, but got ~a" t2 t1)) t1] [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "5 Expected ~a, but got ~a" t2 t1)) expected])) (define (tc-expr/check/type form expected) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 14f2ab3c0d..4c154e5c27 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -125,6 +125,12 @@ (match* (s t) ;; top for functions is above everything [(_ (top-arr:)) A0] + ;; the really simple case + [((arr: s1 s2 #f #f '()) + (arr: t1 t2 #f #f '())) + (subtype-seq A0 + (subtypes* t1 s1) + (subtype* s2 t2))] [((arr: s1 s2 #f #f s-kws) (arr: t1 t2 #f #f t-kws)) (subtype-seq A0 @@ -301,6 +307,9 @@ ;; trivial case for Result [(list (Result: t f o) (Result: t* f o)) (subtype* A0 t t*)] + ;; we can ignore interesting results + [(list (Result: t f o) (Result: t* (LFilterSet: (list) (list)) (LEmpty:))) + (subtype* A0 t t*)] ;; single values shouldn't actually happen, but they're just like the type [(list t (Values: (list t*))) (int-err "BUG - singleton values type~a" (make-Values (list t*)))] [(list (Values: (list t)) t*) (int-err "BUG - singleton values type~a" (make-Values (list t)))] From ce0032f4c5d1262848d58f48d6846446b3f46f28 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 28 Apr 2009 18:53:16 +0000 Subject: [PATCH 078/156] a couple small fixes svn: r14643 --- collects/typed-scheme/test.ss | 4 ++++ collects/typed-scheme/typecheck/tc-expr-unit.ss | 4 ++-- collects/typed-scheme/typecheck/tc-toplevel.ss | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index 097675c064..c4733b51f9 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -48,4 +48,8 @@ #{(lambda: ([x : Number]) 1) :: (Integer -> Any)} #{(lambda: ([x : Number]) x) :: (Number -> Number)} #{(lambda: ([x : Number]) x) :: (Integer -> Any)} +(define zzz 1) +(set! zzz 2) + +(define-struct: xxx ()) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index c1fb45ec57..831e0dcdf7 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -298,8 +298,8 @@ (tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form)] ;; mutation! [(set! id val) - (match-let* ([(tc-result: id-t) (tc-expr #'id)] - [(tc-result: val-t) (tc-expr #'val)]) + (match-let* ([(tc-result1: id-t) (tc-expr #'id)] + [(tc-result1: val-t) (tc-expr #'val)]) (unless (subtype val-t id-t) (tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) (ret -Void))] diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index dd771af2b8..c3295e29af 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -114,7 +114,7 @@ (begin0 (tc-expr #'expr) (restore-errors!)))) => (match-lambda - [(tc-result: t) + [(tc-result1: t) (register-type (car vars) t) (list (make-def-binding (car vars) t))] [t (int-err "~a is not a tc-result" t)])] From ea03a751137b4be3865258840f84527fd80dcb52 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 29 Apr 2009 14:35:26 +0000 Subject: [PATCH 079/156] Fix p/c handling of rename. svn: r14651 --- collects/typed-scheme/utils/utils.ss | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index a2503c86e9..854d1da3a5 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -266,7 +266,7 @@ at least theoretically. (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) -(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) (define-syntax p/c @@ -274,11 +274,12 @@ at least theoretically. (make-rename-transformer #'provide/contract) (lambda (stx) (define-syntax-class clause - #:literals (rename) + #:literals () #:attributes (i) - (pattern [rename out:id in:id] - #:with i #'(rename-out out in)) - (pattern [i:id c])) + (pattern [rename out:id in:id cnt:expr] + #:when (eq? (syntax-e #'rename) 'rename) + #:with i #'(rename-out [out in])) + (pattern [i:id cnt:expr])) (syntax-parse stx [(_ c:clause ...) #'(provide c.i ...)])))) From 6662b72162602e70ea244532c263bb016b0146d0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 29 Apr 2009 14:35:52 +0000 Subject: [PATCH 080/156] Fix reconstruction of Latents, which do not have keys. svn: r14652 --- collects/typed-scheme/env/init-envs.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index 396c94c4e4..029810693b 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -35,9 +35,11 @@ [(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 (Type? e) - (LatentFilter? e) + [(? (lambda (e) (or (LatentFilter? e) (LatentObject? 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 vals))) `(,(gen-constructor tag) ,@(map sub vals))] [_ (basic v)])) From b205f65bec553659e19641c61b7b5d94bb8e25dd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 29 Apr 2009 16:58:20 +0000 Subject: [PATCH 081/156] more testing svn: r14655 --- collects/typed-scheme/test.ss | 20 +++++++++++++++++++ .../typed-scheme/typecheck/tc-toplevel.ss | 1 + 2 files changed, 21 insertions(+) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index c4733b51f9..148488a5c6 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -52,4 +52,24 @@ (set! zzz 2) (define-struct: xxx ()) +(define-struct: xxx2 ([y : Number])) +(define-struct: xxx3 ([y : Number] [z : Number])) +(define-struct: xxx4 ([y : Number] [z : xxx4])) +(define-struct: xxx5 ([y : Number] [z : xxx4])) +(define-struct: (A) xxx6 ([y : A] [z : xxx4])) +xxx6-y +(with-continuation-mark 1 1 1) +'foo +'(foo foo foo) +(define-type-alias NNN Number) +(define-type-alias (NNN2 A) (Listof Number)) +(define-type-alias (NNN3 A) (Listof A)) +(define-syntax-rule (m x) 1) +(m 2) +#{1 :: 1} +(lambda: ([x : String]) (lambda () (set! x "foo"))) +#'(x y z) +(begin0 1 1 1) +(begin 1 1 1) +(#%expression (begin 1 1 1)) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index c3295e29af..555b7bb836 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -161,6 +161,7 @@ [(define-syntaxes . _) (void)] [(define-values-for-syntax . _) (void)] + ;; FIXME - we no longer need these special cases ;; these forms are handled in pass1 [(define-values () (begin (quote-syntax (require/typed-internal . rest)) (#%plain-app values))) (void)] From e79ece72c524eb8a187bd905dc98a2ebf8b28755 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 29 Apr 2009 19:38:36 +0000 Subject: [PATCH 082/156] copy svn: r14659 --- collects/typed-scheme/typecheck/tc-app.ss | 834 ++++++++++++++++++++++ 1 file changed, 834 insertions(+) create mode 100644 collects/typed-scheme/typecheck/tc-app.ss diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss new file mode 100644 index 0000000000..e0a64c4c64 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -0,0 +1,834 @@ +#lang scheme/unit + +(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer])) +(require "signatures.ss" + stxclass + (for-syntax stxclass) + (rep type-rep effect-rep) + (utils tc-utils) + (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type + type-annotation) + (r:infer infer) + (env type-environments) + (only-in srfi/1 alist-delete) + (only-in scheme/private/class-internal make-object do-make-object) + mzlib/trace mzlib/pretty syntax/kerncase scheme/match + (prefix-in c: scheme/contract) + (for-syntax scheme/base) + (for-template + (only-in '#%kernel [apply k:apply]) + "internal-forms.ss" scheme/base + (only-in scheme/private/class-internal make-object do-make-object))) +(require (r:infer constraint-structs)) + +(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) +(export tc-app^) + +;; comparators that inform the type system +(define (comparator? i) + (or (free-identifier=? i #'eq?) + (free-identifier=? i #'equal?) + (free-identifier=? i #'eqv?) + (free-identifier=? i #'=) + (free-identifier=? i #'string=?))) + +;; typecheck eq? applications +;; identifier identifier expression expression expression +;; identifier expr expr expr expr -> tc-result +(define (tc/eq comparator v1 v2) + (define (e? i) (free-identifier=? i comparator)) + (define (do id val) + (define-syntax alt (syntax-rules () [(_ nm pred ...) + (and (e? #'nm) (or (pred val) ...))])) + (if (or (alt symbol=? symbol?) + (alt string=? string?) + (alt = number?) + (alt eq? boolean? keyword? symbol?) + (alt eqv? boolean? keyword? symbol? number?) + (alt equal? (lambda (x) #t))) + (values (list (make-Restrict-Effect (-val val) id)) + (list (make-Remove-Effect (-val val) id))) + (values (list) (list)))) + (match (list (tc-expr v1) (tc-expr v2)) + [(list (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2))) (tc-result: (Value: val))) + (do id1 val)] + [(list (tc-result: (Value: val)) (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2)))) + (do id1 val)] + [_ (values (list) (list))])) + + +;; typecheck an application: +;; arg-types: the types of the actual parameters +;; arg-effs: the effects of the arguments +;; dom-types: the types of the function's fixed arguments +;; rest-type: the type of the functions's rest parameter, or #f +;; latent-eff: the latent effect of the function +;; arg-stxs: the syntax for each actual parameter, for error reporting +;; [Type] [Type] Maybe[Type] [Syntax] -> (values Listof[Effect] Listof[Effect]) +(define (tc-args arg-types arg-thn-effs arg-els-effs dom-types rest-type latent-thn-eff latent-els-eff arg-stxs) + (define (var-true-effect-v e) (match e + [(Var-True-Effect: v) v])) + (define (var-false-effect-v e) (match e + [(Var-False-Effect: v) v])) + ;; special case for predicates: + (if (and (not (null? latent-thn-eff)) + (not (null? latent-els-eff)) + (not rest-type) + ;(printf "got to =~n") + (= (length arg-types) (length dom-types) 1) + ;(printf "got to var preds~n") + (= (length (car arg-thn-effs)) (length (car arg-els-effs)) 1) + (Var-True-Effect? (caar arg-thn-effs)) ;; thn-effs is a list for each arg + (Var-False-Effect? (caar arg-els-effs)) ;; same with els-effs + (free-identifier=? (var-true-effect-v (caar arg-thn-effs)) + (var-false-effect-v (caar arg-els-effs))) + (subtype (car arg-types) (car dom-types))) + ;; then this was a predicate application, so we construct the appropriate type effect + (values (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-thn-eff) + (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-els-eff)) + ;; otherwise, we just ignore the effects. + (let loop ([args arg-types] [doms dom-types] [stxs arg-stxs] [arg-count 1]) + (cond + [(and (null? args) (null? doms)) (values null null)] ;; here, we just return the empty effect + [(null? args) + (tc-error/delayed + "Insufficient arguments to function application, expected ~a, got ~a" + (length dom-types) (length arg-types)) + (values null null)] + [(and (null? doms) rest-type) + (if (subtype (car args) rest-type) + (loop (cdr args) doms (cdr stxs) (add1 arg-count)) + (begin + (tc-error/delayed #:stx (car stxs) + "Rest argument had wrong type, expected: ~a and got: ~a" + rest-type (car args)) + (values null null)))] + [(null? doms) + (tc-error/delayed "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types)) + (values null null)] + [(subtype (car args) (car doms)) + (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))] + [else + (tc-error/delayed + #:stx (car stxs) + "Wrong function argument type, expected ~a, got ~a for argument ~a" + (car doms) (car args) arg-count) + (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))])))) + + +;(trace tc-args) + +(define (stringify-domain dom rst drst [rng #f]) + (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] + [rng-string (if rng (format " -> ~a" rng) "")]) + (cond [drst + (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] + [rst + (format "~a~a *~a" doms-string rst rng-string)] + [else (string-append (stringify dom) rng-string)]))) + +(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) + (define arguments-str + (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f))) + (cond + [(null? doms) + (int-err "How could doms be null: ~a ~a" ty)] + [(= 1 (length doms)) + (format "Domain: ~a~nArguments: ~a~n~a" + (stringify-domain (car doms) (car rests) (car drests)) + arguments-str + (if expected + (format "Result type: ~a~nExpected result: ~a~n" + (car rngs) expected) + ""))] + [else + (format "~a: ~a~nArguments: ~a~n~a" + (if expected "Types" "Domains") + (stringify (if expected + (map stringify-domain doms rests drests rngs) + (map stringify-domain doms rests drests)) + "~n\t") + arguments-str + (if expected + (format "Expected result: ~a~n" expected) + ""))])) + +(define (do-apply-log subst fun arg) + (match* (fun arg) + [('star 'list) (printf/log "Polymorphic apply called with uniform rest arg, list argument\n")] + [('star 'dots) (printf/log "Polymorphic apply called with uniform rest arg, dotted argument\n")] + [('dots 'dots) (printf/log "Polymorphic apply called with non-uniform rest arg, dotted argument\n")]) + (log-result subst)) + +(define (tc/apply f args) + (define f-ty (tc-expr f)) + ;; produces the first n-1 elements of the list, and the last element + (define (split l) + (let loop ([l l] [acc '()]) + (if (null? (cdr l)) + (values (reverse acc) (car l)) + (loop (cdr l) (cons (car l) acc))))) + (define-values (fixed-args tail) (split (syntax->list args))) + + (match f-ty + [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) + (when (null? doms) + (tc-error/expr #:return (ret (Un)) + "empty case-lambda given as argument to apply")) + (let ([arg-tys (map tc-expr/t fixed-args)]) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (cond [(null? doms*) + (let-values ([(tail-ty tail-bound) + (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))]) + (tc/dots tail))]) + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to function in apply:~n" + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))] + [(and (car rests*) + (let-values ([(tail-ty tail-bound) + (with-handlers ([exn:fail? (lambda _ (values #f #f))]) + (tc/dots tail))]) + (and tail-ty + (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty)) + (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) + (printf/log "Non-poly apply, ... arg\n") + (ret (car rngs*))] + [(and (car rests*) + (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)]) + (tc-expr/t tail))]) + (and tail-ty + (subtype (apply -lst* arg-tys #:tail tail-ty) + (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) + + (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) + "Simple arithmetic non-poly apply\n" + "Simple non-poly apply\n")) + (ret (car rngs*))] + [(and (car drests*) + (let-values ([(tail-ty tail-bound) + (with-handlers ([exn:fail? (lambda _ (values #f #f))]) + (tc/dots tail))]) + (and tail-ty + (eq? (cdr (car drests*)) tail-bound) + (subtypes arg-tys (car doms*)) + (subtype tail-ty (car (car drests*)))))) + (printf/log "Non-poly apply, ... arg\n") + (ret (car rngs*))] + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) + (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) + (tc/dots tail))]) + #;(for-each (lambda (x) (unless (not (Poly? x)) + (tc-error "Polymorphic argument of type ~a to polymorphic function in apply not allowed" x))) + (cons tail-ty arg-tys)) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (cond [(null? doms*) + (match f-ty + [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to polymorphic function in apply:~n" + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + ;; the actual work, when we have a * function and a list final argument + [(and (car rests*) + (not tail-bound) + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons tail-ty arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; actual work, when we have a * function and ... final arg + [(and (car rests*) + tail-bound + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons (make-Listof tail-ty) arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg + [(and (car drests*) + tail-bound + (eq? tail-bound (cdr (car drests*))) + (= (length (car doms*)) + (length arg-tys)) + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; if nothing matches, around the loop again + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result: (Poly: vars (Function: '()))) + (tc-error/expr #:return (ret (Un)) + "Function has no cases")] + [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) + (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) + (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) + (tc/dots tail))]) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (cond [(null? doms*) + (match f-ty + [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to polymorphic function in apply:~n" + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + ;; the actual work, when we have a * function and a list final argument + [(and (car rests*) + (not tail-bound) + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons tail-ty arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) + (do-apply-log substitution 'star 'list) + (ret (subst-all substitution (car rngs*))))] + ;; actual work, when we have a * function and ... final arg + [(and (car rests*) + tail-bound + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons (make-Listof tail-ty) arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) + (do-apply-log substitution 'star 'dots) + (ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg, same bound on ... + [(and (car drests*) + tail-bound + (eq? tail-bound (cdr (car drests*))) + (= (length (car doms*)) + (length arg-tys)) + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (do-apply-log substitution 'dots 'dots) + (ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg, different bound on ... + [(and (car drests*) + tail-bound + (not (eq? tail-bound (cdr (car drests*)))) + (= (length (car doms*)) + (length arg-tys)) + (parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*))) + (list (make-DottedBoth (make-F tail-bound)) + (make-DottedBoth (make-F (cdr (car drests*))))) + (current-tvars))]) + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (do-apply-log substitution 'dots 'dots) + (ret (substitute-dotted (cadr (assq drest-bound substitution)) + tail-bound + drest-bound + (subst-all (alist-delete drest-bound substitution eq?) + (car rngs*)))))] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (do-apply-log substitution 'dots 'dots) + (ret (subst-all substitution (car rngs*))))] + ;; if nothing matches, around the loop again + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result: (PolyDots: vars (Function: '()))) + (tc-error/expr #:return (ret (Un)) + "Function has no cases")] + [(tc-result: f-ty) (tc-error/expr #:return (ret (Un)) + "Type of argument to apply is not a function type: ~n~a" f-ty)])) + + + +(define (log-result subst) + (define (dmap-length d) + (match d + [(struct dcon (fixed rest)) (length fixed)] + [(struct dcon-exact (fixed rest)) (length fixed)])) + (define (dmap-rest? d) + (match d + [(struct dcon (fixed rest)) rest] + [(struct dcon-exact (fixed rest)) rest])) + (if (list? subst) + (for ([s subst]) + (match s + [(list v (list imgs ...) starred) + (printf/log "Instantiated ... variable ~a with ~a types\n" v (length imgs))] + [_ (void)])) + (for* ([(cmap dmap) (in-pairs (cset-maps subst))] + [(k v) (dmap-map dmap)]) + (printf/log "Instantiated ... variable ~a with ~a types~a\n" k (dmap-length v) + (if (dmap-rest? v) + " and a starred type" + ""))))) + +(define-syntax (handle-clauses stx) + (syntax-parse stx + [(_ (lsts ... rngs) f-stx pred infer t argtypes expected) + (with-syntax ([(vars ... rng) (generate-temporaries #'(lsts ... rngs))]) + (syntax/loc stx + (or (for/or ([vars lsts] ... [rng rngs] + #:when (pred vars ... rng)) + (let ([substitution (infer vars ... rng)]) + (and substitution + (log-result substitution) + (ret (or expected + (subst-all substitution rng)))))) + (poly-fail t argtypes #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) + +(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) + (match t + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) + (let ([fcn-string (if name + (format "function ~a" (syntax->datum name)) + "function")]) + (if (and (andmap null? msg-doms) + (null? argtypes)) + (tc-error/expr #:return (ret (Un)) + (string-append + "Could not infer types for applying polymorphic " + fcn-string + "\n")) + (tc-error/expr #:return (ret (Un)) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:~n" + (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + "")))))])) + + +(define (tc/funapp f-stx args-stx ftype0 argtys expected) + (match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys]) + (let outer-loop ([ftype ftype0] + [argtypes argtypes] + [arg-thn-effs arg-thn-effs] + [arg-els-effs arg-els-effs] + [args args-stx]) + (match ftype + ;; procedural structs + [(tc-result: (and sty (Struct: _ _ _ (? Type? proc-ty) _ _ _)) thn-eff els-eff) + (outer-loop (ret proc-ty thn-eff els-eff) + (cons (tc-result-t ftype0) argtypes) + (cons (list) arg-thn-effs) + (cons (list) arg-els-effs) + #`(#,(syntax/loc f-stx dummy) #,@args))] + ;; mu types, etc + [(tc-result: (? needs-resolving? t) thn-eff els-eff) + (outer-loop (ret (resolve-once t) thn-eff els-eff) argtypes arg-thn-effs arg-els-effs args)] + ;; parameters + [(tc-result: (Param: in out)) + (match argtypes + [(list) (ret out)] + [(list t) + (if (subtype t in) + (ret -Void) + (tc-error/expr #:return (ret (Un)) + "Wrong argument to parameter - expected ~a and got ~a" in t))] + [_ (tc-error/expr #:return (ret (Un)) + "Wrong number of arguments to parameter - expected 0 or 1, got ~a" + (length argtypes))])] + ;; single clause functions + ;; FIXME - error on non-optional keywords + [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) + thn-eff els-eff) + (let-values ([(thn-eff els-eff) + (tc-args argtypes arg-thn-effs arg-els-effs dom rest + latent-thn-effs latent-els-effs + (syntax->list args))]) + (ret rng thn-eff els-eff))] + ;; non-polymorphic case-lambda functions + [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) + thn-eff els-eff) + (let loop ([doms* doms] [rngs rngs] [rests* rests]) + (cond [(null? doms*) + (tc-error/expr + #:return (ret (Un)) + (string-append "No function domains matched in function application:\n" + (domain-mismatches t doms rests drests rngs argtypes #f #f)))] + [(subtypes/varargs argtypes (car doms*) (car rests*)) + (when (car rests*) + (printf/log "Simple varargs function application (~a)\n" (syntax->datum f-stx))) + (ret (car rngs))] + [else (loop (cdr doms*) (cdr rngs) (cdr rests*))]))] + ;; simple polymorphic functions, no rest arguments + [(tc-result: (and t + (or (Poly: vars + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) + (PolyDots: (list vars ...) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) + (handle-clauses (doms rngs) f-stx + (lambda (dom _) (= (length dom) (length argtypes))) + (lambda (dom rng) (infer vars argtypes dom rng (fv rng) expected)) + t argtypes expected)] + ;; polymorphic varargs + [(tc-result: (and t + (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) + ;; we want to infer the dotted-var here as well, and we don't use these separately + ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) + (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) + (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) + (handle-clauses (doms rests rngs) f-stx + (lambda (dom rest rng) (<= (length dom) (length argtypes))) + (lambda (dom rest rng) (infer/vararg vars argtypes dom rest rng (fv rng) expected)) + t argtypes expected)] + ;; polymorphic ... type + [(tc-result: (and t (PolyDots: + (and vars (list fixed-vars ... dotted-var)) + (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) + (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) + (handle-clauses (doms dtys dbounds rngs) f-stx + (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) + (eq? dotted-var dbound))) + (lambda (dom dty dbound rng) + (infer/dots fixed-vars dotted-var argtypes dom dty rng (fv rng) #:expected expected)) + t argtypes expected)] + ;; Union of function types works if we can apply all of them + [(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2) + (match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop + (ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)]) + (ret (apply Un ts)))] + ;; error type is a perfectly good fcn type + [(tc-result: (Error:)) (ret (make-Error))] + [(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) + +;(trace tc/funapp) + + + +(define (tc/app form) (tc/app/internal form #f)) + +(define (tc/app/check form expected) + (define t (tc/app/internal form expected)) + (check-below t expected) + (ret expected)) + +(define-syntax-class lv-clause + #:transparent + (pattern [(v:id ...) e:expr])) + +(define-syntax-class lv-clauses + #:transparent + (pattern (cl:lv-clause ...) + #:with (e ...) #'(cl.e ...) + #:with (vs ...) #'((cl.v ...) ...))) + +(define-syntax-class core-expr + #:literals (reverse letrec-syntaxes+values let-values #%plain-app + if letrec-values begin #%plain-lambda set! case-lambda + begin0 with-continuation-mark) + #:transparent + (pattern (let-values cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (letrec-values cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (letrec-syntaxes+values _ cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (#%plain-app expr ...)) + (pattern (if expr ...)) + (pattern (with-continuation-mark expr ...)) + (pattern (begin expr ...)) + (pattern (begin0 expr ...)) + (pattern (#%plain-lambda _ e) + #:with (expr ...) #'(e)) + (pattern (case-lambda [_ expr] ...)) + (pattern (set! _ e) + #:with (expr ...) #'(e)) + (pattern _ + #:with (expr ...) #'())) + +;; expr id -> type or #f +;; if there is a binding in stx of the form: +;; (let ([x (reverse name)]) e) +;; where x has a type annotation, return that annotation, otherwise #f +(define (find-annotation stx name) + (define (find s) (find-annotation s name)) + (define (match? b) + (syntax-parse b + #:literals (#%plain-app reverse) + [c:lv-clause + #:with (#%plain-app reverse n:id) #'c.e + #:with (v) #'(c.v ...) + #:when (free-identifier=? name #'n) + (type-annotation #'v)] + [_ #f])) + (syntax-parse stx + #:literals (let-values) + [(let-values cls:lv-clauses body) + (or (ormap match? (syntax->list #'cls)) + (find #'body))] + [e:core-expr + (ormap find (syntax->list #'(e.expr ...)))])) + + +(define (check-do-make-object cl pos-args names named-args) + (let* ([names (map syntax-e (syntax->list names))] + [name-assoc (map list names (syntax->list named-args))]) + (let loop ([t (tc-expr cl)]) + (match t + [(tc-result: (? Mu? t)) (loop (ret (unfold t)))] + [(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) + (unless (= (length pos-tys) + (length (syntax->list pos-args))) + (tc-error/delayed "expected ~a positional arguments, but got ~a" + (length pos-tys) (length (syntax->list pos-args)))) + ;; use for, since they might be different lengths in error case + (for ([pa (in-syntax pos-args)] + [pt (in-list pos-tys)]) + (tc-expr/check pa pt)) + (for ([n names] + #:when (not (memq n tnames))) + (tc-error/delayed + "unknown named argument ~a for class~nlegal named arguments are ~a" + n (stringify tnames))) + (for-each (match-lambda + [(list tname tfty opt?) + (let ([s (cond [(assq tname name-assoc) => cadr] + [(not opt?) + (tc-error/delayed "value not provided for named init arg ~a" tname) + #f] + [else #f])]) + (if s + ;; this argument was present + (tc-expr/check s tfty) + ;; this argument wasn't provided, and was optional + #f))]) + tnflds) + (ret (make-Instance c))] + [(tc-result: t) + (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) + +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (arr: dom rng rest #f ktys _ _)) + ;; assumes that everything is in sorted order + (let loop ([actual-kws kws] + [actuals (map tc-expr/t (syntax->list kw-args))] + [formals ktys]) + (match* (actual-kws formals) + [('() '()) + (void)] + [(_ '()) + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws))] + [('() (cons fst rst)) + (match fst + [(Keyword: k _ #t) + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k)] + [_ (loop actual-kws actuals rst)])] + [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) + (cond [(eq? k k*) ;; we have a match + (unless (subtype (car actuals) t) + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k)) + (loop kws-rest (cdr actuals) form-rest)] + [req? ;; this keyword argument was required + (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)] + [else ;; otherwise, ignore this formal param, and continue + (loop actual-kws actuals form-rest)])])) + (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + [_ (int-err "case-lambda w/ keywords not supported")])) + + +(define (type->list t) + (match t + [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] + [(Value: '()) null] + [_ (int-err "bad value in type->list: ~a" t)])) + +;; id: identifier +;; sym: a symbol +;; mod: a quoted require spec like 'scheme/base +;; is id the name sym defined in mod? +(define (id-from? id sym mod) + (and (eq? (syntax-e id) sym) + (eq? (module-path-index-resolve (syntax-source-module id)) + ((current-module-name-resolver) mod #f #f #f)))) + +(define (tc/app/internal form expected) + (kernel-syntax-case* form #f + (values apply k:apply not list list* call-with-values do-make-object make-object cons + andmap ormap) ;; the special-cased functions + ;; special case for delay + [(#%plain-app + mp1 + (#%plain-lambda () + (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) + (and (id-from? #'mp1 'make-promise 'scheme/promise) + (id-from? #'mp2 'make-promise 'scheme/promise)) + (ret (-Promise (tc-expr/t #'e)))] + ;; special cases for classes + [(#%plain-app make-object cl . args) + (check-do-make-object #'cl #'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 ...))] + [(#%plain-app do-make-object . args) + (int-err "bad do-make-object : ~a" (syntax->datum #'args))] + ;; call-with-values + [(#%plain-app call-with-values prod con) + (match-let* ([(tc-result: prod-t) (tc-expr #'prod)]) + (define (values-ty->list t) + (match t + [(Values: ts) ts] + [_ (list t)])) + (match prod-t + [(Function: (list (arr: (list) vals _ #f '() _ _))) + (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] + [_ (tc-error/expr #:return (ret (Un)) + "First argument to call with values must be a function that can accept no arguments, got: ~a" + prod-t)]))] + ;; special cases for `values' + ;; special case the single-argument version to preserve the effects + [(#%plain-app values arg) (tc-expr #'arg)] + [(#%plain-app values . args) + (let ([tys (map tc-expr/t (syntax->list #'args))]) + (ret (-values tys)))] + ;; special case for `list' + [(#%plain-app list . args) + (let ([tys (map tc-expr/t (syntax->list #'args))]) + (ret (apply -lst* tys)))] + ;; special case for `list*' + [(#%plain-app list* . args) + (match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))] + [tys (reverse tys-r)]) + (ret (foldr make-Pair last tys)))] + ;; in eq? cases, call tc/eq + [(#%plain-app eq? v1 v2) + (and (identifier? #'eq?) (comparator? #'eq?)) + (begin + ;; make sure the whole expression is type correct + (tc/funapp #'eq? #'(v1 v2) (tc-expr #'eq?) (map tc-expr (syntax->list #'(v1 v2))) expected) + ;; check thn and els with the eq? info + (let-values ([(thn-eff els-eff) (tc/eq #'eq? #'v1 #'v2)]) + (ret B thn-eff els-eff)))] + ;; special case for `not' + [(#%plain-app not arg) + (match (tc-expr #'arg) + ;; if arg was a predicate application, we swap the effects + [(tc-result: t thn-eff els-eff) + (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] + [(#%plain-app k:apply . args) + (tc/app/internal #'(#%plain-app apply . args) expected)] + ;; special-er case for (apply values (list x y z)) + [(#%plain-app apply values e) + (cond [(with-handlers ([exn:fail? (lambda _ #f)]) + (untuple (tc-expr/t #'e))) + => (lambda (t) (ret (-values t)))] + [else (tc/apply #'values #'(e))])] + ;; special case for `apply' + [(#%plain-app apply f . args) (tc/apply #'f #'args)] + ;; special case for keywords + [(#%plain-app + (#%plain-app kpe kws num fn) + kw-list + (#%plain-app list . kw-arg-list) + . pos-args) + (eq? (syntax-e #'kpe) 'keyword-procedure-extract) + (match (tc-expr #'fn) + [(tc-result: (Function: arities)) + (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [(tc-result: t) (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] + ;; even more special case for match + [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) + (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) + (let-loop-check form #'lp #'actuals #'args #'body expected)] + ;; or/andmap of ... argument + [(#%plain-app or/andmap f arg) + (and + (identifier? #'or/andmap) + (or (free-identifier=? #'or/andmap #'ormap) + (free-identifier=? #'or/andmap #'andmap)) + (with-handlers ([exn:fail? (lambda _ #f)]) + (tc/dots #'arg) + #t)) + (let-values ([(ty bound) (tc/dots #'arg)]) + (parameterize ([current-tvars (extend-env (list bound) + (list (make-DottedBoth (make-F bound))) + (current-tvars))]) + (match-let* ([ft (tc-expr #'f)] + [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) + (ret (Un (-val #f) t)))))] + ;; infer for ((lambda + [(#%plain-app (#%plain-lambda (x ...) . body) args ...) + (= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + (tc/let-values/check #'((x) ...) #'(args ...) #'body + #'(let-values ([(x) args] ...) . body) + expected)] + ;; default case + [(#%plain-app f args ...) + (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) + +(define (let-loop-check form lp actuals args body expected) + (kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?) + [((val acc ...) + ((if (#%plain-app null? val*) thn els)) + (actual actuals ...)) + (and (free-identifier=? #'val #'val*) + (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a)) + (syntax->list #'(acc ...)))) + (let* ([ts1 (generalize (tc-expr/t #'actual))] + [ann-ts (for/list ([a (in-syntax #'(acc ...))] + [ac (in-syntax #'(actuals ...))]) + (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) + (generalize (tc-expr/t ac))))] + [ts (cons ts1 ann-ts)]) + ;; check that the actual arguments are ok here + (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) + ;; then check that the function typechecks with the inferred types + (tc/rec-lambda/check form args body lp ts expected) + (ret expected))] + ;; special case when argument needs inference + [_ + (let ([ts (for/list ([ac (syntax->list actuals)] + [f (syntax->list args)]) + (or + (type-annotation f #:infer #t) + (generalize (tc-expr/t ac))))]) + (tc/rec-lambda/check form args body lp ts expected) + (ret expected))])) + +(define (matches? stx) + (let loop ([stx stx] [ress null] [acc*s null]) + (syntax-case stx (#%plain-app reverse) + [([(res) (#%plain-app reverse acc*)] . more) + (loop #'more (cons #'res ress) (cons #'acc* acc*s))] + [rest + (syntax->list #'rest) + (begin + ;(printf "ress: ~a~n" (map syntax-e ress)) + (list (reverse ress) (reverse acc*s) #'rest))] + [_ #f]))) + +;(trace tc/app/internal) From c5b4ac4f219f2421ebc2743b2c8afa038109f389 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 29 Apr 2009 19:52:53 +0000 Subject: [PATCH 083/156] Rename id to mk-id to avoid name clashes. Start on new tc-app as copy. svn: r14660 --- collects/typed-scheme/private/parse-type.ss | 2 +- collects/typed-scheme/private/prims.ss | 2 +- collects/typed-scheme/rep/rep-utils.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 832 +----------------- .../typed-scheme/typecheck/typechecker.ss | 4 +- collects/typed-scheme/utils/utils.ss | 2 +- 6 files changed, 15 insertions(+), 829 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index d86e12a48d..147a9d5ea6 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -2,7 +2,7 @@ (provide parse-type parse-type/id parse-type*) -(require (except-in "../utils/utils.ss" extend id)) +(require (except-in "../utils/utils.ss" extend)) (require (except-in (rep type-rep) make-arr) (rename-in (types convenience union utils) [make-arr* make-arr]) (utils tc-utils stxclass-util) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index a5ec8287d1..097d6d6808 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -33,7 +33,7 @@ This file defines two sorts of primitives. All of them are provided into any mod syntax/struct syntax/stx scheme/struct-info - (except-in (utils utils tc-utils) id) + (except-in (utils utils tc-utils)) (env type-name-env) "type-contract.ss")) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 9c1d66af7a..de7ae4316b 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -17,7 +17,7 @@ syntax/struct syntax/stx scheme/contract - (rename-in (utils utils) [id mk-id]))) + (utils utils))) (provide == defintern hash-id (for-syntax fold-target)) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index e0a64c4c64..6d1e92980c 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -1,834 +1,20 @@ #lang scheme/unit -(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer])) -(require "signatures.ss" +(require (rename-in "../utils/utils.ss" [infer r:infer]) + "signatures.ss" stxclass (for-syntax stxclass) - (rep type-rep effect-rep) - (utils tc-utils) - (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type - type-annotation) - (r:infer infer) - (env type-environments) - (only-in srfi/1 alist-delete) - (only-in scheme/private/class-internal make-object do-make-object) - mzlib/trace mzlib/pretty syntax/kerncase scheme/match - (prefix-in c: scheme/contract) - (for-syntax scheme/base) - (for-template - (only-in '#%kernel [apply k:apply]) - "internal-forms.ss" scheme/base - (only-in scheme/private/class-internal make-object do-make-object))) -(require (r:infer constraint-structs)) + (rep type-rep filter-rep object-rep)) (import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) -;; comparators that inform the type system -(define (comparator? i) - (or (free-identifier=? i #'eq?) - (free-identifier=? i #'equal?) - (free-identifier=? i #'eqv?) - (free-identifier=? i #'=) - (free-identifier=? i #'string=?))) -;; typecheck eq? applications -;; identifier identifier expression expression expression -;; identifier expr expr expr expr -> tc-result -(define (tc/eq comparator v1 v2) - (define (e? i) (free-identifier=? i comparator)) - (define (do id val) - (define-syntax alt (syntax-rules () [(_ nm pred ...) - (and (e? #'nm) (or (pred val) ...))])) - (if (or (alt symbol=? symbol?) - (alt string=? string?) - (alt = number?) - (alt eq? boolean? keyword? symbol?) - (alt eqv? boolean? keyword? symbol? number?) - (alt equal? (lambda (x) #t))) - (values (list (make-Restrict-Effect (-val val) id)) - (list (make-Remove-Effect (-val val) id))) - (values (list) (list)))) - (match (list (tc-expr v1) (tc-expr v2)) - [(list (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2))) (tc-result: (Value: val))) - (do id1 val)] - [(list (tc-result: (Value: val)) (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2)))) - (do id1 val)] - [_ (values (list) (list))])) +(define (tc/app . args) + (error "tc/app NYI")) +(define (tc/app/check . args) + (error "tc/app/check NYI")) -;; typecheck an application: -;; arg-types: the types of the actual parameters -;; arg-effs: the effects of the arguments -;; dom-types: the types of the function's fixed arguments -;; rest-type: the type of the functions's rest parameter, or #f -;; latent-eff: the latent effect of the function -;; arg-stxs: the syntax for each actual parameter, for error reporting -;; [Type] [Type] Maybe[Type] [Syntax] -> (values Listof[Effect] Listof[Effect]) -(define (tc-args arg-types arg-thn-effs arg-els-effs dom-types rest-type latent-thn-eff latent-els-eff arg-stxs) - (define (var-true-effect-v e) (match e - [(Var-True-Effect: v) v])) - (define (var-false-effect-v e) (match e - [(Var-False-Effect: v) v])) - ;; special case for predicates: - (if (and (not (null? latent-thn-eff)) - (not (null? latent-els-eff)) - (not rest-type) - ;(printf "got to =~n") - (= (length arg-types) (length dom-types) 1) - ;(printf "got to var preds~n") - (= (length (car arg-thn-effs)) (length (car arg-els-effs)) 1) - (Var-True-Effect? (caar arg-thn-effs)) ;; thn-effs is a list for each arg - (Var-False-Effect? (caar arg-els-effs)) ;; same with els-effs - (free-identifier=? (var-true-effect-v (caar arg-thn-effs)) - (var-false-effect-v (caar arg-els-effs))) - (subtype (car arg-types) (car dom-types))) - ;; then this was a predicate application, so we construct the appropriate type effect - (values (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-thn-eff) - (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-els-eff)) - ;; otherwise, we just ignore the effects. - (let loop ([args arg-types] [doms dom-types] [stxs arg-stxs] [arg-count 1]) - (cond - [(and (null? args) (null? doms)) (values null null)] ;; here, we just return the empty effect - [(null? args) - (tc-error/delayed - "Insufficient arguments to function application, expected ~a, got ~a" - (length dom-types) (length arg-types)) - (values null null)] - [(and (null? doms) rest-type) - (if (subtype (car args) rest-type) - (loop (cdr args) doms (cdr stxs) (add1 arg-count)) - (begin - (tc-error/delayed #:stx (car stxs) - "Rest argument had wrong type, expected: ~a and got: ~a" - rest-type (car args)) - (values null null)))] - [(null? doms) - (tc-error/delayed "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types)) - (values null null)] - [(subtype (car args) (car doms)) - (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))] - [else - (tc-error/delayed - #:stx (car stxs) - "Wrong function argument type, expected ~a, got ~a for argument ~a" - (car doms) (car args) arg-count) - (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))])))) - - -;(trace tc-args) - -(define (stringify-domain dom rst drst [rng #f]) - (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] - [rng-string (if rng (format " -> ~a" rng) "")]) - (cond [drst - (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] - [rst - (format "~a~a *~a" doms-string rst rng-string)] - [else (string-append (stringify dom) rng-string)]))) - -(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) - (define arguments-str - (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f))) - (cond - [(null? doms) - (int-err "How could doms be null: ~a ~a" ty)] - [(= 1 (length doms)) - (format "Domain: ~a~nArguments: ~a~n~a" - (stringify-domain (car doms) (car rests) (car drests)) - arguments-str - (if expected - (format "Result type: ~a~nExpected result: ~a~n" - (car rngs) expected) - ""))] - [else - (format "~a: ~a~nArguments: ~a~n~a" - (if expected "Types" "Domains") - (stringify (if expected - (map stringify-domain doms rests drests rngs) - (map stringify-domain doms rests drests)) - "~n\t") - arguments-str - (if expected - (format "Expected result: ~a~n" expected) - ""))])) - -(define (do-apply-log subst fun arg) - (match* (fun arg) - [('star 'list) (printf/log "Polymorphic apply called with uniform rest arg, list argument\n")] - [('star 'dots) (printf/log "Polymorphic apply called with uniform rest arg, dotted argument\n")] - [('dots 'dots) (printf/log "Polymorphic apply called with non-uniform rest arg, dotted argument\n")]) - (log-result subst)) - -(define (tc/apply f args) - (define f-ty (tc-expr f)) - ;; produces the first n-1 elements of the list, and the last element - (define (split l) - (let loop ([l l] [acc '()]) - (if (null? (cdr l)) - (values (reverse acc) (car l)) - (loop (cdr l) (cons (car l) acc))))) - (define-values (fixed-args tail) (split (syntax->list args))) - - (match f-ty - [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) - (when (null? doms) - (tc-error/expr #:return (ret (Un)) - "empty case-lambda given as argument to apply")) - (let ([arg-tys (map tc-expr/t fixed-args)]) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))] - [(and (car rests*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values #f #f))]) - (tc/dots tail))]) - (and tail-ty - (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty)) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) - (printf/log "Non-poly apply, ... arg\n") - (ret (car rngs*))] - [(and (car rests*) - (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)]) - (tc-expr/t tail))]) - (and tail-ty - (subtype (apply -lst* arg-tys #:tail tail-ty) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) - - (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) - "Simple arithmetic non-poly apply\n" - "Simple non-poly apply\n")) - (ret (car rngs*))] - [(and (car drests*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values #f #f))]) - (tc/dots tail))]) - (and tail-ty - (eq? (cdr (car drests*)) tail-bound) - (subtypes arg-tys (car doms*)) - (subtype tail-ty (car (car drests*)))))) - (printf/log "Non-poly apply, ... arg\n") - (ret (car rngs*))] - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] - [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - #;(for-each (lambda (x) (unless (not (Poly? x)) - (tc-error "Polymorphic argument of type ~a to polymorphic function in apply not allowed" x))) - (cons tail-ty arg-tys)) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] - ;; the actual work, when we have a * function and a list final argument - [(and (car rests*) - (not tail-bound) - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons tail-ty arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] - ;; actual work, when we have a * function and ... final arg - [(and (car rests*) - tail-bound - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons (make-Listof tail-ty) arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg - [(and (car drests*) - tail-bound - (eq? tail-bound (cdr (car drests*))) - (= (length (car doms*)) - (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] - ;; if nothing matches, around the loop again - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: '()))) - (tc-error/expr #:return (ret (Un)) - "Function has no cases")] - [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] - [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] - ;; the actual work, when we have a * function and a list final argument - [(and (car rests*) - (not tail-bound) - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons tail-ty arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) - (do-apply-log substitution 'star 'list) - (ret (subst-all substitution (car rngs*))))] - ;; actual work, when we have a * function and ... final arg - [(and (car rests*) - tail-bound - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons (make-Listof tail-ty) arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) - (do-apply-log substitution 'star 'dots) - (ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg, same bound on ... - [(and (car drests*) - tail-bound - (eq? tail-bound (cdr (car drests*))) - (= (length (car doms*)) - (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) - (do-apply-log substitution 'dots 'dots) - (ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg, different bound on ... - [(and (car drests*) - tail-bound - (not (eq? tail-bound (cdr (car drests*)))) - (= (length (car doms*)) - (length arg-tys)) - (parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*))) - (list (make-DottedBoth (make-F tail-bound)) - (make-DottedBoth (make-F (cdr (car drests*))))) - (current-tvars))]) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))) - => (lambda (substitution) - (define drest-bound (cdr (car drests*))) - (do-apply-log substitution 'dots 'dots) - (ret (substitute-dotted (cadr (assq drest-bound substitution)) - tail-bound - drest-bound - (subst-all (alist-delete drest-bound substitution eq?) - (car rngs*)))))] - ;; ... function, (List A B C etc) arg - [(and (car drests*) - (not tail-bound) - (eq? (cdr (car drests*)) dotted-var) - (= (length (car doms*)) - (length arg-tys)) - (untuple tail-ty) - (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) - (car (car drests*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) - (define drest-bound (cdr (car drests*))) - (do-apply-log substitution 'dots 'dots) - (ret (subst-all substitution (car rngs*))))] - ;; if nothing matches, around the loop again - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (PolyDots: vars (Function: '()))) - (tc-error/expr #:return (ret (Un)) - "Function has no cases")] - [(tc-result: f-ty) (tc-error/expr #:return (ret (Un)) - "Type of argument to apply is not a function type: ~n~a" f-ty)])) - - - -(define (log-result subst) - (define (dmap-length d) - (match d - [(struct dcon (fixed rest)) (length fixed)] - [(struct dcon-exact (fixed rest)) (length fixed)])) - (define (dmap-rest? d) - (match d - [(struct dcon (fixed rest)) rest] - [(struct dcon-exact (fixed rest)) rest])) - (if (list? subst) - (for ([s subst]) - (match s - [(list v (list imgs ...) starred) - (printf/log "Instantiated ... variable ~a with ~a types\n" v (length imgs))] - [_ (void)])) - (for* ([(cmap dmap) (in-pairs (cset-maps subst))] - [(k v) (dmap-map dmap)]) - (printf/log "Instantiated ... variable ~a with ~a types~a\n" k (dmap-length v) - (if (dmap-rest? v) - " and a starred type" - ""))))) - -(define-syntax (handle-clauses stx) - (syntax-parse stx - [(_ (lsts ... rngs) f-stx pred infer t argtypes expected) - (with-syntax ([(vars ... rng) (generate-temporaries #'(lsts ... rngs))]) - (syntax/loc stx - (or (for/or ([vars lsts] ... [rng rngs] - #:when (pred vars ... rng)) - (let ([substitution (infer vars ... rng)]) - (and substitution - (log-result substitution) - (ret (or expected - (subst-all substitution rng)))))) - (poly-fail t argtypes #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) - -(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) - (match t - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) - (let ([fcn-string (if name - (format "function ~a" (syntax->datum name)) - "function")]) - (if (and (andmap null? msg-doms) - (null? argtypes)) - (tc-error/expr #:return (ret (Un)) - (string-append - "Could not infer types for applying polymorphic " - fcn-string - "\n")) - (tc-error/expr #:return (ret (Un)) - (string-append - "Polymorphic " fcn-string " could not be applied to arguments:~n" - (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) - (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) - (string-append "Type Variables: " (stringify msg-vars) "\n") - "")))))])) - - -(define (tc/funapp f-stx args-stx ftype0 argtys expected) - (match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys]) - (let outer-loop ([ftype ftype0] - [argtypes argtypes] - [arg-thn-effs arg-thn-effs] - [arg-els-effs arg-els-effs] - [args args-stx]) - (match ftype - ;; procedural structs - [(tc-result: (and sty (Struct: _ _ _ (? Type? proc-ty) _ _ _)) thn-eff els-eff) - (outer-loop (ret proc-ty thn-eff els-eff) - (cons (tc-result-t ftype0) argtypes) - (cons (list) arg-thn-effs) - (cons (list) arg-els-effs) - #`(#,(syntax/loc f-stx dummy) #,@args))] - ;; mu types, etc - [(tc-result: (? needs-resolving? t) thn-eff els-eff) - (outer-loop (ret (resolve-once t) thn-eff els-eff) argtypes arg-thn-effs arg-els-effs args)] - ;; parameters - [(tc-result: (Param: in out)) - (match argtypes - [(list) (ret out)] - [(list t) - (if (subtype t in) - (ret -Void) - (tc-error/expr #:return (ret (Un)) - "Wrong argument to parameter - expected ~a and got ~a" in t))] - [_ (tc-error/expr #:return (ret (Un)) - "Wrong number of arguments to parameter - expected 0 or 1, got ~a" - (length argtypes))])] - ;; single clause functions - ;; FIXME - error on non-optional keywords - [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) - thn-eff els-eff) - (let-values ([(thn-eff els-eff) - (tc-args argtypes arg-thn-effs arg-els-effs dom rest - latent-thn-effs latent-els-effs - (syntax->list args))]) - (ret rng thn-eff els-eff))] - ;; non-polymorphic case-lambda functions - [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) - thn-eff els-eff) - (let loop ([doms* doms] [rngs rngs] [rests* rests]) - (cond [(null? doms*) - (tc-error/expr - #:return (ret (Un)) - (string-append "No function domains matched in function application:\n" - (domain-mismatches t doms rests drests rngs argtypes #f #f)))] - [(subtypes/varargs argtypes (car doms*) (car rests*)) - (when (car rests*) - (printf/log "Simple varargs function application (~a)\n" (syntax->datum f-stx))) - (ret (car rngs))] - [else (loop (cdr doms*) (cdr rngs) (cdr rests*))]))] - ;; simple polymorphic functions, no rest arguments - [(tc-result: (and t - (or (Poly: vars - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) - (PolyDots: (list vars ...) - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) - (handle-clauses (doms rngs) f-stx - (lambda (dom _) (= (length dom) (length argtypes))) - (lambda (dom rng) (infer vars argtypes dom rng (fv rng) expected)) - t argtypes expected)] - ;; polymorphic varargs - [(tc-result: (and t - (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) - ;; we want to infer the dotted-var here as well, and we don't use these separately - ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) - (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) - (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) - (handle-clauses (doms rests rngs) f-stx - (lambda (dom rest rng) (<= (length dom) (length argtypes))) - (lambda (dom rest rng) (infer/vararg vars argtypes dom rest rng (fv rng) expected)) - t argtypes expected)] - ;; polymorphic ... type - [(tc-result: (and t (PolyDots: - (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) - (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) - (handle-clauses (doms dtys dbounds rngs) f-stx - (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) - (eq? dotted-var dbound))) - (lambda (dom dty dbound rng) - (infer/dots fixed-vars dotted-var argtypes dom dty rng (fv rng) #:expected expected)) - t argtypes expected)] - ;; Union of function types works if we can apply all of them - [(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2) - (match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop - (ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)]) - (ret (apply Un ts)))] - ;; error type is a perfectly good fcn type - [(tc-result: (Error:)) (ret (make-Error))] - [(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) - -;(trace tc/funapp) - - - -(define (tc/app form) (tc/app/internal form #f)) - -(define (tc/app/check form expected) - (define t (tc/app/internal form expected)) - (check-below t expected) - (ret expected)) - -(define-syntax-class lv-clause - #:transparent - (pattern [(v:id ...) e:expr])) - -(define-syntax-class lv-clauses - #:transparent - (pattern (cl:lv-clause ...) - #:with (e ...) #'(cl.e ...) - #:with (vs ...) #'((cl.v ...) ...))) - -(define-syntax-class core-expr - #:literals (reverse letrec-syntaxes+values let-values #%plain-app - if letrec-values begin #%plain-lambda set! case-lambda - begin0 with-continuation-mark) - #:transparent - (pattern (let-values cls:lv-clauses body) - #:with (expr ...) #'(cls.e ... body)) - (pattern (letrec-values cls:lv-clauses body) - #:with (expr ...) #'(cls.e ... body)) - (pattern (letrec-syntaxes+values _ cls:lv-clauses body) - #:with (expr ...) #'(cls.e ... body)) - (pattern (#%plain-app expr ...)) - (pattern (if expr ...)) - (pattern (with-continuation-mark expr ...)) - (pattern (begin expr ...)) - (pattern (begin0 expr ...)) - (pattern (#%plain-lambda _ e) - #:with (expr ...) #'(e)) - (pattern (case-lambda [_ expr] ...)) - (pattern (set! _ e) - #:with (expr ...) #'(e)) - (pattern _ - #:with (expr ...) #'())) - -;; expr id -> type or #f -;; if there is a binding in stx of the form: -;; (let ([x (reverse name)]) e) -;; where x has a type annotation, return that annotation, otherwise #f -(define (find-annotation stx name) - (define (find s) (find-annotation s name)) - (define (match? b) - (syntax-parse b - #:literals (#%plain-app reverse) - [c:lv-clause - #:with (#%plain-app reverse n:id) #'c.e - #:with (v) #'(c.v ...) - #:when (free-identifier=? name #'n) - (type-annotation #'v)] - [_ #f])) - (syntax-parse stx - #:literals (let-values) - [(let-values cls:lv-clauses body) - (or (ormap match? (syntax->list #'cls)) - (find #'body))] - [e:core-expr - (ormap find (syntax->list #'(e.expr ...)))])) - - -(define (check-do-make-object cl pos-args names named-args) - (let* ([names (map syntax-e (syntax->list names))] - [name-assoc (map list names (syntax->list named-args))]) - (let loop ([t (tc-expr cl)]) - (match t - [(tc-result: (? Mu? t)) (loop (ret (unfold t)))] - [(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) - (unless (= (length pos-tys) - (length (syntax->list pos-args))) - (tc-error/delayed "expected ~a positional arguments, but got ~a" - (length pos-tys) (length (syntax->list pos-args)))) - ;; use for, since they might be different lengths in error case - (for ([pa (in-syntax pos-args)] - [pt (in-list pos-tys)]) - (tc-expr/check pa pt)) - (for ([n names] - #:when (not (memq n tnames))) - (tc-error/delayed - "unknown named argument ~a for class~nlegal named arguments are ~a" - n (stringify tnames))) - (for-each (match-lambda - [(list tname tfty opt?) - (let ([s (cond [(assq tname name-assoc) => cadr] - [(not opt?) - (tc-error/delayed "value not provided for named init arg ~a" tname) - #f] - [else #f])]) - (if s - ;; this argument was present - (tc-expr/check s tfty) - ;; this argument wasn't provided, and was optional - #f))]) - tnflds) - (ret (make-Instance c))] - [(tc-result: t) - (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) - -(define (tc-keywords form arities kws kw-args pos-args expected) - (match arities - [(list (arr: dom rng rest #f ktys _ _)) - ;; assumes that everything is in sorted order - (let loop ([actual-kws kws] - [actuals (map tc-expr/t (syntax->list kw-args))] - [formals ktys]) - (match* (actual-kws formals) - [('() '()) - (void)] - [(_ '()) - (tc-error/expr #:return (ret (Un)) - "Unexpected keyword argument ~a" (car actual-kws))] - [('() (cons fst rst)) - (match fst - [(Keyword: k _ #t) - (tc-error/expr #:return (ret (Un)) - "Missing keyword argument ~a" k)] - [_ (loop actual-kws actuals rst)])] - [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) - (cond [(eq? k k*) ;; we have a match - (unless (subtype (car actuals) t) - (tc-error/delayed - "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" - t (car actuals) k)) - (loop kws-rest (cdr actuals) form-rest)] - [req? ;; this keyword argument was required - (tc-error/delayed "Missing keyword argument ~a" k*) - (loop kws-rest (cdr actuals) form-rest)] - [else ;; otherwise, ignore this formal param, and continue - (loop actual-kws actuals form-rest)])])) - (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] - [_ (int-err "case-lambda w/ keywords not supported")])) - - -(define (type->list t) - (match t - [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] - [(Value: '()) null] - [_ (int-err "bad value in type->list: ~a" t)])) - -;; id: identifier -;; sym: a symbol -;; mod: a quoted require spec like 'scheme/base -;; is id the name sym defined in mod? -(define (id-from? id sym mod) - (and (eq? (syntax-e id) sym) - (eq? (module-path-index-resolve (syntax-source-module id)) - ((current-module-name-resolver) mod #f #f #f)))) - -(define (tc/app/internal form expected) - (kernel-syntax-case* form #f - (values apply k:apply not list list* call-with-values do-make-object make-object cons - andmap ormap) ;; the special-cased functions - ;; special case for delay - [(#%plain-app - mp1 - (#%plain-lambda () - (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) - (and (id-from? #'mp1 'make-promise 'scheme/promise) - (id-from? #'mp2 'make-promise 'scheme/promise)) - (ret (-Promise (tc-expr/t #'e)))] - ;; special cases for classes - [(#%plain-app make-object cl . args) - (check-do-make-object #'cl #'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 ...))] - [(#%plain-app do-make-object . args) - (int-err "bad do-make-object : ~a" (syntax->datum #'args))] - ;; call-with-values - [(#%plain-app call-with-values prod con) - (match-let* ([(tc-result: prod-t) (tc-expr #'prod)]) - (define (values-ty->list t) - (match t - [(Values: ts) ts] - [_ (list t)])) - (match prod-t - [(Function: (list (arr: (list) vals _ #f '() _ _))) - (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] - [_ (tc-error/expr #:return (ret (Un)) - "First argument to call with values must be a function that can accept no arguments, got: ~a" - prod-t)]))] - ;; special cases for `values' - ;; special case the single-argument version to preserve the effects - [(#%plain-app values arg) (tc-expr #'arg)] - [(#%plain-app values . args) - (let ([tys (map tc-expr/t (syntax->list #'args))]) - (ret (-values tys)))] - ;; special case for `list' - [(#%plain-app list . args) - (let ([tys (map tc-expr/t (syntax->list #'args))]) - (ret (apply -lst* tys)))] - ;; special case for `list*' - [(#%plain-app list* . args) - (match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))] - [tys (reverse tys-r)]) - (ret (foldr make-Pair last tys)))] - ;; in eq? cases, call tc/eq - [(#%plain-app eq? v1 v2) - (and (identifier? #'eq?) (comparator? #'eq?)) - (begin - ;; make sure the whole expression is type correct - (tc/funapp #'eq? #'(v1 v2) (tc-expr #'eq?) (map tc-expr (syntax->list #'(v1 v2))) expected) - ;; check thn and els with the eq? info - (let-values ([(thn-eff els-eff) (tc/eq #'eq? #'v1 #'v2)]) - (ret B thn-eff els-eff)))] - ;; special case for `not' - [(#%plain-app not arg) - (match (tc-expr #'arg) - ;; if arg was a predicate application, we swap the effects - [(tc-result: t thn-eff els-eff) - (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] - [(#%plain-app k:apply . args) - (tc/app/internal #'(#%plain-app apply . args) expected)] - ;; special-er case for (apply values (list x y z)) - [(#%plain-app apply values e) - (cond [(with-handlers ([exn:fail? (lambda _ #f)]) - (untuple (tc-expr/t #'e))) - => (lambda (t) (ret (-values t)))] - [else (tc/apply #'values #'(e))])] - ;; special case for `apply' - [(#%plain-app apply f . args) (tc/apply #'f #'args)] - ;; special case for keywords - [(#%plain-app - (#%plain-app kpe kws num fn) - kw-list - (#%plain-app list . kw-arg-list) - . pos-args) - (eq? (syntax-e #'kpe) 'keyword-procedure-extract) - (match (tc-expr #'fn) - [(tc-result: (Function: arities)) - (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] - [(tc-result: t) (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" t)])] - ;; even more special case for match - [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) - (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) - (let-loop-check form #'lp #'actuals #'args #'body expected)] - ;; or/andmap of ... argument - [(#%plain-app or/andmap f arg) - (and - (identifier? #'or/andmap) - (or (free-identifier=? #'or/andmap #'ormap) - (free-identifier=? #'or/andmap #'andmap)) - (with-handlers ([exn:fail? (lambda _ #f)]) - (tc/dots #'arg) - #t)) - (let-values ([(ty bound) (tc/dots #'arg)]) - (parameterize ([current-tvars (extend-env (list bound) - (list (make-DottedBoth (make-F bound))) - (current-tvars))]) - (match-let* ([ft (tc-expr #'f)] - [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) - (ret (Un (-val #f) t)))))] - ;; infer for ((lambda - [(#%plain-app (#%plain-lambda (x ...) . body) args ...) - (= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) - (tc/let-values/check #'((x) ...) #'(args ...) #'body - #'(let-values ([(x) args] ...) . body) - expected)] - ;; default case - [(#%plain-app f args ...) - (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) - -(define (let-loop-check form lp actuals args body expected) - (kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?) - [((val acc ...) - ((if (#%plain-app null? val*) thn els)) - (actual actuals ...)) - (and (free-identifier=? #'val #'val*) - (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a)) - (syntax->list #'(acc ...)))) - (let* ([ts1 (generalize (tc-expr/t #'actual))] - [ann-ts (for/list ([a (in-syntax #'(acc ...))] - [ac (in-syntax #'(actuals ...))]) - (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) - (generalize (tc-expr/t ac))))] - [ts (cons ts1 ann-ts)]) - ;; check that the actual arguments are ok here - (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) - ;; then check that the function typechecks with the inferred types - (tc/rec-lambda/check form args body lp ts expected) - (ret expected))] - ;; special case when argument needs inference - [_ - (let ([ts (for/list ([ac (syntax->list actuals)] - [f (syntax->list args)]) - (or - (type-annotation f #:infer #t) - (generalize (tc-expr/t ac))))]) - (tc/rec-lambda/check form args body lp ts expected) - (ret expected))])) - -(define (matches? stx) - (let loop ([stx stx] [ress null] [acc*s null]) - (syntax-case stx (#%plain-app reverse) - [([(res) (#%plain-app reverse acc*)] . more) - (loop #'more (cons #'res ress) (cons #'acc* acc*s))] - [rest - (syntax->list #'rest) - (begin - ;(printf "ress: ~a~n" (map syntax-e ress)) - (list (reverse ress) (reverse acc*s) #'rest))] - [_ #f]))) - -;(trace tc/app/internal) +(define (tc/funapp . args) + (error "tc/funapp NYI")) diff --git a/collects/typed-scheme/typecheck/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss index 524c161bb1..3a1e2b3173 100644 --- a/collects/typed-scheme/typecheck/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -7,11 +7,11 @@ provide-signature-elements define-values/invoke-unit/infer link) "signatures.ss" "tc-toplevel.ss" - "tc-new-if.ss" "tc-lambda-unit.ss" "tc-new-app-unit.ss" + "tc-new-if.ss" "tc-lambda-unit.ss" "tc-app.ss" "tc-let-unit.ss" "tc-dots-unit.ss" "tc-expr-unit.ss" "check-subforms-unit.ss") (provide-signature-elements typechecker^ tc-expr^) (define-values/invoke-unit/infer - (link tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-new-app@ tc-let@ tc-expr@ check-subforms@)) + (link tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 854d1da3a5..69a09d9239 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -13,7 +13,7 @@ at least theoretically. (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log with-logging-to-file log-file-name == define-struct/printer - id + (rename-out [id mk-id]) filter-multiple hash-union in-pairs From 91f5c269642ec9ecc62efabcc83131db539fcedd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 29 Apr 2009 22:54:29 +0000 Subject: [PATCH 084/156] Add `single-value' function, should be used more. Construct returns correctly in lam-result->type Add typechecking for `values' applications. Extend `ret' to handle dty/dbound. Define conversions from/to values <-> results Handle multiple values at the repl. svn: r14665 --- collects/typed-scheme/test.ss | 14 +++++ collects/typed-scheme/typecheck/signatures.ss | 6 +-- collects/typed-scheme/typecheck/tc-app.ss | 47 +++++++++++++--- .../typed-scheme/typecheck/tc-expr-unit.ss | 6 +++ .../typed-scheme/typecheck/tc-lambda-unit.ss | 53 ++++++++++--------- .../typecheck/tc-metafunctions.ss | 2 +- collects/typed-scheme/typed-scheme.ss | 10 ++-- collects/typed-scheme/types/abbrev.ss | 23 ++++++-- collects/typed-scheme/types/printer.ss | 2 + collects/typed-scheme/types/subtype.ss | 3 -- collects/typed-scheme/types/utils.ss | 14 ++++- collects/typed-scheme/utils/utils.ss | 2 +- 12 files changed, 132 insertions(+), 50 deletions(-) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index 148488a5c6..c9b5d7c541 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -73,3 +73,17 @@ xxx6-y (begin 1 1 1) (#%expression (begin 1 1 1)) +(values 1) +(values 1 1) +(values) + +(: ff (Number -> Number)) +(define (ff x) x) + +(lambda: ([y : String][x : Number]) (values 1 x 1)) +(lambda: ([x : Number]) (values 1 x 1)) +(lambda () (values 1 1)) +(lambda () 1) +#{(lambda (x) x) :: (Number -> Number)} +;; BUG - this should work +{ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))} \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index 577dbd2b98..366056c830 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -14,10 +14,10 @@ [cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)] [cnt tc-expr/check/t (syntax? tc-results? . -> . Type/c)] [cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])] - ;[cnt tc-literal (any/c . -> . Type/c)] [cnt tc-exprs ((listof syntax?) . -> . tc-results?)] [cnt tc-exprs/check ((listof syntax?) tc-results? . -> . tc-results?)] - [cnt tc-expr/t (syntax? . -> . Type/c)])) + [cnt tc-expr/t (syntax? . -> . Type/c)] + [cnt single-value ((syntax?) ((or/c tc-results? #f)) . ->* . tc-results?)])) (define-signature check-subforms^ ([cnt check-subforms/ignore (syntax? . -> . any)] @@ -36,7 +36,7 @@ (define-signature tc-app^ ([cnt tc/app (syntax? . -> . tc-results?)] [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)] - [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-results?) (or/c #f Type/c) . -> . tc-results?)])) + [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)])) (define-signature tc-let^ ([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 6d1e92980c..3973404bd2 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -2,19 +2,52 @@ (require (rename-in "../utils/utils.ss" [infer r:infer]) "signatures.ss" - stxclass + stxclass scheme/match mzlib/trace (for-syntax stxclass) - (rep type-rep filter-rep object-rep)) + (types utils) + (rep type-rep filter-rep object-rep) + (for-template + (only-in '#%kernel [apply k:apply]) + "internal-forms.ss" scheme/base + (only-in scheme/private/class-internal make-object do-make-object))) (import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) +;; syntax tc-results? -> tc-results? +(define (tc/app/internal form expected) + (syntax-parse form + #:literals (#%plain-app #%plain-lambda letrec-values + values apply k:apply not list list* call-with-values do-make-object make-object cons + andmap ormap) + [(#%plain-app values arg) (single-value #'arg expected)] + [(#%plain-app values . args) + (match expected + [(tc-results: ets efs eos) + (match-let ([(list (tc-result1: ts fs os) ...) + (for/list ([arg (syntax->list #'args)] + [et ets] [ef efs] [eo eos]) + (single-value arg (ret et ef eo)))]) + (if (= (length ts) (length ets) (length (syntax->list #'args))) + (ret ts fs os) + (tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a" + (length ets) (length (syntax->list #'args)))))] + [_ (match-let ([(list (tc-result1: ts fs os) ...) + (for/list ([arg (syntax->list #'args)]) + (single-value arg))]) + (ret ts fs os))])])) -(define (tc/app . args) - (error "tc/app NYI")) +;(trace tc/app/internal) -(define (tc/app/check . args) - (error "tc/app/check NYI")) +;; syntax -> tc-results +(define (tc/app form) (tc/app/internal form #f)) + +;; syntax tc-results? -> tc-results? +(define (tc/app/check form expected) + (define t (tc/app/internal form expected)) + (check-below t expected) + expected) -(define (tc/funapp . args) +;; syntax? syntax? tc-result? (listof tc-results?) (or/c #f tc-results) -> tc-results? +(define (tc/funapp f-stx args-stx ftype0 argtys expected) (error "tc/funapp NYI")) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 831e0dcdf7..43fbcc996f 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -361,6 +361,12 @@ [(tc-result: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])] [(tc-result: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)])) +(define (single-value form [expected #f]) + (define t (if expected (tc-expr/check form expected) (tc-expr form))) + (match t + [(tc-result1: _ _ _) t] + [_ (tc-error/stx form "expected single value, got multiple (or zero) values")])) + ;; type-check a list of exprs, producing the type of the last one. ;; if the list is empty, the type is Void. ;; list[syntax[expr]] -> tc-result diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index ae4f4296dd..b0b1662938 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -1,7 +1,7 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) -(require "signatures.ss" +(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]) + "signatures.ss" "tc-metafunctions.ss" mzlib/trace scheme/list @@ -11,6 +11,7 @@ (rename-in (types convenience utils union) [make-arr* make-arr]) (private type-annotation) + (types abbrev) (env type-environments lexical-env) (utils tc-utils) mzlib/plt-match) @@ -29,13 +30,14 @@ (define (lam-result->type lr) (match lr [(struct lam-result ((list (list arg-ids arg-tys) ...) (list (list kw kw-id kw-ty req?) ...) rest drest body)) - (make-arr arg-tys - (abstract-filters (append (for/list ([i (in-naturals)] [_ arg-ids]) i) kw) - (append arg-ids kw-id) - body) - #:kws (map make-Keyword kw kw-ty req?) - #:rest rest - #:drest drest)])) + (make-arr/values + arg-tys + (abstract-filters (append (for/list ([i (in-naturals)] [_ arg-ids]) i) kw) + (append arg-ids kw-id) + body) + #:kws (map make-Keyword kw kw-ty req?) + #:rest rest + #:drest drest)])) (define (expected-str tys-len rest-ty drest arg-len rest) (format "Expected function with ~a argument~a~a, but got function with ~a argument~a~a" @@ -49,7 +51,7 @@ (if (= arg-len 1) "" "s") (if rest " and a rest arg" ""))) -;; listof[id] option[id] block listof[type] option[type] option[(cons type var)] type -> lam-result +;; listof[id] option[id] block listof[type] option[type] option[(cons type var)] tc-result -> lam-result (define (check-clause arg-list rest body arg-tys rest-ty drest ret-ty) (let* ([arg-len (length arg-list)] [tys-len (length arg-tys)] @@ -60,12 +62,13 @@ [(< arg-len tys-len) (take arg-tys arg-len)] [(> arg-len tys-len) (append arg-tys (map (lambda _ (or rest-ty (Un))) - (drop arg-list tys-len)))]))]) + (drop arg-list tys-len)))]))]) (define (check-body) (with-lexical-env/extend arg-list arg-types (make lam-result (map list arg-list arg-types) null rest-ty drest (tc-exprs/check (syntax->list body) ret-ty)))) + (printf "arg-types old new: ~a ~a~n" arg-tys arg-types) (when (or (not (= arg-len tys-len)) (and rest (and (not rest-ty) (not drest)))) @@ -96,7 +99,7 @@ ;; typecheck a single lambda, with argument list and body ;; drest-ty and drest-bound are both false or not false -;; syntax-list[id] block listof[type] type option[type] option[(cons type var)] -> lam-result +;; syntax-list[id] block listof[type] tc-result option[type] option[(cons type var)] -> lam-result (define (tc/lambda-clause/check args body arg-tys ret-ty rest-ty drest) (syntax-case args () [(args* ...) @@ -188,18 +191,20 @@ (cons (car formals) formals*) (cons (car bodies) bodies*) (cons (syntax-len (car formals)) nums-seen))])) - (if (and expected - (= 1 (length (syntax->list formals)))) - ;; special case for not-case-lambda - (let loop ([expected expected]) - (match expected - [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests '()) ...)) - (for/list ([args argss] [ret rets] [rest rests] [drest drests]) - (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))] - ;; FIXME - is this right? - [_ (go (syntax->list formals) (syntax->list bodies) null null null)])) - (go (syntax->list formals) (syntax->list bodies) null null null))) + (cond + ;; special case for not-case-lambda + [(and expected + (= 1 (length (syntax->list formals)))) + (let loop ([expected expected]) + (match expected + [(tc-result1: (Mu: _ _)) (loop (unfold expected))] + [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) + (printf "expe: ~a~n" expected) + (for/list ([args argss] [ret rets] [rest rests] [drest drests]) + (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args (values->tc-results ret) rest drest))] + [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))] + ;; otherwise + [else (go (syntax->list formals) (syntax->list bodies) null null null)])) (define (tc/mono-lambda/type formals bodies expected) (define t (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index e9ba260829..7bb32a4950 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -28,7 +28,7 @@ [else (make-FilterSet l1 l2)])) (d/c (abstract-filters keys ids results) - (-> (listof index/c) (listof identifier?) tc-results? (or/c Values? ValuesDots?)) + ((listof index/c) (listof identifier?) tc-results? . -> . (or/c Values? ValuesDots?)) (define (mk l [drest #f]) (if drest (make-ValuesDots l (car drest) (cdr drest)) (make-Values l))) (match results diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 5a43f819f0..72053d9b05 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -129,15 +129,15 @@ [(head:invis-kw . _) body2] [_ (let ([ty-str (match type + [(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f] [(tc-result1: t) - (if (type-equal? t -Void) - #f - (format "- : ~a\n" t))] + (format "- : ~a\n" t)] + [(tc-results: ts) (format "- : ~a\n" (cons 'values ts))] [x (int-err "bad type result: ~a" x)])]) (if #'ty-str - #`(let ([v #,body2] [type '#,ty-str]) + #`(let ([type '#,ty-str]) (begin0 - v + #,body2 (printf type))) body2))]))])) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 165dbb6c94..be20981216 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -3,7 +3,7 @@ (require "../utils/utils.ss") (require (rep type-rep object-rep filter-rep) - "printer.ss" + "printer.ss" "utils.ss" (utils tc-utils) scheme/list scheme/match @@ -173,8 +173,8 @@ #:rest [rest #f] #:drest [drest #f] #:kws [kws null] #:filters [filters -no-lfilter] #:object [obj -no-lobj]) (c:->* ((listof Type/c) (or/c ValuesDots? Values?)) - (#:rest Type/c - #:drest (cons/c Type/c symbol?) + (#:rest (or/c Type/c #f) + #:drest (or/c (cons/c Type/c symbol?) #f) #:kws (listof Keyword?) #:filters LFilterSet? #:object LatentObject?) @@ -262,4 +262,19 @@ (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) (define-syntax-rule (->opt args ... [opt ...] res) - (opt-fn (list args ...) (list opt ...) res)) \ No newline at end of file + (opt-fn (list args ...) (list opt ...) res)) + +(define (tc-results->values tc) + (match tc + [(tc-results: ts fs os dty dbound) + (make-ValuesDots (map -result ts fs os) dty dbound)] + [(tc-results: ts fs os) + (make-Values (map -result ts fs os))])) + +;; FIXME - this should really be a new metafunction like abstract-filter +(define (values->tc-results tc) + (match tc + [(ValuesDots: (list (Result: ts fs os)) dty dbound) + (int-err "values->tc-results NYI for Dots")] + [(Values: (list (Result: ts fs os))) + (ret ts)])) \ No newline at end of file diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index cc5b3673c3..6667f41fc7 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -90,12 +90,14 @@ (when drest (fp "~a ... ~a " (car drest) (cdr drest))) (match rng + #| [(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:)))) (fp "-> ~a" t)] [(Values: (list (Result: t fs (LEmpty:)))) (fp "-> ~a : ~a" t fs)] [(Values: (list (Result: t lf lo))) (fp "-> ~a : ~a ~a" t lf lo)] +|# [_ (fp "-> ~a" rng)]) (fp ")")])) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 4c154e5c27..39570982e8 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -310,9 +310,6 @@ ;; we can ignore interesting results [(list (Result: t f o) (Result: t* (LFilterSet: (list) (list)) (LEmpty:))) (subtype* A0 t t*)] - ;; single values shouldn't actually happen, but they're just like the type - [(list t (Values: (list t*))) (int-err "BUG - singleton values type~a" (make-Values (list t*)))] - [(list (Values: (list t)) t*) (int-err "BUG - singleton values type~a" (make-Values (list t)))] ;; subtyping on other stuff [(list (Syntax: t) (Syntax: t*)) (subtype* A0 t t*)] diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 8d86e992b0..e37685edd5 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -209,7 +209,15 @@ (if (and (list? t) (list? f) (list? o)) (map make-tc-result t f o) (list (make-tc-result t f o))) - #f)])) + #f)] + [(t f o dty) + (int-err "ret used with dty without dbound")] + [(t f o dty dbound) + (make-tc-results + (if (and (list? t) (list? f) (list? o)) + (map make-tc-result t f o) + (list (make-tc-result t f o))) + (cons dty dbound))])) (p/c [ret @@ -219,7 +227,9 @@ FilterSet?)] [o (if (list? t) (listof Object?) - Object?)]) + Object?)] + [dty Type/c] + [dbound symbol?]) [_ tc-results?])]) (define (subst v t e) (substitute t v e)) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 69a09d9239..f322ad0307 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -266,7 +266,7 @@ at least theoretically. (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) -(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) (define-syntax p/c From b4d100d60cb99e714374d2db3c75a36167b109cc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 1 May 2009 21:18:23 +0000 Subject: [PATCH 085/156] Fold tc/let-values/check into tc/let-values. Remove printfs. More metafunctions to handle splitting and merging filter sets. Handle `delay', `list', `list*' Implement tc/funapp for the simple case. Make `id-from' a stxclass. Shuffle code around so that it compiles. Type parsing now handles multiple values properly, and has a values and results entry point. svn: r14680 --- collects/typed-scheme/private/parse-type.ss | 105 ++++++++++-------- .../typed-scheme/private/type-annotation.ss | 4 +- collects/typed-scheme/test.ss | 14 ++- collects/typed-scheme/typecheck/signatures.ss | 3 +- collects/typed-scheme/typecheck/tc-app.ss | 76 ++++++++++++- .../typed-scheme/typecheck/tc-expr-unit.ss | 4 +- .../typed-scheme/typecheck/tc-lambda-unit.ss | 4 +- .../typed-scheme/typecheck/tc-let-unit.ss | 10 +- .../typecheck/tc-metafunctions.ss | 29 ++++- collects/typed-scheme/types/abbrev.ss | 17 +-- collects/typed-scheme/types/utils.ss | 32 +++++- collects/typed-scheme/utils/tc-utils.ss | 17 ++- 12 files changed, 217 insertions(+), 98 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 147a9d5ea6..509aa3a439 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -1,25 +1,31 @@ #lang scheme/base -(provide parse-type parse-type/id parse-type*) + (require (except-in "../utils/utils.ss" extend)) (require (except-in (rep type-rep) make-arr) (rename-in (types convenience union utils) [make-arr* make-arr]) (utils tc-utils stxclass-util) - syntax/stx + syntax/stx (prefix-in c: scheme/contract) stxclass stxclass/util (env type-environments type-name-env type-alias-env lexical-env) (prefix-in t: "base-types-extra.ss") scheme/match (for-template scheme/base "base-types-extra.ss")) +(p/c [parse-type (syntax? . c:-> . Type/c)] + [parse-type/id (syntax? c:any/c . c:-> . Type/c)] + [parse-tc-results (syntax? . c:-> . tc-results?)] + [parse-tc-results/id (syntax? c:any/c . c:-> . tc-results?)] + [parse-type* (syntax? . c:-> . Type/c)]) + (define enable-mu-parsing (make-parameter #t)) -(define (parse-type/id loc datum) +(define ((parse/id p) loc datum) #;(printf "parse-type/id id : ~a~n ty: ~a~n" (syntax-object->datum loc) (syntax-object->datum stx)) (let* ([stx* (datum->syntax loc datum loc loc)]) - (parse-type stx*))) + (p stx*))) (define (stx-cadr stx) (stx-car (stx-cdr stx))) @@ -322,19 +328,20 @@ [(pred t) (eq? (syntax-e #'pred) 'pred) (make-pred-ty (parse-type #'t))] + ;; function types [(dom -> rng : pred-ty) (and (eq? (syntax-e #'->) '->) (eq? (syntax-e #':) ':)) (begin (add-type-name-reference (stx-cadr stx)) - (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty)))] + (make-pred-ty (list (parse-type #'dom)) (parse-values-type #'rng) (parse-type #'pred-ty)))] [(dom ... rest ::: -> rng) (and (eq? (syntax-e #'->) '->) (eq? (syntax-e #':::) '*)) (begin (add-type-name-reference #'->) - (->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-type #'rng)))] + (->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng)))] [(dom ... rest ::: bound -> rng) (and (eq? (syntax-e #'->) '->) (eq? (syntax-e #':::) '...) @@ -347,7 +354,7 @@ (make-Function (list (make-arr-dots (map parse-type (syntax->list #'(dom ...))) - (parse-type #'rng) + (parse-values-type #'rng) (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) (list (make-DottedBoth (make-F (syntax-e #'bound)))) (current-tvars))]) @@ -367,7 +374,7 @@ (make-Function (list (make-arr-dots (map parse-type (syntax->list #'(dom ...))) - (parse-type #'rng) + (parse-values-type #'rng) (parameterize ([current-tvars (extend-env (list var) (list (make-DottedBoth t)) (current-tvars))]) @@ -378,40 +385,8 @@ (eq? (syntax-e #'->) '->) (begin (add-type-name-reference #'->) - (->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rng)))] - [(values tys ... dty dd bound) - (and (eq? (syntax-e #'dd) '...) - (identifier? #'bound) - (eq? (syntax-e #'values) 'values)) - (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) - (if (not (Dotted? var)) - (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound)) - (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) - (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) - (list (make-DottedBoth (make-F (syntax-e #'bound)))) - (current-tvars))]) - (parse-type #'dty)) - (syntax-e #'bound))))] - [(values tys ... dty dd) - (and (eq? (syntax-e #'values) 'values) - (eq? (syntax-e #'dd) '...)) - (begin - (add-type-name-reference #'values) - (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) - (when (null? bounds) - (tc-error/stx stx "No type variable bound with ... in scope for ... type")) - (unless (null? (cdr bounds)) - (tc-error/stx stx "Cannot infer bound for ... type")) - (match-let ([(cons var (struct Dotted (t))) (car bounds)]) - (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) - (parameterize ([current-tvars (extend-env (list var) - (list (make-DottedBoth t)) - (current-tvars))]) - (parse-type #'dty)) - var))))] - [(values tys ...) - (eq? (syntax-e #'values) 'values) - (-values (map parse-type (syntax->list #'(tys ...))))] + (->* (map parse-type (syntax->list #'(dom ...))) (parse-values-type #'rng)))] + [(case-lambda tys ...) (eq? (syntax-e #'case-lambda) 'case-lambda) (make-Function @@ -459,7 +434,7 @@ [tv (make-Dotted (make-F v))]) (add-type-name-reference #'All) (parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))]) - (make-PolyDots (append vars (list v)) (parse-type #'t))))] + (make-PolyDots (append vars (list v)) (parse-values-type #'t))))] [(All (vars ...) t) (and (or (eq? (syntax-e #'All) 'All) (eq? (syntax-e #'All) '∀)) @@ -468,7 +443,7 @@ [tvars (map make-F vars)]) (add-type-name-reference #'All) (parameterize ([current-tvars (extend-env vars tvars (current-tvars))]) - (make-Poly vars (parse-type #'t))))] + (make-Poly vars (parse-values-type #'t))))] [(Opaque p?) (eq? (syntax-e #'Opaque) 'Opaque) (begin @@ -554,3 +529,45 @@ (string? (syntax-e #'t))) (-val (syntax-e #'t))] [_ (tc-error "not a valid type: ~a" (syntax->datum stx))]))) + +(define (parse-values-type stx) + (parameterize ([current-orig-stx stx]) + (syntax-parse stx + [(values tys ... dty :ddd bound:id) + #:when (eq? (syntax-e #'values) 'values) + (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) + (if (not (Dotted? var)) + (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound)) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) + (list (make-DottedBoth (make-F (syntax-e #'bound)))) + (current-tvars))]) + (parse-type #'dty)) + (syntax-e #'bound))))] + [(values tys ... dty :ddd) + #:when (and (eq? (syntax-e #'values) 'values)) + (add-type-name-reference #'values) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'dty)) + var)))] + [(values tys ...) + #:when (eq? (syntax-e #'values) 'values) + (-values (map parse-type (syntax->list #'(tys ...))))] + [t + (-values (list (parse-type #'t)))]))) + +(define (parse-tc-results stx) + (values->tc-results (parse-values-type stx))) + +(define parse-tc-results/id (parse/id parse-tc-results)) + +(define parse-type/id (parse/id parse-type)) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index ec556f4d83..ae5fc69a95 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -58,8 +58,8 @@ (define (pt prop) #;(print-size prop) (if (syntax? prop) - (parse-type prop) - (parse-type/id stx prop))) + (parse-tc-results prop) + (parse-tc-results/id stx prop))) (cond [(syntax-property stx type-ascrip-symbol) => pt] [else #f])) diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss index c9b5d7c541..a029c11dab 100644 --- a/collects/typed-scheme/test.ss +++ b/collects/typed-scheme/test.ss @@ -79,6 +79,7 @@ xxx6-y (: ff (Number -> Number)) (define (ff x) x) +(ff 1) (lambda: ([y : String][x : Number]) (values 1 x 1)) (lambda: ([x : Number]) (values 1 x 1)) @@ -86,4 +87,15 @@ xxx6-y (lambda () 1) #{(lambda (x) x) :: (Number -> Number)} ;; BUG - this should work -{ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))} \ No newline at end of file +{ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))} + +(list 1 2 3) +(ann (list 1 2 3) (Pair Number (Listof Integer))) +(ann (list 1 2 3) (Listof Integer)) +(ann (list 1 2 3) (Listof Number)) + +(list* 1 2 3) +(ann (list* 1 2 3 (list)) (Pair Number (Listof Integer))) + +((lambda (x) 1) 1) +((lambda (x y) 1) 1 2) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index 366056c830..c5ef2012fa 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -39,9 +39,8 @@ [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)])) (define-signature tc-let^ - ([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-results?)] + ([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)] [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-results?)] - [cnt tc/let-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)] [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)])) (define-signature tc-dots^ diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 3973404bd2..155196cde6 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -1,10 +1,11 @@ #lang scheme/unit (require (rename-in "../utils/utils.ss" [infer r:infer]) - "signatures.ss" + "signatures.ss" "tc-metafunctions.ss" stxclass scheme/match mzlib/trace (for-syntax stxclass) - (types utils) + (types utils abbrev) + (utils tc-utils) (rep type-rep filter-rep object-rep) (for-template (only-in '#%kernel [apply k:apply]) @@ -20,6 +21,7 @@ #:literals (#%plain-app #%plain-lambda letrec-values values apply k:apply not list list* call-with-values do-make-object make-object cons andmap ormap) + ;; special case for `values' [(#%plain-app values arg) (single-value #'arg expected)] [(#%plain-app values . args) (match expected @@ -35,7 +37,36 @@ [_ (match-let ([(list (tc-result1: ts fs os) ...) (for/list ([arg (syntax->list #'args)]) (single-value arg))]) - (ret ts fs os))])])) + (ret ts fs os))])] + ;; special case for `delay' + [(#%plain-app + mp1 + (#%plain-lambda () + (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) + #:declare mp1 (id-from 'make-promise 'scheme/promise) + #:declare mp2 (id-from 'make-promise 'scheme/promise) + (ret (-Promise (tc-expr/t #'e)))] + ;; special case for `list' + [(#%plain-app list . args) + (let ([tys (map tc-expr/t (syntax->list #'args))]) + (ret (apply -lst* tys)))] + ;; special case for `list*' + [(#%plain-app list* . args) + (match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))] + [tys (reverse tys-r)]) + (ret (foldr make-Pair last tys)))] + ;; inference for ((lambda + [(#%plain-app (#%plain-lambda (x ...) . body) args ...) + #:when (= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + (tc/let-values #'((x) ...) #'(args ...) #'body + #'(let-values ([(x) args] ...) . body) + expected)] + [(#%plain-app f . args) + (let* ([f-ty (single-value #'f)] + [arg-tys (map single-value (syntax->list #'args))]) + (tc/funapp #'f #'args f-ty arg-tys expected))] + [_ (int-err "tc/app NYI")])) ;(trace tc/app/internal) @@ -48,6 +79,41 @@ (check-below t expected) expected) -;; syntax? syntax? tc-result? (listof tc-results?) (or/c #f tc-results) -> tc-results? +(define (object-index os i) + (unless (number? i) + (int-err "object-index for keywords NYI")) + (list-ref os i)) + +;; in-indexes : Listof[Type] -> Sequence[index/c] +(define (in-indexes dom) + (in-range (length dom))) + +;; syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results) -> tc-results? (define (tc/funapp f-stx args-stx ftype0 argtys expected) - (error "tc/funapp NYI")) + (match* (ftype0 argtys) + [((tc-result1: (Function: (list (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) #f #f '())))) + (list (tc-result1: t-a phi-a o-a) ...)) + (unless (= (length dom) (length t-a)) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments")) + (for ([dom-t (in-list dom)] [arg-t (in-list t-a)]) + (check-below arg-t dom-t)) + (let* (;; Listof[Listof[LFilterSet]] + [lfs-f (for/list ([lf lf-r]) + (for/list ([i (in-indexes dom)]) + (split-lfilters lf i)))] + ;; Listof[FilterSet] + [f-r (for/list ([lfs lfs-f]) + (merge-filter-sets (for/list ([lf lfs] [t t-a] [o o-a]) + (apply-filter lf t o))))] + ;; Listof[Object] + [o-r (for/list ([lo lo-r]) + (match lo + [(LPath: pi* i) + (match (object-index o-a i) + [(Path: pi x) (make-Path (append pi* pi) x)] + [_ (make-Empty)])] + [_ (make-Empty)]))]) + (ret t-r f-r o-r))] + [(_ _) + (int-err "funapp with keyword/rest args NYI")])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 43fbcc996f..468aa19dee 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -238,7 +238,7 @@ (tc/send #'rcvr #'meth #'(args ...) expected)] ;; let [(let-values ([(name ...) expr] ...) . body) - (tc/let-values/check #'((name ...) ...) #'(expr ...) #'body form expected)] + (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)] [(letrec-values ([(name ...) expr] ...) . body) (tc/letrec-values/check #'((name ...) ...) #'(expr ...) #'body form expected)] ;; other @@ -340,7 +340,7 @@ (int-err "bad form input to tc-expr: ~a" form)) ;; typecheck form (let ([ty (cond [(type-ascription form) => (lambda (ann) - (tc-expr/check/type form ann))] + (tc-expr/check form ann))] [else (internal-tc-expr form)])]) (match ty [(tc-results: ts fs os) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index b0b1662938..f749365e0d 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -11,7 +11,7 @@ (rename-in (types convenience utils union) [make-arr* make-arr]) (private type-annotation) - (types abbrev) + (types abbrev utils) (env type-environments lexical-env) (utils tc-utils) mzlib/plt-match) @@ -68,7 +68,6 @@ arg-list arg-types (make lam-result (map list arg-list arg-types) null rest-ty drest (tc-exprs/check (syntax->list body) ret-ty)))) - (printf "arg-types old new: ~a ~a~n" arg-tys arg-types) (when (or (not (= arg-len tys-len)) (and rest (and (not rest-ty) (not drest)))) @@ -199,7 +198,6 @@ (match expected [(tc-result1: (Mu: _ _)) (loop (unfold expected))] [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) - (printf "expe: ~a~n" expected) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args (values->tc-results ret) rest drest))] [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))] diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 06083a25cd..e1aa8fda99 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -119,7 +119,7 @@ (-> expected))] [_ (tc-expr/t e)])) -(define (tc/let-values/internal namess exprs body form expected) +(define (tc/let-values namess exprs body form [expected #f]) (let* (;; a list of each name clause [names (map syntax->list (syntax->list namess))] ;; all the trailing expressions - the ones actually bound to the names @@ -133,12 +133,4 @@ [clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])]) (do-check void names types form types body clauses expected))) -(define (tc/let-values/check namess exprs body form expected) - (tc/let-values/internal namess exprs body form expected)) - -(define (tc/let-values namess exprs body form) - (tc/let-values/internal namess exprs body form #f)) - -;(trace tc/letrec-values/internal) - diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 7bb32a4950..2314431381 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -10,7 +10,8 @@ stxclass/util (for-syntax scheme/base)) -(provide combine-filter apply-filter abstract-filter abstract-filters) +(provide combine-filter apply-filter abstract-filter abstract-filters + split-lfilters merge-filter-sets) ;; this implements the sequence invariant described on the first page relating to Bot (define (lcombine l1 l2) @@ -57,7 +58,7 @@ [(Path: p (lookup: idx)) (make-LPath p idx)] [_ (make-LEmpty)])) -(define/contract (abstract-filter ids keys fs) +(d/c (abstract-filter ids keys fs) (-> (listof identifier?) (listof index/c) FilterSet? LFilterSet?) (match fs [(FilterSet: f+ f-) @@ -65,7 +66,7 @@ (apply append (for/list ([f f+]) (abo ids keys f))) (apply append (for/list ([f f-]) (abo ids keys f))))])) -(define/contract (abo xs idxs f) +(d/c (abo xs idxs f) (-> (listof identifier?) (listof index/c) Filter/c (or/c '() (list/c LatentFilter/c))) (define (lookup y) (for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) i)) @@ -78,7 +79,12 @@ [(NotTypeFilter: t p (lookup: idx)) (list (make-LNotTypeFilter t p idx))] [_ null])) -(define/contract (apply-filter lfs t o) +(define (merge-filter-sets fs) + (match fs + [(list (FilterSet: f+ f-) ...) + (make-FilterSet (apply append f+) (apply append f-))])) + +(d/c (apply-filter lfs t o) (-> LFilterSet? Type/c Object? FilterSet?) (match lfs [(LFilterSet: lf+ lf-) @@ -86,7 +92,7 @@ (apply append (for/list ([lf lf+]) (apo lf t o))) (apply append (for/list ([lf lf-]) (apo lf t o))))])) -(define/contract (apo lf s o) +(d/c (apo lf s o) (-> LatentFilter/c Type/c Object? (or/c '() (list/c Filter/c))) (match* (lf s o) [((LBot:) _ _) (list (make-Bot))] @@ -96,12 +102,23 @@ [((LTypeFilter: t pi* _) _ (Path: pi x)) (list (make-TypeFilter t (append pi* pi) x))] [((LNotTypeFilter: t pi* _) _ (Path: pi x)) (list (make-NotTypeFilter t (append pi* pi) x))])) +(define/contract (split-lfilters lf idx) + (LFilterSet? index/c . -> . LFilterSet?) + (define (idx= lf) + (match lf + [(LBot:) #t] + [(LNotTypeFilter: _ _ idx*) (type-equal? idx* idx)] + [(LTypeFilter: _ _ idx*) (type-equal? idx* idx)])) + (match lf + [(LFilterSet: lf+ lf-) + (make-LFilterSet (filter idx= lf+) (filter idx= lf-))])) + (define-match-expander T-FS: (lambda (stx) #'(FilterSet: _ (list (Bot:))))) (define-match-expander F-FS: (lambda (stx) #'(FilterSet: (list (Bot:)) _))) -(define/contract (combine-filter f1 f2 f3) +(d/c (combine-filter f1 f2 f3) (FilterSet? FilterSet? FilterSet? . -> . FilterSet?) (match* (f1 f2 f3) [(f (T-FS:) (F-FS:)) f] ;; the student expansion diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index be20981216..1b785e17a2 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -262,19 +262,4 @@ (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) (define-syntax-rule (->opt args ... [opt ...] res) - (opt-fn (list args ...) (list opt ...) res)) - -(define (tc-results->values tc) - (match tc - [(tc-results: ts fs os dty dbound) - (make-ValuesDots (map -result ts fs os) dty dbound)] - [(tc-results: ts fs os) - (make-Values (map -result ts fs os))])) - -;; FIXME - this should really be a new metafunction like abstract-filter -(define (values->tc-results tc) - (match tc - [(ValuesDots: (list (Result: ts fs os)) dty dbound) - (int-err "values->tc-results NYI for Dots")] - [(Values: (list (Result: ts fs os))) - (ret ts)])) \ No newline at end of file + (opt-fn (list args ...) (list opt ...) res)) \ No newline at end of file diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index e37685edd5..d80088f71b 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -30,7 +30,9 @@ just-Dotted? tc-error/expr lookup-fail - lookup-type-fail) + lookup-type-fail + values->tc-results + tc-results->values) ;; substitute : Type Name Type -> Type @@ -192,10 +194,13 @@ (define ret (case-lambda [(t) (make-tc-results - (if (Type? t) - (list (make-tc-result t (make-FilterSet null null) (make-Empty))) - (for/list ([i t]) - (make-tc-result i (make-FilterSet null null) (make-Empty)))) + (cond [(Type? t) + (list (make-tc-result t (make-FilterSet null null) (make-Empty)))] + [(or (Values? t) (ValuesDots? t)) + (values->tc-results t)] + [else + (for/list ([i t]) + (make-tc-result i (make-FilterSet null null) (make-Empty)))]) #f)] [(t f) (make-tc-results @@ -221,7 +226,7 @@ (p/c [ret - (->d ([t (or/c Type/c (listof Type/c))]) + (->d ([t (or/c Type/c (listof Type/c) Values? ValuesDots?)]) ([f (if (list? t) (listof FilterSet?) FilterSet?)] @@ -278,3 +283,18 @@ (define (lookup-type-fail i) (tc-error/expr "~a is not bound as a type" (syntax-e i))) + +(define (tc-results->values tc) + (match tc + [(tc-results: ts fs os dty dbound) + (make-ValuesDots (map make-Result ts fs os) dty dbound)] + [(tc-results: ts fs os) + (make-Values (map make-Result ts fs os))])) + +;; FIXME - this should really be a new metafunction like abstract-filter +(define (values->tc-results tc) + (match tc + [(ValuesDots: (list (Result: ts fs os)) dty dbound) + (int-err "values->tc-results NYI for Dots")] + [(Values: (list (Result: ts fs os) ...)) + (ret ts)])) \ No newline at end of file diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 515cbef66c..b92a4bafdb 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -6,7 +6,7 @@ don't depend on any other portion of the system |# (provide (all-defined-out)) -(require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match) +(require "syntax-traversal.ss" stxclass (for-syntax scheme/base stxclass) scheme/match) ;; a parameter representing the original location of the syntax being currently checked (define current-orig-stx (make-parameter #'here)) @@ -168,4 +168,17 @@ don't depend on any other portion of the system e)))) (syntax-parse stx [(_ e:spec ...) - #'(list (list e.id e.ty) ...)])) \ No newline at end of file + #'(list (list e.id e.ty) ...)])) + +;; id: identifier +;; sym: a symbol +;; mod: a quoted require spec like 'scheme/base +;; is id the name sym defined in mod? +(define (id-from? id sym mod) + (and (eq? (syntax-e id) sym) + (eq? (module-path-index-resolve (syntax-source-module id)) + ((current-module-name-resolver) mod #f #f #f)))) + +(define-syntax-class (id-from sym mod) + (pattern i:id + #:when (id-from? #'i sym mod))) \ No newline at end of file From 16305c20ff620f56df136583663a735b02f9a3a8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 2 May 2009 01:45:50 +0000 Subject: [PATCH 086/156] more tests svn: r14685 --- collects/typed-scheme/test2.ss | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 collects/typed-scheme/test2.ss diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss new file mode 100644 index 0000000000..33f552eb98 --- /dev/null +++ b/collects/typed-scheme/test2.ss @@ -0,0 +1,12 @@ +#lang typed-scheme + +(: f (Number String -> Number)) +(define (f x z) (f x z)) +(lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) +(lambda: ([x : Any] [y : Any]) (values (number? x) (number? y))) +(lambda: ([x : Any]) (values (number? x) (number? x))) +(: g (Any -> Boolean : Number)) +(define g (lambda: ([x : Any]) (number? x))) + +;(f 12 "hi") + From cce7f91b78955206b44c180c77b9c6d78be88ce4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 2 May 2009 12:46:53 +0000 Subject: [PATCH 087/156] fix values->tc-results, doesn't compile yet svn: r14688 --- .../typed-scheme/typecheck/tc-lambda-unit.ss | 2 +- .../typecheck/tc-metafunctions.ss | 22 +++++++++++++++++-- collects/typed-scheme/types/utils.ss | 8 ------- 3 files changed, 21 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index f749365e0d..f3a4ebc319 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -165,7 +165,7 @@ ;(trace tc-args) -;; tc/mono-lambda : syntax-list syntax-list -> (listof lam-result) +;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result) ;; typecheck a sequence of case-lambda clauses (define (tc/mono-lambda formals bodies expected) (define (syntax-len s) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 2314431381..f1e3c85418 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -11,7 +11,7 @@ (for-syntax scheme/base)) (provide combine-filter apply-filter abstract-filter abstract-filters - split-lfilters merge-filter-sets) + split-lfilters merge-filter-sets values->tc-results) ;; this implements the sequence invariant described on the first page relating to Bot (define (lcombine l1 l2) @@ -138,4 +138,22 @@ [(f f* f*) f*] [(_ _ _) ;; could intersect f2 and f3 here - (make-FilterSet null null)])) \ No newline at end of file + (make-FilterSet null null)])) + + +;; FIXME - this should really be a new metafunction like abstract-filter +;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results? +(define (values->tc-results tc formals) + (match tc + [(ValuesDots: (list (Result: ts fs os)) dty dbound) + (int-err "values->tc-results NYI for Dots")] + [(Values: (list (Result: ts lfs los) ...)) + (ret ts + (for/list ([lf lfs]) + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x)))) + (for/list ([lo los]) + (for/list ([x formals] [i (in-naturals)]) + (match lo + [(LEmpty:) (make-Empty)] + [(LPath: p (== i)) (make-Path p x)]))))])) \ No newline at end of file diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index d80088f71b..6c0e49b18d 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -290,11 +290,3 @@ (make-ValuesDots (map make-Result ts fs os) dty dbound)] [(tc-results: ts fs os) (make-Values (map make-Result ts fs os))])) - -;; FIXME - this should really be a new metafunction like abstract-filter -(define (values->tc-results tc) - (match tc - [(ValuesDots: (list (Result: ts fs os)) dty dbound) - (int-err "values->tc-results NYI for Dots")] - [(Values: (list (Result: ts fs os) ...)) - (ret ts)])) \ No newline at end of file From 9c538764dcd499d9b8a04b415a88835ccd55f1c9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 4 May 2009 18:49:56 +0000 Subject: [PATCH 088/156] `values->tc-results' needs the formals Fix values->tc-results for ValuesDots Don't generate problematic nested lists. Fix stupid typo. Parsing of tc-results now doesn't use parsing of values, which does something different. svn: r14713 --- collects/typed-scheme/private/parse-type.ss | 6 +++- collects/typed-scheme/test2.ss | 1 + .../typed-scheme/typecheck/tc-lambda-unit.ss | 3 +- .../typecheck/tc-metafunctions.ss | 36 +++++++++++++------ collects/typed-scheme/typecheck/tc-new-if.ss | 2 +- collects/typed-scheme/types/utils.ss | 14 ++------ 6 files changed, 37 insertions(+), 25 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 509aa3a439..d0752ee6c7 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -566,7 +566,11 @@ (-values (list (parse-type #'t)))]))) (define (parse-tc-results stx) - (values->tc-results (parse-values-type stx))) + (syntax-parse stx + [(values t ...) + #:when (eq? 'values (syntax-e #'values)) + (ret (map parse-type (syntax->list #'(t ...))))] + [t (parse-type #'t)])) (define parse-tc-results/id (parse/id parse-tc-results)) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 33f552eb98..4352321758 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -4,6 +4,7 @@ (define (f x z) (f x z)) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) (lambda: ([x : Any] [y : Any]) (values (number? x) (number? y))) +(lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y))) (lambda: ([x : Any]) (values (number? x) (number? x))) (: g (Any -> Boolean : Number)) (define g (lambda: ([x : Any]) (number? x))) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index f3a4ebc319..1e255f0f44 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -199,7 +199,8 @@ [(tc-result1: (Mu: _ _)) (loop (unfold expected))] [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) - (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args (values->tc-results ret) rest drest))] + (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) + args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))] [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))] ;; otherwise [else (go (syntax->list formals) (syntax->list bodies) null null null)])) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index f1e3c85418..d0dfda98b6 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -134,26 +134,40 @@ ;; or [((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (combine null (append f1- f3-))] ;; and - [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) (combine (append f1+ f2+) null)] + [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) + (combine (append f1+ f2+) null)] [(f f* f*) f*] [(_ _ _) ;; could intersect f2 and f3 here (make-FilterSet null null)])) - -;; FIXME - this should really be a new metafunction like abstract-filter ;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results? (define (values->tc-results tc formals) (match tc - [(ValuesDots: (list (Result: ts fs os)) dty dbound) - (int-err "values->tc-results NYI for Dots")] + [(ValuesDots: (list (Result: ts lfs los)) dty dbound) + (ret ts + (for/list ([lf lfs]) + (merge-filter-sets + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x))))) + (for/list ([lo los]) + (or + (for/or ([x formals] [i (in-naturals)]) + (match lo + [(LEmpty:) #f] + [(LPath: p (== i)) (make-Path p x)])) + (make-Empty))) + dty dbound)] [(Values: (list (Result: ts lfs los) ...)) (ret ts (for/list ([lf lfs]) - (for/list ([x formals] [i (in-naturals)]) - (apply-filter (split-lfilters lf i) Univ (make-Path null x)))) + (merge-filter-sets + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x))))) (for/list ([lo los]) - (for/list ([x formals] [i (in-naturals)]) - (match lo - [(LEmpty:) (make-Empty)] - [(LPath: p (== i)) (make-Path p x)]))))])) \ No newline at end of file + (or + (for/or ([x formals] [i (in-naturals)]) + (match lo + [(LEmpty:) #f] + [(LPath: p (== i)) (make-Path p x)])) + (make-Empty))))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss index dcd423df98..6970804c43 100644 --- a/collects/typed-scheme/typecheck/tc-new-if.ss +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -28,7 +28,7 @@ (cond [(= (length ts) (length us)) (ret (for/list ([t ts] [u us]) (Un t u)) (for/list ([f2 fs2] [f3 fs3]) - (combine-filter f1 f2 f2)))] + (combine-filter f1 f2 f3)))] [else (tc-error/expr #:return (ret Err) "Expected the same number of values from both branches of if expression, but got ~a and ~a" diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 6c0e49b18d..b7ad8b71de 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -30,9 +30,7 @@ just-Dotted? tc-error/expr lookup-fail - lookup-type-fail - values->tc-results - tc-results->values) + lookup-type-fail) ;; substitute : Type Name Type -> Type @@ -197,7 +195,8 @@ (cond [(Type? t) (list (make-tc-result t (make-FilterSet null null) (make-Empty)))] [(or (Values? t) (ValuesDots? t)) - (values->tc-results t)] + (int-err "Values in ret: ~a" t) + #;(values->tc-results t)] [else (for/list ([i t]) (make-tc-result i (make-FilterSet null null) (make-Empty)))]) @@ -283,10 +282,3 @@ (define (lookup-type-fail i) (tc-error/expr "~a is not bound as a type" (syntax-e i))) - -(define (tc-results->values tc) - (match tc - [(tc-results: ts fs os dty dbound) - (make-ValuesDots (map make-Result ts fs os) dty dbound)] - [(tc-results: ts fs os) - (make-Values (map make-Result ts fs os))])) From 6b89062d6a2e6b35fb24c71d7f0fb839d49546b1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 5 May 2009 16:27:18 +0000 Subject: [PATCH 089/156] Various constants are true. Remove useless code. `combine-filter' now handles producing the new type/object in appropriate cases. Move student expansion later in pattern match. Print out top-level tc-results. svn: r14721 --- .../typed-scheme/typecheck/tc-expr-unit.ss | 9 +++--- .../typed-scheme/typecheck/tc-lambda-unit.ss | 2 +- .../typecheck/tc-metafunctions.ss | 22 +++++++------- collects/typed-scheme/typecheck/tc-new-if.ss | 12 ++++---- collects/typed-scheme/typed-scheme.ss | 5 ++-- collects/typed-scheme/types/utils.ss | 30 +++++++++++-------- 6 files changed, 42 insertions(+), 38 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 468aa19dee..03baae8c33 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -188,9 +188,9 @@ [(quote #t) (ret (-val #t) true-filter)] [(quote val) (match expected [(tc-result1: t) - (ret (tc-literal #'val t))])] + (ret (tc-literal #'val t) true-filter)])] ;; syntax - [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))] + [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)) true-filter)] ;; mutation! [(set! id val) (match-let* ([(tc-result: id-t) (tc-expr #'id)] @@ -273,9 +273,9 @@ [(quote #f) (ret (-val #f) false-filter)] [(quote #t) (ret (-val #t) true-filter)] - [(quote val) (ret (tc-literal #'val))] + [(quote val) (ret (tc-literal #'val) true-filter)] ;; syntax - [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))] + [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)) true-filter)] ;; w-c-m [(with-continuation-mark e1 e2 e3) (begin (tc-expr/check/type #'e1 Univ) @@ -315,7 +315,6 @@ ;; application [(#%plain-app . _) (tc/app form)] ;; if - [(if tst body) (tc/if-twoarm #'tst #'body #'(#%app void))] [(if tst thn els) (tc/if-twoarm #'tst #'thn #'els)] diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 1e255f0f44..6119c29fc5 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -277,7 +277,7 @@ (define (tc/lambda/internal form formals bodies expected) (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) (ret (tc/plambda form formals bodies expected)) - (ret (tc/mono-lambda/type formals bodies expected)))) + (ret (tc/mono-lambda/type formals bodies expected) true-filter))) ;; tc/lambda : syntax syntax-list syntax-list -> tc-result (define (tc/lambda form formals bodies) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index d0dfda98b6..1a7ca3b9e9 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -118,28 +118,30 @@ (define-match-expander F-FS: (lambda (stx) #'(FilterSet: (list (Bot:)) _))) -(d/c (combine-filter f1 f2 f3) - (FilterSet? FilterSet? FilterSet? . -> . FilterSet?) +(d/c (combine-filter f1 f2 f3 t2 t3 o2 o3) + (FilterSet? FilterSet? FilterSet? Type? Type? Object? Object? . -> . tc-results?) + (define (mk f) (ret (Un t2 t3) f (make-Empty))) (match* (f1 f2 f3) - [(f (T-FS:) (F-FS:)) f] ;; the student expansion - [((T-FS:) f _) f] - [((F-FS:) _ f) f] + [((T-FS:) f _) (ret t2 f o2)] + [((F-FS:) _ f) (ret t3 f o3)] ;; skipping the general or/predicate rule because it's really complicated ;; or/predicate special case for one elem lists ;; note that we are relying on equal? on identifiers here [((FilterSet: (list (TypeFilter: t pi x)) (list (NotTypeFilter: t pi x))) (T-FS:) (FilterSet: (list (TypeFilter: s pi x)) (list (NotTypeFilter: s pi x)))) - (make-FilterSet (list (make-TypeFilter (Un t s) pi x)) (list (make-NotTypeFilter (Un t s) pi x)))] + (mk (make-FilterSet (list (make-TypeFilter (Un t s) pi x)) (list (make-NotTypeFilter (Un t s) pi x))))] ;; or - [((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (combine null (append f1- f3-))] + [((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (mk (combine null (append f1- f3-)))] ;; and [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) - (combine (append f1+ f2+) null)] - [(f f* f*) f*] + (mk (combine (append f1+ f2+) null))] + [(f f* f*) (mk f*)] + ;; the student expansion + [(f (T-FS:) (F-FS:)) (mk f)] [(_ _ _) ;; could intersect f2 and f3 here - (make-FilterSet null null)])) + (mk (make-FilterSet null null))])) ;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results? (define (values->tc-results tc formals) diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss index 6970804c43..6d6bc87be9 100644 --- a/collects/typed-scheme/typecheck/tc-new-if.ss +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -20,15 +20,15 @@ (define (tc/if-twoarm tst thn els [expected #f]) (define (tc e) (if expected (tc-expr/check e expected) (tc-expr e))) - (match (tc-expr tst) + (match (single-value tst) [(tc-result1: _ (and f1 (FilterSet: fs+ fs-)) _) - (match-let ([(tc-results: ts fs2 _) (with-lexical-env (env+ (lexical-env) fs+) (tc thn))] - [(tc-results: us fs3 _) (with-lexical-env (env+ (lexical-env) fs-) (tc els))]) + (match-let ([(tc-results: ts fs2 os2) (with-lexical-env (env+ (lexical-env) fs+) (tc thn))] + [(tc-results: us fs3 os3) (with-lexical-env (env+ (lexical-env) fs-) (tc els))]) ;; if we have the same number of values in both cases (cond [(= (length ts) (length us)) - (ret (for/list ([t ts] [u us]) (Un t u)) - (for/list ([f2 fs2] [f3 fs3]) - (combine-filter f1 f2 f3)))] + (combine-results + (for/list ([t ts] [u us] [o2 os2] [o3 os3] [f2 fs2] [f3 fs3]) + (combine-filter f1 f2 f3 t u o2 o3)))] [else (tc-error/expr #:return (ret Err) "Expected the same number of values from both branches of if expression, but got ~a and ~a" diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 72053d9b05..49d1ea97cf 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -130,9 +130,8 @@ body2] [_ (let ([ty-str (match type [(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f] - [(tc-result1: t) - (format "- : ~a\n" t)] - [(tc-results: ts) (format "- : ~a\n" (cons 'values ts))] + [(tc-results: t) + (format "- : ~a\n" type)] [x (int-err "bad type result: ~a" x)])]) (if #'ty-str #`(let ([type '#,ty-str]) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index b7ad8b71de..da45eab2f5 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -30,7 +30,8 @@ just-Dotted? tc-error/expr lookup-fail - lookup-type-fail) + lookup-type-fail + combine-results) ;; substitute : Type Name Type -> Type @@ -190,17 +191,15 @@ ;; convenience function for returning the result of typechecking an expression (define ret - (case-lambda [(t) - (make-tc-results - (cond [(Type? t) - (list (make-tc-result t (make-FilterSet null null) (make-Empty)))] - [(or (Values? t) (ValuesDots? t)) - (int-err "Values in ret: ~a" t) - #;(values->tc-results t)] - [else - (for/list ([i t]) - (make-tc-result i (make-FilterSet null null) (make-Empty)))]) - #f)] + (case-lambda [(t) + (let ([mk (lambda (t) (make-FilterSet null null))]) + (make-tc-results + (cond [(Type? t) + (list (make-tc-result t (mk t) (make-Empty)))] + [else + (for/list ([i t]) + (make-tc-result i (mk t) (make-Empty)))]) + #f))] [(t f) (make-tc-results (if (Type? t) @@ -225,7 +224,7 @@ (p/c [ret - (->d ([t (or/c Type/c (listof Type/c) Values? ValuesDots?)]) + (->d ([t (or/c Type/c (listof Type/c))]) ([f (if (list? t) (listof FilterSet?) FilterSet?)] @@ -236,6 +235,11 @@ [dbound symbol?]) [_ tc-results?])]) +(define (combine-results tcs) + (match tcs + [(list (tc-result1: t f o) ...) + (ret t f o)])) + (define (subst v t e) (substitute t v e)) From 59dbcade9c888afac614dba06b4c93cdff64c6b7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 5 May 2009 19:10:21 +0000 Subject: [PATCH 090/156] Handle rest args and case-lambda in app. Fix parsing. svn: r14722 --- collects/typed-scheme/private/parse-type.ss | 2 +- collects/typed-scheme/test2.ss | 13 ++++- .../typed-scheme/typecheck/tc-app-helper.ss | 41 +++++++++++++++ collects/typed-scheme/typecheck/tc-app.ss | 51 ++++++++++++++----- .../typed-scheme/typecheck/tc-lambda-unit.ss | 13 ++--- 5 files changed, 99 insertions(+), 21 deletions(-) create mode 100644 collects/typed-scheme/typecheck/tc-app-helper.ss diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index d0752ee6c7..0818d2a574 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -570,7 +570,7 @@ [(values t ...) #:when (eq? 'values (syntax-e #'values)) (ret (map parse-type (syntax->list #'(t ...))))] - [t (parse-type #'t)])) + [t (ret (parse-type #'t))])) (define parse-tc-results/id (parse/id parse-tc-results)) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 4352321758..d895c3b5e6 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -1,13 +1,24 @@ #lang typed-scheme (: f (Number String -> Number)) -(define (f x z) (f x z)) +(define (f x z) #;(f x z) 7) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) (lambda: ([x : Any] [y : Any]) (values (number? x) (number? y))) (lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y))) (lambda: ([x : Any]) (values (number? x) (number? x))) (: g (Any -> Boolean : Number)) (define g (lambda: ([x : Any]) (number? x))) +(: q ((Number -> Number) -> Number)) +(define q (lambda: ([x : (Number -> Number)]) (x 1))) +;(q (lambda (z) (f z "foo"))) + +(: p (Number * -> Number)) +(define (p . x) 7) + +(lambda x (number? x)) +(+) +(+ 1 2 3) +(+ 1 2 3.5) ;(f 12 "hi") diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss new file mode 100644 index 0000000000..f5f268e9cc --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -0,0 +1,41 @@ +#lang scheme/base + +(require "../utils/utils.ss" + (utils tc-utils)) + +(provide (all-defined-out)) + +(define (stringify-domain dom rst drst [rng #f]) + (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] + [rng-string (if rng (format " -> ~a" rng) "")]) + (cond [drst + (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] + [rst + (format "~a~a *~a" doms-string rst rng-string)] + [else (string-append (stringify dom) rng-string)]))) + +(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) + (define arguments-str + (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f))) + (cond + [(null? doms) + (int-err "How could doms be null: ~a ~a" ty)] + [(= 1 (length doms)) + (format "Domain: ~a~nArguments: ~a~n~a" + (stringify-domain (car doms) (car rests) (car drests)) + arguments-str + (if expected + (format "Result type: ~a~nExpected result: ~a~n" + (car rngs) expected) + ""))] + [else + (format "~a: ~a~nArguments: ~a~n~a" + (if expected "Types" "Domains") + (stringify (if expected + (map stringify-domain doms rests drests rngs) + (map stringify-domain doms rests drests)) + "~n\t") + arguments-str + (if expected + (format "Expected result: ~a~n" expected) + ""))])) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 155196cde6..eee6b699b6 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -2,9 +2,10 @@ (require (rename-in "../utils/utils.ss" [infer r:infer]) "signatures.ss" "tc-metafunctions.ss" + "tc-app-helper.ss" stxclass scheme/match mzlib/trace (for-syntax stxclass) - (types utils abbrev) + (types utils abbrev union subtype) (utils tc-utils) (rep type-rep filter-rep object-rep) (for-template @@ -88,24 +89,48 @@ (define (in-indexes dom) (in-range (length dom))) -;; syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results) -> tc-results? (define (tc/funapp f-stx args-stx ftype0 argtys expected) (match* (ftype0 argtys) - [((tc-result1: (Function: (list (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) #f #f '())))) + ;; we special-case this (no case-lambda) for improved error messages + [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws)))))) + argtys) + (tc/funapp1 f-stx args-stx a argtys expected)] + [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests #f kws) ...))))) + (and argtys (list (tc-result1: argtys-t) ...))) + (let loop ([doms* doms] [rngs rngs] [rests* rests] [a arrs]) + (cond [(null? doms*) + (tc-error/expr + #:return (or expected (ret (Un))) + (string-append "No function domains matched in function application:\n" + (domain-mismatches t doms rests #f rngs argtys #f #f)))] + [(subtypes/varargs argtys-t (car doms*) (car rests*)) + (tc/funapp1 f-stx args-stx (car a) argtys expected #:check #f)] + [else (loop (cdr doms*) (cdr rngs) (cdr rests*) (cdr a))]))])) + + +;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? +(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) + (match* (ftype0 argtys) + [((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f '()) (list (tc-result1: t-a phi-a o-a) ...)) - (unless (= (length dom) (length t-a)) - (tc-error/expr #:return (ret t-r) - "Wrong number of arguments")) - (for ([dom-t (in-list dom)] [arg-t (in-list t-a)]) - (check-below arg-t dom-t)) + (when check? + (cond [(and (not rest) (not (= (length dom) (length t-a)))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] + [(and rest (< (length t-a) (length dom))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) + (for ([dom-t (in-list-forever dom rest)] [a (syntax->list args-stx)] [arg-t (in-list t-a)]) + (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (let* (;; Listof[Listof[LFilterSet]] [lfs-f (for/list ([lf lf-r]) - (for/list ([i (in-indexes dom)]) - (split-lfilters lf i)))] + (for/list ([i (in-indexes dom)]) + (split-lfilters lf i)))] ;; Listof[FilterSet] [f-r (for/list ([lfs lfs-f]) - (merge-filter-sets (for/list ([lf lfs] [t t-a] [o o-a]) - (apply-filter lf t o))))] + (merge-filter-sets + (for/list ([lf lfs] [t t-a] [o o-a]) + (apply-filter lf t o))))] ;; Listof[Object] [o-r (for/list ([lo lo-r]) (match lo @@ -116,4 +141,4 @@ [_ (make-Empty)]))]) (ret t-r f-r o-r))] [(_ _) - (int-err "funapp with keyword/rest args NYI")])) \ No newline at end of file + (int-err "funapp with keyword args NYI")])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 6119c29fc5..59080124c5 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -5,7 +5,7 @@ "tc-metafunctions.ss" mzlib/trace scheme/list - stxclass/util + stxclass/util syntax/stx (rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c]) (except-in (rep type-rep) make-arr) (rename-in (types convenience utils union) @@ -160,10 +160,11 @@ #f (tc-exprs (syntax->list body)))))]))])) - -;; FIXED TO HERE - -;(trace tc-args) +(define (formals->list l) + (let loop ([l (syntax-e l)]) + (cond [(stx-pair? l) (cons (stx-car l) (loop (stx-cdr l)))] + [(pair? l) (cons (car l) (loop (cdr l)))] + [else null]))) ;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result) ;; typecheck a sequence of case-lambda clauses @@ -200,7 +201,7 @@ [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) - args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))] + args (values->tc-results ret (formals->list (car (syntax->list formals)))) rest drest))] [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))] ;; otherwise [else (go (syntax->list formals) (syntax->list bodies) null null null)])) From 07341c605b9660333444665265a4fb3104efdc6e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 5 May 2009 23:03:02 +0000 Subject: [PATCH 091/156] Remove `make-arr/values' Accessors now have appropriate latent objects Handle function application for unions, error, mu, parameters svn: r14724 --- collects/typed-scheme/env/init-envs.ss | 5 +- collects/typed-scheme/private/base-env.ss | 4 +- collects/typed-scheme/test2.ss | 12 +++++ collects/typed-scheme/typecheck/tc-app.ss | 49 ++++++++++++++----- collects/typed-scheme/typecheck/tc-envops.ss | 22 ++++++--- .../typed-scheme/typecheck/tc-lambda-unit.ss | 2 +- collects/typed-scheme/typecheck/tc-structs.ss | 10 +++- collects/typed-scheme/types/abbrev.ss | 13 ----- collects/typed-scheme/types/resolve.ss | 5 +- 9 files changed, 83 insertions(+), 39 deletions(-) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index 029810693b..4b87fadc95 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -5,7 +5,7 @@ (require "type-env.ss" "type-name-env.ss" "type-alias-env.ss" - (rep type-rep object-rep filter-rep) + (rep type-rep object-rep filter-rep rep-utils) (for-template (rep type-rep object-rep filter-rep) (types union) mzlib/pconvert mzlib/shared scheme/base) @@ -36,7 +36,8 @@ [(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))) + (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))) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 17e73dbfcf..7e8b742bf2 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -250,7 +250,7 @@ [apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] -[time-apply (-polydots (b a) (make-arr/values +[time-apply (-polydots (b a) (make-arr (list ((list) (a a) . ->... . b) (-lst a)) (-values (list (-pair b (-val '())) N N N))))] @@ -261,7 +261,7 @@ [quotient (-Integer -Integer . -> . -Integer)] [remainder (-Integer -Integer . -> . -Integer)] [quotient/remainder - (make-arr/values (list -Integer -Integer) (-values (list -Integer -Integer)))] + (make-arr (list -Integer -Integer) (-values (list -Integer -Integer)))] ;; parameter stuff diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index d895c3b5e6..a4305927fb 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -19,6 +19,18 @@ (+) (+ 1 2 3) (+ 1 2 3.5) +#| +(define-struct: (Z) x ([y : Z])) +(define: my-x : (x Number) (make-x 1)) +(number? (x-y my-x)) +(if (number? (x-y my-x)) (+ 1 (x-y my-x)) 7) +|# + +(define: (f2) : (U) (error 'foo)) +(lambda: ([x : Number]) #{((f2)) :: (U)}) + +(: f3 (U (Number -> Number) (Number -> String))) +(define (f3 x) 7) ;(f 12 "hi") diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index eee6b699b6..43b4ba8d0b 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -5,7 +5,7 @@ "tc-app-helper.ss" stxclass scheme/match mzlib/trace (for-syntax stxclass) - (types utils abbrev union subtype) + (types utils abbrev union subtype resolve) (utils tc-utils) (rep type-rep filter-rep object-rep) (for-template @@ -95,17 +95,44 @@ [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws)))))) argtys) (tc/funapp1 f-stx args-stx a argtys expected)] - [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests #f kws) ...))))) + [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...))))) (and argtys (list (tc-result1: argtys-t) ...))) - (let loop ([doms* doms] [rngs rngs] [rests* rests] [a arrs]) - (cond [(null? doms*) - (tc-error/expr - #:return (or expected (ret (Un))) - (string-append "No function domains matched in function application:\n" - (domain-mismatches t doms rests #f rngs argtys #f #f)))] - [(subtypes/varargs argtys-t (car doms*) (car rests*)) - (tc/funapp1 f-stx args-stx (car a) argtys expected #:check #f)] - [else (loop (cdr doms*) (cdr rngs) (cdr rests*) (cdr a))]))])) + (or + ;; find the first function where the argument types match + (for/first ([dom doms] [rng rngs] [rest rests] [a arrs] + #:when (subtypes/varargs argtys-t dom rest)) + ;; then typecheck here + ;; we call the separate function so that we get the appropriate filters/objects + (tc/funapp1 f-stx args-stx a argtys expected #:check #f)) + ;; if nothing matched, error + (tc-error/expr + #:return (or expected (ret (Un))) + (string-append "No function domains matched in function application:\n" + (domain-mismatches t doms rests drests rngs argtys-t #f #f))))] + ;; parameters are functions too + [((tc-result1: (Param: in out)) (list)) (ret out)] + [((tc-result1: (Param: in out)) (list (tc-result1: t))) + (if (subtype t in) + (ret -Void true-filter) + (tc-error/expr #:return (ret -Void true-filter) + "Wrong argument to parameter - expected ~a and got ~a" in t))] + [((tc-result1: (Param: _ _)) _) + (tc-error/expr #:return (ret (Un)) + "Wrong number of arguments to parameter - expected 0 or 1, got ~a" + (length argtys))] + ;; resolve names, polymorphic apps, mu, etc + [((tc-result1: (? needs-resolving? t) f o) _) + (tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)] + ;; a union of functions can be applied if we can apply all of the elements + [((tc-result1: (Union: (and ts (list (Function: _) ...)))) _) + (ret (for/fold ([result (Un)]) ([fty ts]) + (match (tc/funapp f-stx args-stx (ret fty) argtys expected) + [(tc-result1: t) (Un result t)])))] + ;; error type is a perfectly good fcn type + [((tc-result1: (Error:)) _) (ret (make-Error))] + ;; otherwise fail + [((tc-result1: f-ty) _) (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" f-ty)])) ;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index 292391ed00..a96e1b42ca 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -7,9 +7,11 @@ [one-of/c -one-of/c]) (infer-in infer) (rep type-rep) + (utils tc-utils) + (types resolve) (only-in (env type-environments lexical-env) env? update-type/lexical env-map) scheme/contract scheme/match - stxclass/util + stxclass/util mzlib/trace (for-syntax scheme/base)) (provide env+) @@ -19,9 +21,11 @@ [(zero? i) (cons (f (car l)) (cdr l))] [else (cons (car l) (replace-nth (cdr l) (sub1 i) f))])) +(trace replace-nth) + (define/contract (update t lo) (Type/c Filter/c . -> . Type/c) - (match* (t lo) + (match* ((resolve t) lo) ;; pair ops [((Pair: t s) (TypeFilter: u (list* (CarPE:) rst) x)) (make-Pair (update t (make-TypeFilter u rst x)) s)] @@ -34,17 +38,19 @@ ;; struct ops [((Struct: nm par flds proc poly pred cert) - (TypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) - (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-TypeFilter u rst x)))))] + (TypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) + (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-TypeFilter u rst x)))) proc poly pred cert)] [((Struct: nm par flds proc poly pred cert) (NotTypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) - (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-NotTypeFilter u rst x)))))] + (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-NotTypeFilter u rst x)))) proc poly pred cert)] ;; otherwise [(t (TypeFilter: u (list) _)) (restrict t u)] [(t (NotTypeFilter: u (list) _)) - (remove t u)])) + (remove t u)] + [(_ _) + (int-err "update along ill-typed path: ~a ~a" t lo)])) (define/contract (env+ env fs) (env? (listof Filter/c) . -> . env?) @@ -52,4 +58,6 @@ (match f [(Bot:) (env-map (lambda (x) (cons (car x) (Un))) Γ)] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) - (update-type/lexical (lambda (x t) (update t f)) x Γ)]))) + (update-type/lexical (lambda (x t) + (printf "upd: ~a ~a ~a~n" t f (update t f)) + (update t f)) x Γ)]))) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 59080124c5..48f5a6e9cb 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -30,7 +30,7 @@ (define (lam-result->type lr) (match lr [(struct lam-result ((list (list arg-ids arg-tys) ...) (list (list kw kw-id kw-ty req?) ...) rest drest body)) - (make-arr/values + (make-arr arg-tys (abstract-filters (append (for/list ([i (in-naturals)] [_ arg-ids]) i) kw) (append arg-ids kw-id) diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 395a82bdc2..c388b8b735 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -3,7 +3,7 @@ (require (except-in "../utils/utils.ss" extend)) (require (rep type-rep) (private parse-type) - (types convenience utils union resolve) + (types convenience utils union resolve abbrev) (env type-env type-environments type-name-env) (utils tc-utils) "def-binding.ss" @@ -129,7 +129,13 @@ (wrapper (->* external-fld-types (if cret cret name)))) (cons pred (make-pred-ty (pred-wrapper name)))) - (map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent) + (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) + (let ([func (if setters? + (->* (list name) t) + (make-Function + (list (make-arr* (list sty) t + #:object (make-LPath (list (make-StructPE name i)) 0)))))]) + (cons g (wrapper func)))) (if setters? (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) null))) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 1b785e17a2..7ec654ed5e 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -169,19 +169,6 @@ (make-Values (list (-result rng filters obj)))) rest drest (sort #:key Keyword-kw kws keyword* ((listof Type/c) (or/c ValuesDots? Values?)) - (#:rest (or/c Type/c #f) - #:drest (or/c (cons/c Type/c symbol?) #f) - #:kws (listof Keyword?) - #:filters LFilterSet? - #:object LatentObject?) - arr?) - (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword* (syntax-rules (:) [(_ dom rng) diff --git a/collects/typed-scheme/types/resolve.ss b/collects/typed-scheme/types/resolve.ss index 7a132543bb..520cc444f7 100644 --- a/collects/typed-scheme/types/resolve.ss +++ b/collects/typed-scheme/types/resolve.ss @@ -8,7 +8,7 @@ scheme/match mzlib/trace) -(provide resolve-name resolve-app needs-resolving? resolve-once) +(provide resolve-name resolve-app needs-resolving? resolve-once resolve) (define (resolve-name t) (match t @@ -33,3 +33,6 @@ [(Mu: _ _) (unfold t)] [(App: r r* s) (resolve-app r r* s)] [(Name: _) (resolve-name t)])) + +(define (resolve t) + (if (needs-resolving? t) (resolve-once t) t)) From 50696a08a31258428edf4af9d58c84d763a2bc17 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 6 May 2009 22:45:12 +0000 Subject: [PATCH 092/156] Handle polymorphic function application. Paths work with car/cdr. Fix #%require/#%provide top-level handling. svn: r14735 --- collects/typed-scheme/infer/infer-unit.ss | 4 +- collects/typed-scheme/infer/signatures.ss | 3 +- collects/typed-scheme/private/base-env.ss | 27 +++++++---- collects/typed-scheme/test2.ss | 21 ++++++-- .../typed-scheme/typecheck/tc-app-helper.ss | 26 +++++++++- collects/typed-scheme/typecheck/tc-app.ss | 48 ++++++++++++++++++- .../typecheck/tc-metafunctions.ss | 8 +++- collects/typed-scheme/typed-scheme.ss | 6 +-- collects/typed-scheme/types/abbrev.ss | 15 +++++- collects/typed-scheme/types/utils.ss | 6 ++- 10 files changed, 136 insertions(+), 28 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 20bbf1f274..e0fdae3a08 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -454,11 +454,11 @@ (let ([cs (cgen/list null X S T)]) (if (not expected) (subst-gen cs R must-vars) - (cset-meet cs (cgen null X R expected)))))) + (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) ;; like infer, but T-var is the vararg type: (define (infer/vararg X S T T-var R must-vars [expected #f]) - (define new-T (extend S T T-var)) + (define new-T (if T-var (extend S T T-var) T)) (and ((length S) . >= . (length T)) (infer X S new-T R must-vars expected))) diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss index a3b85665f3..b9b9be1286 100644 --- a/collects/typed-scheme/infer/signatures.ss +++ b/collects/typed-scheme/infer/signatures.ss @@ -33,7 +33,8 @@ [cnt infer/vararg (((listof symbol?) (listof Type?) (listof Type?) - Type? Type? + (or/c #f Type?) + Type? (listof symbol?)) ((or/c #f Type?)) . ->* . any)] [cnt infer/dots (((listof symbol?) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 7e8b742bf2..398fd0e782 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -14,7 +14,23 @@ [raise (Univ . -> . (Un))] -[car (-poly (a b) (cl-> [((-pair a b)) a] [((-lst a)) a]))] +[car (-poly (a b) + (cl->* + (->acc (list (-pair a b)) a (list -car)) + (->* (list (-lst a)) a)))] +[cdr (-poly (a b) + (cl->* + (->acc (list (-pair a b)) b (list -cdr)) + (->* (list (-lst a)) (-lst a))))] + +[cadr (-poly (a b c) + (cl-> [((-pair a (-pair b c))) b] + [((-lst a)) a]))] +[caddr (-poly (a) (-> (-lst a) a))] +[cadddr (-poly (a) (-> (-lst a) a))] +[cddr (-poly (a) (-> (-lst a) (-lst a)))] +[cdddr (-poly (a) (-> (-lst a) (-lst a)))] + [first (-poly (a b) (cl-> [((-pair a b)) a] [((-lst a)) a]))] [second (-poly (a b c) (cl-> [((-pair a (-pair b c))) b] @@ -26,14 +42,7 @@ [fifth (-poly (a) ((-lst a) . -> . a))] [sixth (-poly (a) ((-lst a) . -> . a))] [rest (-poly (a) ((-lst a) . -> . (-lst a)))] -[cadr (-poly (a b c) - (cl-> [((-pair a (-pair b c))) b] - [((-lst a)) a]))] -[caddr (-poly (a) (-> (-lst a) a))] -[cadddr (-poly (a) (-> (-lst a) a))] -[cdr (-poly (a b) (cl-> [((-pair a b)) b] [((-lst a)) (-lst a)]))] -[cddr (-poly (a) (-> (-lst a) (-lst a)))] -[cdddr (-poly (a) (-> (-lst a) (-lst a)))] + [cons (-poly (a b) (cl-> [(a (-lst a)) (-lst a)] [(a b) (-pair a b)]))] diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index a4305927fb..860a39efa0 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -19,11 +19,12 @@ (+) (+ 1 2 3) (+ 1 2 3.5) -#| -(define-struct: (Z) x ([y : Z])) -(define: my-x : (x Number) (make-x 1)) -(number? (x-y my-x)) -(if (number? (x-y my-x)) (+ 1 (x-y my-x)) 7) + +(define-struct: (Z) X ([y : Z])) +(define: my-x : (X Number) (make-X 1)) +#| ; FIXME - doesn't work yet +(number? (X-y my-x)) +(if (number? (X-y my-x)) (+ 1 (X-y my-x)) 7) |# (define: (f2) : (U) (error 'foo)) @@ -32,5 +33,15 @@ (: f3 (U (Number -> Number) (Number -> String))) (define (f3 x) 7) +(define: x : (List Any Any) (list 1 23 )) +(car x) +(if (number? (car x)) (add1 (car #{x :: (Pair Number Any)})) 7) +(if (number? (car x)) (add1 (car x)) 7) + +;; error ;(f 12 "hi") +(map + (list 1 2 3)) +(map + (list 1 2 3) (list 1 2 3)) +;; error +;(map + (list 1 2 3) (list 1 2 "foo")) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss index f5f268e9cc..4ea2ff3071 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.ss +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require "../utils/utils.ss" - (utils tc-utils)) +(require "../utils/utils.ss" scheme/match + (utils tc-utils) (rep type-rep) (types utils union)) (provide (all-defined-out)) @@ -39,3 +39,25 @@ (if expected (format "Expected result: ~a~n" expected) ""))])) + +(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) + (match t + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '()) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '()) ...)))) + (let ([fcn-string (if name + (format "function ~a" (syntax->datum name)) + "function")]) + (if (and (andmap null? msg-doms) + (null? argtypes)) + (tc-error/expr #:return (ret (Un)) + (string-append + "Could not infer types for applying polymorphic " + fcn-string + "\n")) + (tc-error/expr #:return (ret (Un)) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:~n" + (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + "")))))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 43b4ba8d0b..16e7d2d618 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -4,10 +4,11 @@ "signatures.ss" "tc-metafunctions.ss" "tc-app-helper.ss" stxclass scheme/match mzlib/trace - (for-syntax stxclass) + (for-syntax stxclass scheme/base) (types utils abbrev union subtype resolve) (utils tc-utils) (rep type-rep filter-rep object-rep) + (r:infer infer) (for-template (only-in '#%kernel [apply k:apply]) "internal-forms.ss" scheme/base @@ -89,6 +90,19 @@ (define (in-indexes dom) (in-range (length dom))) + +(define-syntax (handle-clauses stx) + (syntax-parse stx + [(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected) + (with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))]) + (syntax/loc stx + (or (for/or ([vars lsts] ... [a arrs] + #:when (pred vars ... a)) + (let ([substitution (infer vars ... a)]) + (and substitution + (tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f)))) + (poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) + (define (tc/funapp f-stx args-stx ftype0 argtys expected) (match* (ftype0 argtys) ;; we special-case this (no case-lambda) for improved error messages @@ -109,6 +123,34 @@ #:return (or expected (ret (Un))) (string-append "No function domains matched in function application:\n" (domain-mismatches t doms rests drests rngs argtys-t #f #f))))] + ;; polymorphic functions without dotted rest + [((tc-result1: (and t + (or (Poly: vars + (Function: (list (and arrs (arr: doms rngs rests (and drests #f) '())) ...))) + (PolyDots: vars + (Function: (list (and arrs (arr: doms rngs rests (and drests #f) '())) ...)))))) + (list (tc-result1: argtys-t) ...)) + (handle-clauses (doms rngs rests arrs) f-stx args-stx + ;; only try inference if the argument lengths are appropriate + (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) + ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) + ;; note that we have to use argtys-t here, since argtys is a list of tc-results + (lambda (dom rng rest a) (infer/vararg vars argtys-t dom rest rng (fv rng) (and expected (tc-results->values expected)))) + t argtys expected)] + ;; polymorphic ... type + [((tc-result1: (and t (PolyDots: + (and vars (list fixed-vars ... dotted-var)) + (Function: (list (and arrs (arr: doms rngs (and #f rests) (cons dtys dbounds) '())) ...))))) + (list (tc-result1: argtys-t) ...)) + (handle-clauses (doms dtys dbounds rngs arrs) f-stx args-stx + (lambda (dom dty dbound rng arr) (and (<= (length dom) (length argtys)) + (eq? dotted-var dbound))) + (lambda (dom dty dbound rng arr) + (infer/dots fixed-vars dotted-var argtys-t dom dty rng (fv rng) #:expected (and expected (tc-results->values expected)))) + t argtys expected)] + ;; procedural structs + [(tc-result1: (and sty (Struct: _ _ _ (? Type? proc-ty) _ _ _))) + (tc/funapp f-stx (cons (syntax/loc f-stx dummy) args-stx) (ret proc-ty) (cons sty argtys) expected)] ;; parameters are functions too [((tc-result1: (Param: in out)) (list)) (ret out)] [((tc-result1: (Param: in out)) (list (tc-result1: t))) @@ -167,5 +209,7 @@ [_ (make-Empty)])] [_ (make-Empty)]))]) (ret t-r f-r o-r))] - [(_ _) + [((arr: _ _ _ drest '()) _) + (int-err "funapp with drest args NYI")] + [((arr: _ _ _ _ kws) _) (int-err "funapp with keyword args NYI")])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 1a7ca3b9e9..cea9cb4499 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -11,7 +11,7 @@ (for-syntax scheme/base)) (provide combine-filter apply-filter abstract-filter abstract-filters - split-lfilters merge-filter-sets values->tc-results) + split-lfilters merge-filter-sets values->tc-results tc-results->values) ;; this implements the sequence invariant described on the first page relating to Bot (define (lcombine l1 l2) @@ -172,4 +172,8 @@ (match lo [(LEmpty:) #f] [(LPath: p (== i)) (make-Path p x)])) - (make-Empty))))])) \ No newline at end of file + (make-Empty))))])) + +(define (tc-results->values tc) + (match tc + [(tc-results: ts) (-values ts)])) \ No newline at end of file diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 49d1ea97cf..36770a4321 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -119,11 +119,11 @@ ;; typecheck the body, and produce syntax-time code that registers types [let ([type (tc-toplevel-form body2)])]) (define-syntax-class invis-kw - #:literals (define-values define-syntaxes require provide begin) + #:literals (define-values define-syntaxes #%require #%provide begin) (pattern define-values) (pattern define-syntaxes) - (pattern require) - (pattern provide) + (pattern #%require) + (pattern #%provide) (pattern begin)) (syntax-parse body2 [(head:invis-kw . _) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 7ec654ed5e..1b5e2f930d 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -125,6 +125,9 @@ (define -no-lobj (make-LEmpty)) (define -no-obj (make-Empty)) +(define -car (make-CarPE)) +(define -cdr (make-CdrPE)) + ;; convenient syntax (define-syntax -v @@ -177,8 +180,12 @@ (make-Function (list (make-arr* dom rng #:rest rst)))] [(_ dom rng : filters) (make-Function (list (make-arr* dom rng #:filters filters)))] + [(_ dom rng : filters : object) + (make-Function (list (make-arr* dom rng #:filters filters #:object object)))] [(_ dom rst rng : filters) - (make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))])) + (make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))] + [(_ dom rst rng : filters : object) + (make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))])) (define-syntax (-> stx) (syntax-parse stx @@ -201,6 +208,12 @@ [(_ dom (dty dbound) rng : filters) (make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))])) +(define (->acc dom rng path) + (make-Function (list (make-arr* dom rng + #:filters (-LFS (list (-not-filter (-val #f) path)) + (list (-filter (-val #f) path))) + #:object (make-LPath path 0))))) + (define (cl->* . args) (define (funty-arities f) (match f diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index da45eab2f5..35e36327b5 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -187,7 +187,11 @@ [(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op))) #f))] [(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _))) #f))])) -(provide tc-result: tc-results: tc-result1: tc-result? tc-results?) +(define (tc-results-t tc) + (match tc + [(tc-results: t) t])) + +(provide tc-result: tc-results: tc-result1: tc-result? tc-results? tc-results-t) ;; convenience function for returning the result of typechecking an expression (define ret From aa887be6d2def1ba9f3c57abb82b31f771ff35f9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 7 May 2009 17:40:29 +0000 Subject: [PATCH 093/156] Type inference for ((lambda with rest args svn: r14739 --- collects/typed-scheme/test2.ss | 4 +++- collects/typed-scheme/typecheck/tc-app.ss | 15 ++++++++++++--- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 860a39efa0..779f389a5e 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -44,4 +44,6 @@ (map + (list 1 2 3)) (map + (list 1 2 3) (list 1 2 3)) ;; error -;(map + (list 1 2 3) (list 1 2 "foo")) \ No newline at end of file +;(map + (list 1 2 3) (list 1 2 "foo")) + +((lambda (a b . c) (+ a b (car c))) 1 2 3 4) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 16e7d2d618..6ea9bf03c3 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -3,7 +3,7 @@ (require (rename-in "../utils/utils.ss" [infer r:infer]) "signatures.ss" "tc-metafunctions.ss" "tc-app-helper.ss" - stxclass scheme/match mzlib/trace + stxclass scheme/match mzlib/trace scheme/list (for-syntax stxclass scheme/base) (types utils abbrev union subtype resolve) (utils tc-utils) @@ -64,11 +64,20 @@ (tc/let-values #'((x) ...) #'(args ...) #'body #'(let-values ([(x) args] ...) . body) expected)] + ;; inference for ((lambda with dotted rest + [(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) + #:when (<= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + (let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) + (with-syntax ([(fixed-args ...) fixed-args] + [varg #`(#%plain-app list #,@varargs)]) + (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body + #'(let-values ([(x) fixed-args] ... [(rst) varg]) . body) + expected)))] [(#%plain-app f . args) (let* ([f-ty (single-value #'f)] [arg-tys (map single-value (syntax->list #'args))]) - (tc/funapp #'f #'args f-ty arg-tys expected))] - [_ (int-err "tc/app NYI")])) + (tc/funapp #'f #'args f-ty arg-tys expected))])) ;(trace tc/app/internal) From d2cc1b2400a6c15c4103de0a0f4f2561cd0c9ce9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 7 May 2009 20:17:38 +0000 Subject: [PATCH 094/156] All code from old app is now in new app svn: r14740 --- collects/typed-scheme/typecheck/tc-app.ss | 397 ++++++++++++++++++- collects/typed-scheme/typecheck/tc-envops.ss | 4 +- collects/typed-scheme/types/utils.ss | 12 +- 3 files changed, 403 insertions(+), 10 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 6ea9bf03c3..1416aaceb4 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -2,11 +2,14 @@ (require (rename-in "../utils/utils.ss" [infer r:infer]) "signatures.ss" "tc-metafunctions.ss" - "tc-app-helper.ss" + "tc-app-helper.ss" "find-annotation.ss" stxclass scheme/match mzlib/trace scheme/list (for-syntax stxclass scheme/base) - (types utils abbrev union subtype resolve) + (private type-annotation) + (types utils abbrev union subtype resolve convenience) (utils tc-utils) + (only-in srfi/1 alist-delete) + (except-in (env type-environments) extend) (rep type-rep filter-rep object-rep) (r:infer infer) (for-template @@ -17,14 +20,371 @@ (import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Comparators + +;; comparators that inform the type system +(define-syntax-class comparator + #:literals (eq? equal? eqv? = string=? symbol=?) + (pattern eq?) (pattern equal?) (pattern eqv?) (pattern =) (pattern string=?) (pattern symbol=?)) + +;; typecheck eq? applications +;; identifier identifier expression expression expression +;; identifier expr expr -> tc-results +(define (tc/eq comparator v1 v2) + (define (ok? val) + (define-syntax-rule (alt nm pred ...) (and (free-identifier=? #'nm comparator) (or (pred val) ...))) + (or (alt symbol=? symbol?) + (alt string=? string?) + (alt = number?) + (alt eq? boolean? keyword? symbol?) + (alt eqv? boolean? keyword? symbol? number?) + (alt equal? (lambda (x) #t)))) + (match* ((single-value v1) (single-value v2)) + [((tc-result1: t _ o) (tc-result1: (Value: (? ok? val)))) + (ret -Boolean (apply-filter (make-LFilterSet (list (make-LTypeFilter (-val val) null 0)) (list (make-LNotTypeFilter (-val val) null 0))) t o))] + [((tc-result1: (Value: (? ok? val))) (tc-result1: t _ o)) + (ret -Boolean (apply-filter (make-LFilterSet (list (make-LTypeFilter (-val val) null 0)) (list (make-LNotTypeFilter (-val val) null 0))) t o))] + [(_ _) (ret -Boolean)])) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Keywords + +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (arr: dom rng rest #f ktys)) + ;; assumes that everything is in sorted order + (let loop ([actual-kws kws] + [actuals (map tc-expr/t (syntax->list kw-args))] + [formals ktys]) + (match* (actual-kws formals) + [('() '()) + (void)] + [(_ '()) + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws))] + [('() (cons fst rst)) + (match fst + [(Keyword: k _ #t) + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k)] + [_ (loop actual-kws actuals rst)])] + [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) + (cond [(eq? k k*) ;; we have a match + (unless (subtype (car actuals) t) + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k)) + (loop kws-rest (cdr actuals) form-rest)] + [req? ;; this keyword argument was required + (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)] + [else ;; otherwise, ignore this formal param, and continue + (loop actual-kws actuals form-rest)])])) + (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + [_ (int-err "case-lambda w/ keywords not supported")])) + +(define (type->list t) + (match t + [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] + [(Value: '()) null] + [_ (int-err "bad value in type->list: ~a" t)])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Objects + +(define (check-do-make-object cl pos-args names named-args) + (let* ([names (map syntax-e (syntax->list names))] + [name-assoc (map list names (syntax->list named-args))]) + (let loop ([t (tc-expr cl)]) + (match t + [(tc-result: (? Mu? t)) (loop (ret (unfold t)))] + [(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) + (unless (= (length pos-tys) + (length (syntax->list pos-args))) + (tc-error/delayed "expected ~a positional arguments, but got ~a" + (length pos-tys) (length (syntax->list pos-args)))) + ;; use for, since they might be different lengths in error case + (for ([pa (in-syntax pos-args)] + [pt (in-list pos-tys)]) + (tc-expr/check pa pt)) + (for ([n names] + #:when (not (memq n tnames))) + (tc-error/delayed + "unknown named argument ~a for class~nlegal named arguments are ~a" + n (stringify tnames))) + (for-each (match-lambda + [(list tname tfty opt?) + (let ([s (cond [(assq tname name-assoc) => cadr] + [(not opt?) + (tc-error/delayed "value not provided for named init arg ~a" tname) + #f] + [else #f])]) + (if s + ;; this argument was present + (tc-expr/check s tfty) + ;; this argument wasn't provided, and was optional + #f))]) + tnflds) + (ret (make-Instance c))] + [(tc-result: t) + (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; let loop + +(define (let-loop-check form lp actuals args body expected) + (syntax-parse #`(#,args #,body #,actuals) + #:literals (#%plain-app if null?) + [((val acc ...) + ((if (#%plain-app null? val*) thn els)) + (actual actuals ...)) + (and (free-identifier=? #'val #'val*) + (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a)) + (syntax->list #'(acc ...)))) + (let* ([ts1 (generalize (tc-expr/t #'actual))] + [ann-ts (for/list ([a (in-syntax #'(acc ...))] + [ac (in-syntax #'(actuals ...))]) + (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) + (generalize (tc-expr/t ac))))] + [ts (cons ts1 ann-ts)]) + ;; check that the actual arguments are ok here + (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) + ;; then check that the function typechecks with the inferred types + (tc/rec-lambda/check form args body lp ts expected) + (ret expected))] + ;; special case when argument needs inference + [_ + (let ([ts (for/list ([ac (syntax->list actuals)] + [f (syntax->list args)]) + (or + (type-annotation f #:infer #t) + (generalize (tc-expr/t ac))))]) + (tc/rec-lambda/check form args body lp ts expected) + (ret expected))])) + +(define (tc/apply f args) + (define f-ty (single-value f)) + ;; produces the first n-1 elements of the list, and the last element + (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) + (values f (car r)))) + (define-values (fixed-args tail) (split (syntax->list args))) + + (match f-ty + [(tc-result1: (Function: (list (arr: doms rngs rests drests '()) ...))) + (when (null? doms) + (tc-error/expr #:return (ret (Un)) + "empty case-lambda given as argument to apply")) + (let ([arg-tys (map tc-expr/t fixed-args)]) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (cond [(null? doms*) + (let-values ([(tail-ty tail-bound) + (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))]) + (tc/dots tail))]) + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to function in apply:~n" + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))] + [(and (car rests*) + (let-values ([(tail-ty tail-bound) + (with-handlers ([exn:fail? (lambda _ (values #f #f))]) + (tc/dots tail))]) + (and tail-ty + (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty)) + (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) + (printf/log "Non-poly apply, ... arg\n") + (ret (car rngs*))] + [(and (car rests*) + (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)]) + (tc-expr/t tail))]) + (and tail-ty + (subtype (apply -lst* arg-tys #:tail tail-ty) + (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) + + (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) + "Simple arithmetic non-poly apply\n" + "Simple non-poly apply\n")) + (ret (car rngs*))] + [(and (car drests*) + (let-values ([(tail-ty tail-bound) + (with-handlers ([exn:fail? (lambda _ (values #f #f))]) + (tc/dots tail))]) + (and tail-ty + (eq? (cdr (car drests*)) tail-bound) + (subtypes arg-tys (car doms*)) + (subtype tail-ty (car (car drests*)))))) + (printf/log "Non-poly apply, ... arg\n") + (ret (car rngs*))] + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '()) ..1)))) + (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) + (tc/dots tail))]) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (cond [(null? doms*) + (match f-ty + [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1)))) + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to polymorphic function in apply:~n" + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + ;; the actual work, when we have a * function and a list final argument + [(and (car rests*) + (not tail-bound) + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons tail-ty arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; actual work, when we have a * function and ... final arg + [(and (car rests*) + tail-bound + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons (make-Listof tail-ty) arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg + [(and (car drests*) + tail-bound + (eq? tail-bound (cdr (car drests*))) + (= (length (car doms*)) + (length arg-tys)) + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; if nothing matches, around the loop again + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result1: (Poly: vars (Function: '()))) + (tc-error/expr #:return (ret (Un)) + "Function has no cases")] + [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) + (Function: (list (arr: doms rngs rests drests '()) ..1)))) + (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) + (tc/dots tail))]) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (cond [(null? doms*) + (match f-ty + [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1)))) + (tc-error/expr #:return (ret (Un)) + (string-append + "Bad arguments to polymorphic function in apply:~n" + (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + ;; the actual work, when we have a * function and a list final argument + [(and (car rests*) + (not tail-bound) + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons tail-ty arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + ;; actual work, when we have a * function and ... final arg + [(and (car rests*) + tail-bound + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars + (cons (make-Listof tail-ty) arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*) + (fv (car rngs*)))) + => (lambda (substitution) + (ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg, same bound on ... + [(and (car drests*) + tail-bound + (eq? tail-bound (cdr (car drests*))) + (= (length (car doms*)) + (length arg-tys)) + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg, different bound on ... + [(and (car drests*) + tail-bound + (not (eq? tail-bound (cdr (car drests*)))) + (= (length (car doms*)) + (length arg-tys)) + (parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*))) + (list (make-DottedBoth (make-F tail-bound)) + (make-DottedBoth (make-F (cdr (car drests*))))) + (current-tvars))]) + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (ret (substitute-dotted (cadr (assq drest-bound substitution)) + tail-bound + drest-bound + (subst-all (alist-delete drest-bound substitution eq?) + (car rngs*)))))] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (ret (subst-all substitution (car rngs*))))] + ;; if nothing matches, around the loop again + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result1: (PolyDots: vars (Function: '()))) + (tc-error/expr #:return (ret (Un)) + "Function has no cases")] + [(tc-result1: f-ty) (tc-error/expr #:return (ret (Un)) + "Type of argument to apply is not a function type: ~n~a" f-ty)])) + +;; the main dispatching function ;; syntax tc-results? -> tc-results? (define (tc/app/internal form expected) (syntax-parse form - #:literals (#%plain-app #%plain-lambda letrec-values + #:literals (#%plain-app #%plain-lambda letrec-values quote values apply k:apply not list list* call-with-values do-make-object make-object cons - andmap ormap) - ;; special case for `values' + andmap ormap) + ;; in eq? cases, call tc/eq + [(#%plain-app eq?:comparator v1 v2) + ;; make sure the whole expression is type correct + (tc/funapp #'eq? #'(v1 v2) (single-value #'eq?) (map single-value (syntax->list #'(v1 v2))) expected) + ;; check thn and els with the eq? info + (tc/eq #'eq? #'v1 #'v2)] + ;; special-case for not - flip the filters + [(#%plain-app not arg) + (match (single-value #'arg) + [(tc-result1: t (FilterSet: f+ f-) _) + (ret t (make-FilterSet f- f+))])] + ;; (apply values l) gets special handling + [(#%plain-app apply values e) + (cond [(with-handlers ([exn:fail? (lambda _ #f)]) + (untuple (tc-expr/t #'e))) + => (lambda (t) (ret (-values t)))] + [else (tc/apply #'values #'(e))])] + ;; rewrite this so that it takes advantages of all the special cases + [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (apply . args)) expected)] + ;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value [(#%plain-app values arg) (single-value #'arg expected)] + ;; handle `values' specially [(#%plain-app values . args) (match expected [(tc-results: ets efs eos) @@ -39,7 +399,32 @@ [_ (match-let ([(list (tc-result1: ts fs os) ...) (for/list ([arg (syntax->list #'args)]) (single-value arg))]) - (ret ts fs os))])] + (ret ts fs os))])] + ;; rewrite this so that it takes advantages of all the special cases + [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (apply . args)) expected)] + ;; special case for keywords + [(#%plain-app + (#%plain-app kpe kws num fn) + kw-list + (#%plain-app list . kw-arg-list) + . pos-args) + #:declare kpe (id-from 'keyword-procedure-extract 'scheme/private/kw) + (match (tc-expr #'fn) + [(tc-result1: (Function: arities)) + (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [(tc-result1: t) (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] + ;; even more special case for match + [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) + #:when expected + #:when (not (andmap type-annotation (syntax->list #'args))) + #:when (free-identifier=? #'lp #'lp*) + (let-loop-check form #'lp #'actuals #'args #'body expected)] + ;; special cases for classes + [(#%plain-app make-object cl . args) + (check-do-make-object #'cl #'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 ...))] ;; special case for `delay' [(#%plain-app mp1 diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index a96e1b42ca..da851f3839 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -58,6 +58,4 @@ (match f [(Bot:) (env-map (lambda (x) (cons (car x) (Un))) Γ)] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) - (update-type/lexical (lambda (x t) - (printf "upd: ~a ~a ~a~n" t f (update t f)) - (update t f)) x Γ)]))) + (update-type/lexical (lambda (x t) (update t f)) x Γ)]))) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 35e36327b5..ecb4f49106 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -191,7 +191,17 @@ (match tc [(tc-results: t) t])) -(provide tc-result: tc-results: tc-result1: tc-result? tc-results? tc-results-t) +(provide tc-result: tc-results: tc-result1: tc-result? tc-results? tc-results-t Result1: Results:) + +(define-match-expander Result1: + (syntax-parser + [(_ tp) #'(Values: (list (Result: tp _ _)))] + [(_ tp fp op) #'(Values: (list (Result: tp fp op)))])) + +(define-match-expander Results: + (syntax-parser + [(_ tp) #'(Values: (list (Result: tp _ _) (... ...)))] + [(_ tp fp op) #'(Values: (list (Result: tp fp op) (... ...)))])) ;; convenience function for returning the result of typechecking an expression (define ret From dbe5556b45a036e0457dc2f5ae6abcfad31d2947 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 19:00:07 +0000 Subject: [PATCH 095/156] Add missing file. Fix bug in struct type creation. Add ability to disable printing dynamically. Fix recursion into objects & paths. svn: r14747 --- collects/typed-scheme/infer/infer-unit.ss | 6 +- collects/typed-scheme/rep/type-rep.ss | 17 ++++- collects/typed-scheme/test.ss | 2 +- collects/typed-scheme/test2.ss | 11 ++-- .../typed-scheme/typecheck/find-annotation.ss | 65 +++++++++++++++++++ collects/typed-scheme/typecheck/tc-structs.ss | 4 +- collects/typed-scheme/typed-scheme.ss | 4 +- collects/typed-scheme/types/printer.ss | 2 +- collects/typed-scheme/types/utils.ss | 2 +- collects/typed-scheme/utils/utils.ss | 24 ++++--- 10 files changed, 114 insertions(+), 23 deletions(-) create mode 100644 collects/typed-scheme/typecheck/find-annotation.ss diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index e0fdae3a08..3b240d2370 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -452,6 +452,7 @@ (define (infer X S T R must-vars [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let ([cs (cgen/list null X S T)]) + (printf "finished step 1~n") (if (not expected) (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) @@ -459,7 +460,10 @@ ;; like infer, but T-var is the vararg type: (define (infer/vararg X S T T-var R must-vars [expected #f]) (define new-T (if T-var (extend S T T-var) T)) + (printf "infer/vararg: ~a~n" (list X S T)) + (printf "new-T: ~a~n" new-T) (and ((length S) . >= . (length T)) + (printf "finished step 0~n") (infer X S new-T R must-vars expected))) ;; like infer, but dotted-var is the bound on the ... @@ -486,4 +490,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -;(trace cgen) +(trace cgen subst-gen) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 754884c03f..0d470720b8 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -341,6 +341,17 @@ #:LatentFilter (sub-lf st)) e)) +(define ((sub-lo st) e) + (latentobject-case (#:Type st + #:LatentObject (sub-lo st) + #:PathElem (sub-pe st)) + e)) + +(define ((sub-pe st) e) + (pathelem-case (#:Type st + #:PathElem (sub-pe st)) + e)) + ;; abstract-many : Names Type -> Scope^n ;; where n is the length of names (define (abstract-many names ty) @@ -349,7 +360,7 @@ (define (sb t) (loop outer t)) (define slf (sub-lf sb)) (type-case - (#:Type sb #:LatentFilter (sub-lf sb)) + (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb)) ty [#:F name* (if (eq? name name*) (*B (+ count outer)) ty)] ;; necessary to avoid infinite loops @@ -392,7 +403,7 @@ (define (sb t) (loop outer t)) (define slf (sub-lf sb)) (type-case - (#:Type sb #:LatentFilter slf) + (#:Type sb #:LatentFilter slf #:LatentObject (sub-lo sb)) ty [#:B idx (if (= (+ count outer) idx) image @@ -580,7 +591,7 @@ free-vars* type-equal? type-compare type Number)} -;; BUG - this should work + {ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))} (list 1 2 3) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 779f389a5e..e5b55e11ba 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -1,5 +1,5 @@ #lang typed-scheme - +#| (: f (Number String -> Number)) (define (f x z) #;(f x z) 7) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) @@ -19,14 +19,16 @@ (+) (+ 1 2 3) (+ 1 2 3.5) - +|# (define-struct: (Z) X ([y : Z])) (define: my-x : (X Number) (make-X 1)) +(X-y my-x) + #| ; FIXME - doesn't work yet (number? (X-y my-x)) (if (number? (X-y my-x)) (+ 1 (X-y my-x)) 7) |# - +#| (define: (f2) : (U) (error 'foo)) (lambda: ([x : Number]) #{((f2)) :: (U)}) @@ -46,4 +48,5 @@ ;; error ;(map + (list 1 2 3) (list 1 2 "foo")) -((lambda (a b . c) (+ a b (car c))) 1 2 3 4) \ No newline at end of file +((lambda (a b . c) (+ a b (car c))) 1 2 3 4) +|# diff --git a/collects/typed-scheme/typecheck/find-annotation.ss b/collects/typed-scheme/typecheck/find-annotation.ss new file mode 100644 index 0000000000..8ac74b4d78 --- /dev/null +++ b/collects/typed-scheme/typecheck/find-annotation.ss @@ -0,0 +1,65 @@ +#lang scheme/base + +(require "../utils/utils.ss" stxclass + scheme/contract + (rep type-rep) + (private type-annotation)) + +(p/c [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))]) + +(define-syntax-class lv-clause + #:transparent + (pattern [(v:id ...) e:expr])) + +(define-syntax-class lv-clauses + #:transparent + (pattern (cl:lv-clause ...) + #:with (e ...) #'(cl.e ...) + #:with (vs ...) #'((cl.v ...) ...))) + +(define-syntax-class core-expr + #:literals (reverse letrec-syntaxes+values let-values #%plain-app + if letrec-values begin #%plain-lambda set! case-lambda + begin0 with-continuation-mark) + #:transparent + (pattern (let-values cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (letrec-values cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (letrec-syntaxes+values _ cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (#%plain-app expr ...)) + (pattern (if expr ...)) + (pattern (with-continuation-mark expr ...)) + (pattern (begin expr ...)) + (pattern (begin0 expr ...)) + (pattern (#%plain-lambda _ e) + #:with (expr ...) #'(e)) + (pattern (case-lambda [_ expr] ...)) + (pattern (set! _ e) + #:with (expr ...) #'(e)) + (pattern _ + #:with (expr ...) #'())) + +;; expr id -> type or #f +;; if there is a binding in stx of the form: +;; (let ([x (reverse name)]) e) +;; where x has a type annotation, return that annotation, otherwise #f +(define (find-annotation stx name) + (define (find s) (find-annotation s name)) + (define (match? b) + (syntax-parse b + #:literals (#%plain-app reverse) + [c:lv-clause + #:with (#%plain-app reverse n:id) #'c.e + #:with (v) #'(c.v ...) + #:when (free-identifier=? name #'n) + (type-annotation #'v)] + [_ #f])) + (syntax-parse stx + #:literals (let-values) + [(let-values cls:lv-clauses body) + (or (ormap match? (syntax->list #'cls)) + (find #'body))] + [e:core-expr + (ormap find (syntax->list #'(e.expr ...)))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index c388b8b735..4f1b3c00ce 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -126,14 +126,14 @@ (define bindings (append (list (cons (or maker* maker) - (wrapper (->* external-fld-types (if cret cret name)))) + (debug (wrapper (->* external-fld-types (if cret cret name))))) (cons pred (make-pred-ty (pred-wrapper name)))) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) (let ([func (if setters? (->* (list name) t) (make-Function - (list (make-arr* (list sty) t + (list (make-arr* (list name) t #:object (make-LPath (list (make-StructPE name i)) 0)))))]) (cons g (wrapper func)))) (if setters? diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 36770a4321..5646b76a53 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -48,7 +48,9 @@ [with-handlers ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))) (lambda (e) (tc-error "Internal error: ~a" e))])] - [parameterize (;; a cheat to avoid units + [parameterize (;; disable fancy printing + [custom-printer #t] + ;; a cheat to avoid units [infer-param infer] ;; do we report multiple errors [delay-errors? #t] diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 6667f41fc7..9eeca9b249 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -116,7 +116,7 @@ ;; names are just the printed as the original syntax [(Name: stx) (fp "~a" (syntax-e stx))] [(App: rator rands stx) - (fp "~a" (cons rator rands))] + (fp "~a" (list* '@ rator rands))] ;; special cases for lists [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (fp "(Listof ~a)" elem-ty)] diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index ecb4f49106..2a768e0fb0 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -38,7 +38,7 @@ (define (substitute image name target #:Un [Un (get-union-maker)]) (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) - (type-case (#:Type sb #:LatentFilter (sub-lf sb)) + (type-case (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb)) target [#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index f322ad0307..69041a536c 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -22,6 +22,7 @@ at least theoretically. debug in-syntax symbol-append + custom-printer rep utils typecheck infer env private) (define-syntax (define-requirer stx) @@ -200,6 +201,18 @@ at least theoretically. (defprinter print-type* print-filter* print-latentfilter* print-object* print-latentobject* print-pathelem*) + +(define pseudo-printer + (lambda (s port mode) + (parameterize ([current-output-port port] + [show-sharing #f] + [booleans-as-true/false #f] + [constructor-style-printing #t]) + (newline) + (pretty-print (print-convert s)) + (newline)))) + +(define custom-printer (make-parameter #t)) (require scheme/pretty mzlib/pconvert) @@ -208,15 +221,8 @@ at least theoretically. [(form name (flds ...) printer) #`(define-struct/properties name (flds ...) #,(if printing? - #'([prop:custom-write printer]) - #'([prop:custom-write (lambda (s port mode) - (parameterize ([current-output-port port] - [show-sharing #f] - [booleans-as-true/false #f] - [constructor-style-printing #t]) - (newline) - (pretty-print (print-convert s)) - (newline)))])) + #'([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)])) (define (id kw . args) From 3575ba8d5fb8ee8378c69165e88f1af444795a2c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 19:10:12 +0000 Subject: [PATCH 096/156] Remove debugging printfs. Comment tests back in. svn: r14748 --- collects/typed-scheme/infer/infer-unit.ss | 6 +----- collects/typed-scheme/test2.ss | 12 ++++++------ collects/typed-scheme/typecheck/tc-structs.ss | 2 +- 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 3b240d2370..7981b69d4d 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -452,7 +452,6 @@ (define (infer X S T R must-vars [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let ([cs (cgen/list null X S T)]) - (printf "finished step 1~n") (if (not expected) (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) @@ -460,10 +459,7 @@ ;; like infer, but T-var is the vararg type: (define (infer/vararg X S T T-var R must-vars [expected #f]) (define new-T (if T-var (extend S T T-var) T)) - (printf "infer/vararg: ~a~n" (list X S T)) - (printf "new-T: ~a~n" new-T) (and ((length S) . >= . (length T)) - (printf "finished step 0~n") (infer X S new-T R must-vars expected))) ;; like infer, but dotted-var is the bound on the ... @@ -490,4 +486,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -(trace cgen subst-gen) +;(trace cgen subst-gen) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index e5b55e11ba..f590a5d788 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -1,5 +1,5 @@ #lang typed-scheme -#| + (: f (Number String -> Number)) (define (f x z) #;(f x z) 7) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) @@ -19,16 +19,16 @@ (+) (+ 1 2 3) (+ 1 2 3.5) -|# + (define-struct: (Z) X ([y : Z])) (define: my-x : (X Number) (make-X 1)) (X-y my-x) -#| ; FIXME - doesn't work yet +; FIXME - doesn't work yet (number? (X-y my-x)) (if (number? (X-y my-x)) (+ 1 (X-y my-x)) 7) -|# -#| + + (define: (f2) : (U) (error 'foo)) (lambda: ([x : Number]) #{((f2)) :: (U)}) @@ -49,4 +49,4 @@ ;(map + (list 1 2 3) (list 1 2 "foo")) ((lambda (a b . c) (+ a b (car c))) 1 2 3 4) -|# + diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 4f1b3c00ce..47bcd92a23 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -126,7 +126,7 @@ (define bindings (append (list (cons (or maker* maker) - (debug (wrapper (->* external-fld-types (if cret cret name))))) + (wrapper (->* external-fld-types (if cret cret name)))) (cons pred (make-pred-ty (pred-wrapper name)))) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) From f6f9b20f17ef5be7a84cd37ab6f8eac883036a65 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 20:10:53 +0000 Subject: [PATCH 097/156] Rename vars. svn: r14749 --- .../typed-scheme/unit-tests/subtype-tests.ss | 130 +++++++++--------- 1 file changed, 65 insertions(+), 65 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 69b56012f6..3725582e68 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -29,97 +29,97 @@ (subtyping-tests ;; trivial examples (Univ Univ) - (N Univ) - (B Univ) - (Sym Univ) + (-Number Univ) + (-Boolean Univ) + (-Symbol Univ) (-Void Univ) - [N N] + [-Number -Number] [(Un (-pair Univ (-lst Univ)) (-val '())) (-lst Univ)] - [(-pair N (-pair N (-pair (-val 'foo) (-val '())))) (-lst Univ)] - [(-pair N (-pair N (-pair (-val 'foo) (-val '())))) (-lst (Un N Sym))] - [(-pair (-val 6) (-val 6)) (-pair N N)] + [(-pair -Number (-pair -Number (-pair (-val 'foo) (-val '())))) (-lst Univ)] + [(-pair -Number (-pair -Number (-pair (-val 'foo) (-val '())))) (-lst (Un -Number -Symbol))] + [(-pair (-val 6) (-val 6)) (-pair -Number -Number)] [(-val 6) (-val 6)] ;; unions - [(Un N) N] - [(Un N N) N] - [(Un N Sym) (Un Sym N)] - [(Un (-val 6) (-val 7)) N] - [(Un (-val #f) (Un (-val 6) (-val 7))) (Un N (Un B Sym))] - [(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un N (Un B Sym)))] - [(Un N (-val #f) (-mu x (Un N Sym (make-Listof x)))) - (-mu x (Un N Sym B (make-Listof x)))] + [(Un -Number) -Number] + [(Un -Number -Number) -Number] + [(Un -Number -Symbol) (Un -Symbol -Number)] + [(Un (-val 6) (-val 7)) -Number] + [(Un (-val #f) (Un (-val 6) (-val 7))) (Un -Number (Un -Boolean -Symbol))] + [(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un -Number (Un -Boolean -Symbol)))] + [(Un -Number (-val #f) (-mu x (Un -Number -Symbol (make-Listof x)))) + (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))] ;; sexps vs list*s of nums - [(-mu x (Un N Sym (make-Listof x))) (-mu x (Un N Sym B (make-Listof x)))] - [(-mu x (Un N (make-Listof x))) (-mu x (Un N Sym (make-Listof x)))] - [(-mu x (Un N (make-Listof x))) (-mu y (Un N Sym (make-Listof y)))] + [(-mu x (Un -Number -Symbol (make-Listof x))) (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))] + [(-mu x (Un -Number (make-Listof x))) (-mu x (Un -Number -Symbol (make-Listof x)))] + [(-mu x (Un -Number (make-Listof x))) (-mu y (Un -Number -Symbol (make-Listof y)))] ;; a hard one - [(-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null)))))) -Sexp] + [(-mu x (*Un -Number (-pair x (-pair -Symbol (-pair x (-val null)))))) -Sexp] ;; simple function types - ((Univ . -> . N) (N . -> . Univ)) - [(Univ Univ Univ . -> . N) (Univ Univ N . -> . N)] + ((Univ . -> . -Number) (-Number . -> . Univ)) + [(Univ Univ Univ . -> . -Number) (Univ Univ -Number . -> . -Number)] ;; simple list types - [(make-Listof N) (make-Listof Univ)] - [(make-Listof N) (make-Listof N)] - [FAIL (make-Listof N) (make-Listof Sym)] + [(make-Listof -Number) (make-Listof Univ)] + [(make-Listof -Number) (make-Listof -Number)] + [FAIL (make-Listof -Number) (make-Listof -Symbol)] [(-mu x (make-Listof x)) (-mu x* (make-Listof x*))] - [(-pair N N) (-pair Univ N)] - [(-pair N N) (-pair N N)] + [(-pair -Number -Number) (-pair Univ -Number)] + [(-pair -Number -Number) (-pair -Number -Number)] ;; from page 7 [(-mu t (-> t t)) (-mu s (-> s s))] - [(-mu s (-> N s)) (-mu t (-> N (-> N t)))] + [(-mu s (-> -Number s)) (-mu t (-> -Number (-> -Number t)))] ;; polymorphic types [(-poly (t) (-> t t)) (-poly (s) (-> s s))] - [FAIL (make-Listof N) (-poly (t) (make-Listof t))] - [(-poly (a) (make-Listof (-v a))) (make-Listof N)] ;; - [(-poly (a) N) N] + [FAIL (make-Listof -Number) (-poly (t) (make-Listof t))] + [(-poly (a) (make-Listof (-v a))) (make-Listof -Number)] ;; + [(-poly (a) -Number) -Number] - [(-val 6) N] - [(-val 'hello) Sym] - [((Un Sym N) . -> . N) (-> N N)] - [(-poly (t) (-> N t)) (-mu t (-> N t))] + [(-val 6) -Number] + [(-val 'hello) -Symbol] + [((Un -Symbol -Number) . -> . -Number) (-> -Number -Number)] + [(-poly (t) (-> -Number t)) (-mu t (-> -Number t))] ;; not subtypes - [FAIL (-val 'hello) N] - [FAIL (-val #f) Sym] - [FAIL (Univ Univ N N . -> . N) (Univ Univ Univ . -> . N)] - [FAIL (N . -> . N) (-> Univ Univ)] - [FAIL (Un N Sym) N] - [FAIL N (Un (-val 6) (-val 11))] - [FAIL Sym (-val 'Sym)] - [FAIL (Un Sym N) (-poly (a) N)] + [FAIL (-val 'hello) -Number] + [FAIL (-val #f) -Symbol] + [FAIL (Univ Univ -Number -Number . -> . -Number) (Univ Univ Univ . -> . -Number)] + [FAIL (-Number . -> . -Number) (-> Univ Univ)] + [FAIL (Un -Number -Symbol) -Number] + [FAIL -Number (Un (-val 6) (-val 11))] + [FAIL -Symbol (-val 'Sym)] + [FAIL (Un -Symbol -Number) (-poly (a) -Number)] ;; bugs found [(Un (-val 'foo) (-val 6)) (Un (-val 'foo) (-val 6))] - [(-poly (a) (make-Listof (-v a))) (make-Listof (-mu x (Un (make-Listof x) N)))] - [FAIL (make-Listof (-mu x (Un (make-Listof x) N))) (-poly (a) (make-Listof a))] + [(-poly (a) (make-Listof (-v a))) (make-Listof (-mu x (Un (make-Listof x) -Number)))] + [FAIL (make-Listof (-mu x (Un (make-Listof x) -Number))) (-poly (a) (make-Listof a))] ;; case-lambda - [(cl-> [(N) N] [(B) B]) (N . -> . N)] + [(cl-> [(-Number) -Number] [(-Boolean) -Boolean]) (-Number . -> . -Number)] ;; special case for unused variables - [N (-poly (a) N)] - [FAIL (cl-> [(N) B] [(B) N]) (N . -> . N)] + [-Number (-poly (a) -Number)] + [FAIL (cl-> [(-Number) -Boolean] [(-Boolean) -Number]) (-Number . -> . -Number)] ;; varargs - [(->* (list N) Univ B) (->* (list N) N B)] - [(->* (list Univ) N B) (->* (list N) N B)] - [(->* (list N) N B) (->* (list N) N B)] - [(->* (list N) N B) (->* (list N) N Univ)] - [(->* (list N) N N) (->* (list N N) N)] - [(->* (list N) N N) (->* (list N N N) N)] - [(->* (list N N) B N) (->* (list N N) N)] - [FAIL (->* (list N) N B) (->* (list N N N) N)] - [(->* (list N N) B N) (->* (list N N B B) N)] + [(->* (list -Number) Univ -Boolean) (->* (list -Number) -Number -Boolean)] + [(->* (list Univ) -Number -Boolean) (->* (list -Number) -Number -Boolean)] + [(->* (list -Number) -Number -Boolean) (->* (list -Number) -Number -Boolean)] + [(->* (list -Number) -Number -Boolean) (->* (list -Number) -Number Univ)] + [(->* (list -Number) -Number -Number) (->* (list -Number -Number) -Number)] + [(->* (list -Number) -Number -Number) (->* (list -Number -Number -Number) -Number)] + [(->* (list -Number -Number) -Boolean -Number) (->* (list -Number -Number) -Number)] + [FAIL (->* (list -Number) -Number -Boolean) (->* (list -Number -Number -Number) -Number)] + [(->* (list -Number -Number) -Boolean -Number) (->* (list -Number -Number -Boolean -Boolean) -Number)] [(-poly (a) (cl-> [() a] - [(N) a])) - (cl-> [() (-pair N (-v b))] - [(N) (-pair N (-v b))])] + [(-Number) a])) + (cl-> [() (-pair -Number (-v b))] + [(-Number) (-pair -Number (-v b))])] - [(-values (list N)) (-values (list Univ))] + [(-values (list -Number)) (-values (list Univ))] - [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list N a))) . -> . (-lst a))) - ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list N (-pair N (-v a))))) . -> . (-lst (-pair N (-v a))))] - [(-poly (a) ((-struct 'bar #f (list N a)) . -> . (-lst a))) - ((-struct 'bar #f (list N (-pair N (-v a)))) . -> . (-lst (-pair N (-v a))))] + [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a))) . -> . (-lst a))) + ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))))) . -> . (-lst (-pair -Number (-v a))))] + [(-poly (a) ((-struct 'bar #f (list -Number a)) . -> . (-lst a))) + ((-struct 'bar #f (list -Number (-pair -Number (-v a)))) . -> . (-lst (-pair -Number (-v a))))] [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))] - [(-poly (a) (a . -> . (make-Listof a))) ((-pair N (-v b)) . -> . (make-Listof (-pair N (-v b))))] + [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))] (FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b))) From 0ddf7338cbc9c3d01c8a24820a04cac82deed6b7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 20:11:09 +0000 Subject: [PATCH 098/156] sync to trunk svn: r14750 --- collects/framework/preferences.ss | 226 +- collects/lang/private/todo.ss | 280 ++ collects/mzlib/port.ss | 3500 ++++++++--------- collects/redex/private/reduction-semantics.ss | 312 +- collects/redex/private/rg-test.ss | 16 + collects/redex/private/tl-test.ss | 11 + collects/schemeunit/test-suite-test.ss | 29 + collects/schemeunit/test-suite.ss | 35 +- collects/schemeunit/test-test.ss | 8 + collects/schemeunit/test.ss | 4 +- collects/scribblings/foreign/libs.scrbl | 21 +- collects/scribblings/reference/class.scrbl | 3 +- collects/sgl/gl.ss | 4 +- collects/tests/mzscheme/optimize.ss | 30 + collects/web-server/lang/lang-api.ss | 2 + .../web-server/scribblings/cache-table.scrbl | 2 +- .../scribblings/connection-manager.scrbl | 2 +- .../web-server/scribblings/contracts.scrbl | 2 +- .../scribblings/ctable-structs.scrbl | 2 +- collects/web-server/scribblings/ctable.scrbl | 2 +- .../web-server/scribblings/dispatchers.scrbl | 4 +- .../web-server/scribblings/file-box.scrbl | 2 +- .../web-server/scribblings/lang-api.scrbl | 1 + .../web-server/scribblings/managers.scrbl | 8 +- .../web-server/scribblings/mime-types.scrbl | 2 +- collects/web-server/scribblings/mod-map.scrbl | 2 +- .../web-server/scribblings/namespace.scrbl | 6 +- .../web-server/scribblings/responders.scrbl | 2 +- .../scribblings/stateless-usage.scrbl | 14 +- collects/web-server/scribblings/timer.scrbl | 2 +- .../web-server/scribblings/url-param.scrbl | 2 +- collects/web-server/scribblings/util.scrbl | 2 +- .../web-server/scribblings/web-param.scrbl | 2 +- 33 files changed, 2407 insertions(+), 2133 deletions(-) create mode 100644 collects/lang/private/todo.ss diff --git a/collects/framework/preferences.ss b/collects/framework/preferences.ss index 22a4e13cd2..1d882bfbde 100644 --- a/collects/framework/preferences.ss +++ b/collects/framework/preferences.ss @@ -38,12 +38,8 @@ the state transitions / contracts are: (define exn:make-unknown-preference make-exn:unknown-preference) (define exn:struct:unknown-preference struct:exn:unknown-preference) -(define old-preferences-symbol 'plt:framework-prefs) -(define old-preferences (make-hasheq)) -(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))]) - (for-each - (λ (line) (hash-set! old-preferences (car line) (cadr line))) - old-prefs)) +(define preferences:low-level-put-preferences (make-parameter put-preferences)) +(define preferences:low-level-get-preference (make-parameter get-preference)) (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p))) @@ -51,12 +47,6 @@ the state transitions / contracts are: ;; the current values of the preferences (define preferences (make-hasheq)) -;; marshalled : hash-table[sym -o> any] -;; the values of the preferences, as read in from the disk -;; each symbol will only be mapped in one of the preferences -;; hash-table and this hash-table, but not both. -(define marshalled (make-hasheq)) - ;; marshall-unmarshall : sym -o> un/marshall (define marshall-unmarshall (make-hasheq)) @@ -67,11 +57,11 @@ the state transitions / contracts are: (define defaults (make-hasheq)) ;; these four functions determine the state of a preference -(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref)) -(define (pref-default-set? pref) (hash-table-bound? defaults pref)) -(define (pref-can-init? pref) +(define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref)) +(define (pref-default-set? pref) (hash-has-key? defaults pref)) +(define (pref-can-init? pref) (and (not snapshot-grabbed?) - (not (hash-table-bound? preferences pref)))) + (not (hash-has-key? preferences pref)))) ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any)) (define-struct un/marshall (marshall unmarshall)) @@ -86,35 +76,32 @@ the state transitions / contracts are: ;; this is used as a wrapped to deal with the problem that different procedures might be eq?. (define-struct pref-callback (cb)) +;; used to detect missing hash entries +(define none (gensym 'none)) + ;; get : symbol -> any ;; return the current value of the preference `p' ;; exported (define (preferences:get p) + (define v (hash-ref preferences p none)) (cond + ;; if this is found, we can just return it immediately + [(not (eq? v none)) + v] + ;; first time reading this, check the file & unmarshall value, if + ;; it's not there, use the default [(pref-default-set? p) - - ;; unmarshall, if required - (when (hash-table-bound? marshalled p) - ;; if `preferences' is already bound, that means the unmarshalled value isn't useful. - (unless (hash-table-bound? preferences p) - (hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p)))) - (hash-remove! marshalled p)) - - ;; if there is no value in the preferences table, but there is one - ;; in the old version preferences file, take that: - (unless (hash-table-bound? preferences p) - (when (hash-table-bound? old-preferences p) - (hash-set! preferences p (unmarshall-pref p (hash-ref old-preferences p))))) - - ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore) - (when (hash-table-bound? old-preferences p) - (hash-remove! old-preferences p)) - - ;; if it still isn't set, take the default value - (unless (hash-table-bound? preferences p) - (hash-set! preferences p (default-value (hash-ref defaults p)))) - - (hash-ref preferences p)] + (let* (;; try to read the preferece from the preferences file + [v ((preferences:low-level-get-preference) + (add-pref-prefix p) (λ () none))] + [v (if (eq? v none) + ;; no value read, take the default value + (default-value (hash-ref defaults p)) + ;; found a saved value, unmarshall it + (unmarshall-pref p v))]) + ;; set the value for future reference and return it + (hash-set! preferences p v) + v)] [(not (pref-default-set? p)) (raise-unknown-preference-error 'preferences:get @@ -155,8 +142,6 @@ the state transitions / contracts are: values)) (void)) -(define preferences:low-level-put-preferences (make-parameter put-preferences)) - (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference (string-append (format "~a: " sym) (apply format fmt args)) @@ -229,11 +214,6 @@ the state transitions / contracts are: [(not (pref-can-init? p)) (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])) -(define (hash-table-bound? ht s) - (let/ec k - (hash-ref ht s (λ () (k #f))) - #t)) - (define (preferences:restore-defaults) (hash-for-each defaults @@ -248,12 +228,7 @@ the state transitions / contracts are: (unless default-okay? (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker default-okay? default-value)) - (hash-set! defaults p (make-default default-value checker)) - (let/ec k - (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))]) - ;; if there is no preference saved, we just don't do anything. - ;; `get' notices this case. - (hash-set! marshalled p m))))] + (hash-set! defaults p (make-default default-value checker)))] [(not (pref-can-init? p)) (error 'preferences:set-default "tried to call set-default for preference ~e but it cannot be configured any more" @@ -355,83 +330,77 @@ the state transitions / contracts are: ((p f) ((weak? #f))) @{This function adds a callback which is called with a symbol naming a - preference and its value, when the preference changes. - @scheme[preferences:add-callback] returns a thunk, which when - invoked, removes the callback from this preference. - - If @scheme[weak?] is true, the preferences system will only hold on to - the callback weakly. - - The callbacks will be called in the order in which they were added. - - If you are adding a callback for a preference that requires - marshalling and unmarshalling, you must set the marshalling and - unmarshalling functions by calling - @scheme[preferences:set-un/marshall] before adding a callback. - - This function raises - @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]} - @scheme[exn:unknown-preference] - if the preference has not been set.}) + preference and its value, when the preference changes. + @scheme[preferences:add-callback] returns a thunk, which when + invoked, removes the callback from this preference. + + If @scheme[weak?] is true, the preferences system will only hold on to + the callback weakly. + + The callbacks will be called in the order in which they were added. + + If you are adding a callback for a preference that requires + marshalling and unmarshalling, you must set the marshalling and + unmarshalling functions by calling + @scheme[preferences:set-un/marshall] before adding a callback. + + This function raises + @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]} + @scheme[exn:unknown-preference] + if the preference has not been set.}) (proc-doc/names preferences:set-default (symbol? any/c (any/c . -> . any) . -> . void?) (symbol value test) - @{This function must be called every time your application starts up, before any call to - @scheme[preferences:get] or - @scheme[preferences:set] - (for any given preference). - - If you use - @scheme[preferences:set-un/marshall], - you must call this function before calling it. - - This sets the default value of the preference @scheme[symbol] to - @scheme[value]. If the user has chosen a different setting, - the user's setting - will take precedence over the default value. - - The last argument, @scheme[test] is used as a safeguard. That function is - called to determine if a preference read in from a file is a valid - preference. If @scheme[test] returns @scheme[#t], then the preference is - treated as valid. If @scheme[test] returns @scheme[#f] then the default is - used.}) + @{This function must be called every time your application starts up, before + any call to @scheme[preferences:get] or @scheme[preferences:set] + (for any given preference). + + If you use @scheme[preferences:set-un/marshall], + you must call this function before calling it. + + This sets the default value of the preference @scheme[symbol] to + @scheme[value]. If the user has chosen a different setting, + the user's setting will take precedence over the default value. + + The last argument, @scheme[test] is used as a safeguard. That function is + called to determine if a preference read in from a file is a valid + preference. If @scheme[test] returns @scheme[#t], then the preference is + treated as valid. If @scheme[test] returns @scheme[#f] then the default is + used.}) (proc-doc/names preferences:set-un/marshall (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?) (symbol marshall unmarshall) @{@scheme[preference:set-un/marshall] is used to specify marshalling and - unmarshalling functions for the preference - @scheme[symbol]. @scheme[marshall] will be called when the users saves their - preferences to turn the preference value for @scheme[symbol] into a - printable value. @scheme[unmarshall] will be called when the user's - preferences are read from the file to transform the printable value - into its internal representation. If @scheme[preference:set-un/marshall] - is never called for a particular preference, the values of that - preference are assumed to be printable. - - If the unmarshalling function returns a value that does not meet the - guard passed to - @scheme[preferences:set-default] - for this preference, the default value is used. - - The @scheme[marshall] function might be called with any value returned - from @scheme[read] and it must not raise an error - (although it can return arbitrary results if it gets bad input). This might - happen when the preferences file becomes corrupted, or is edited - by hand. - - @scheme[preference:set-un/marshall] must be called before calling - @scheme[preferences:get], - @scheme[preferences:set].}) + unmarshalling functions for the preference + @scheme[symbol]. @scheme[marshall] will be called when the users saves their + preferences to turn the preference value for @scheme[symbol] into a + printable value. @scheme[unmarshall] will be called when the user's + preferences are read from the file to transform the printable value + into its internal representation. If @scheme[preference:set-un/marshall] + is never called for a particular preference, the values of that + preference are assumed to be printable. + + If the unmarshalling function returns a value that does not meet the + guard passed to @scheme[preferences:set-default] + for this preference, the default value is used. + + The @scheme[marshall] function might be called with any value returned + from @scheme[read] and it must not raise an error + (although it can return arbitrary results if it gets bad input). This might + happen when the preferences file becomes corrupted, or is edited + by hand. + + @scheme[preference:set-un/marshall] must be called before calling + @scheme[preferences:get],@scheme[preferences:set].}) (proc-doc/names preferences:restore-defaults (-> void?) () - @{@scheme[(preferences:restore-defaults)] - restores the users's configuration to the - default preferences.}) + @{@scheme[(preferences:restore-defaults)] restores the users' configuration + to the default preferences.}) (proc-doc/names exn:make-unknown-preference @@ -447,28 +416,33 @@ the state transitions / contracts are: (parameter-doc preferences:low-level-put-preferences - (parameter/c (-> (listof symbol?) (listof any/c) any)) - put-preference - @{This parameter's value - is called to save preference the preferences. Its interface should - be just like mzlib's @scheme[put-preference].}) + (parameter/c ((listof symbol?) (listof any/c) . -> . any)) + put-preferences + @{This parameter's value is called to save preference the preferences file. + Its interface should be just like mzlib's @scheme[put-preferences].}) + + (parameter-doc + preferences:low-level-get-preference + (parameter/c (->* [symbol?] [(-> any)] any)) + get-preference + @{This parameter's value is called to get a preference from the preferences + file. Its interface should be just like mzlib's @scheme[get-preference].}) (proc-doc/names preferences:snapshot? (-> any/c boolean?) (arg) @{Determines if its argument is a preferences snapshot. - - See also - @scheme[preferences:get-prefs-snapshot] and - @scheme[preferences:restore-prefs-snapshot].}) + + See also @scheme[preferences:get-prefs-snapshot] and + @scheme[preferences:restore-prefs-snapshot].}) (proc-doc/names preferences:restore-prefs-snapshot (-> preferences:snapshot? void?) (snapshot) @{Restores the preferences saved in @scheme[snapshot]. - - See also @scheme[preferences:get-prefs-snapshot].}) + + See also @scheme[preferences:get-prefs-snapshot].}) (proc-doc/names preferences:get-prefs-snapshot diff --git a/collects/lang/private/todo.ss b/collects/lang/private/todo.ss new file mode 100644 index 0000000000..1eda9fb48b --- /dev/null +++ b/collects/lang/private/todo.ss @@ -0,0 +1,280 @@ +#lang scheme + +;; If we eliminate char from HtDP/I, we need to add re-think +;; the following functions. Concrete proposals attached. + +;; If you're in a hurry, look for QQQ. + +#| QQQ: okay? +char-upcase: use string-upcase instead +char-downcase: use string-downcase instead +string: use string-append instead +|# + +#| QQQ: I noticed an oddity: +substring consumes 2 or 3 arguments +|# + +;; ----------------------------------------------------------------------------- +;; auxiliary stuff, ignore +(require test-engine/scheme-tests) + +(define 1-letter "1-letter string") +(define 1-letter* (format "~as" 1-letter)) + +;; Symbol Any -> Boolean +;; is this a 1-letter string? +(define (1-letter? tag s) + (unless (string? s) + (error tag "~a expected, not a string: ~e" 1-letter s)) + (= (string-length s) 1)) + + +;; Symbol Any -> Boolean +;; is s a list of 1-letter strings +;; effect: not a list, not a list of strings +(define (1-letter*? tag s) + (unless (list? s) + (error tag "list of ~a expected, not a list: ~e" 1-letter* s)) + (for-each + (lambda (c) + (unless (string? c) + (error tag "list of ~a expected, not a string: ~e" 1-letter* c))) + s) + #; (lambda (s) (= 1 (string-length s))) + (andmap (compose (curry = 1) string-length) s)) + +(define-syntax (define-teach stx) + (syntax-case stx () + [(_ level id expr) + (with-syntax ([level-id (datum->syntax + (syntax id) + (string->symbol + (format "~a-~a" + (syntax->datum (syntax level)) + (syntax->datum (syntax id)))) + (syntax id))]) + (syntax (define level-id + (let ([id expr]) + id))))])) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-string-ith "hell" 0) "h") +(check-error + (beginner-string-ith "hell" 4) + (string-append + "string-ith:" + " second argument must be between 0 and the length of the given string (4), given " + "4")) + +(define-teach beginner string-ith + (lambda (s n) + (unless (string? s) + (error 'string-ith "first argument must be of type , given ~e" s)) + (unless (and (number? n) (integer? n) (>= n 0)) + (error 'string-ith + "second argument must be of type , given ~e" + n)) + (unless (< n (string-length s)) + (error 'string-ith + "second argument must be between 0 and the length of the given string (~s), given ~a" + (string-length s) n)) + (string (string-ref s n)))) + +;; ----------------------------------------------------------------------------- +;; QQQ: this would be a re-definition of a Scheme function. Should we rename? + +(check-expect (beginner-make-string 3 "a") "aaa") +(check-error + (beginner-make-string 3 "ab") + (string-append "make-string: " 1-letter " expected, given " + (format "~s" "ab"))) + +(define-teach beginner make-string + (lambda (n s1) + (unless (and (number? n) (exact-integer? n) (>= n 0)) + (error 'make-string "(exact) natural number expected, given ~e" n)) + (unless (1-letter? 'make-string s1) + (error 'make-string "~a expected, given ~e" 1-letter s1)) + (apply string-append (build-list n (lambda (i) s1))))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-int->string 10) "\n") +(check-error + (beginner-int->string 56555) + (string-append + "int->string: exact integer in [0,55295] or [57344 1114111] expected, given " + "56555")) +(check-error + (beginner-int->string "A") + (string-append + "int->string: exact integer in [0,55295] or [57344 1114111] expected, given " + "A")) + +(define-teach beginner int->string + (lambda (i) + (unless (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111))) + (error 'int->string + "exact integer in [0,55295] or [57344 1114111] expected, given ~a" + i)) + (string (integer->char i)))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-string->int "A") 65) +(check-error + (beginner-string->int 10) + (string-append + "string->int: " 1-letter " expected, not a string: " + "10")) +(check-error + (beginner-string->int "AB") + (string-append + "string->int: " 1-letter " expected, given " + (format "~s" "AB"))) + +(define-teach beginner string->int + (lambda (s) + (unless (1-letter? 'string->int s) + (error 'string->int "~a expected, given ~e" 1-letter s)) + (char->integer (string-ref s 0)))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-explode "hello") (list "h" "e" "l" "l" "o")) +(check-error + (beginner-explode 10) + (string-append + "explode: string expected, given " + "10")) + +(define-teach beginner explode + (lambda (s) + (unless (string? s) + (error 'explode "string expected, given ~e" s)) + (map string (string->list s)))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-implode (list "h" "e" "l" "l" "o")) "hello") +(check-error + (beginner-implode 10) + (string-append + "implode: list of " 1-letter* " expected, not a list: " + "10")) +(check-error + (beginner-implode '("he" "l")) + (string-append + "implode: list of " 1-letter* " expected, given " + (format "~s" '("he" "l")))) + +(define-teach beginner implode + (lambda (los) + (unless (1-letter*? 'implode los) + (error 'implode "list of ~a expected, given ~e" 1-letter* los)) + (list->string (map (lambda (s) (string-ref s 0)) los)))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-string1-numeric? "0") true) +(check-expect (beginner-string1-numeric? "a") false) +(check-error + (beginner-string1-numeric? "ab") + (string-append "string1-numeric?: " 1-letter " expected, given " + (format "~s" "ab"))) + +(define-teach beginner string1-numeric? + ;; is this: (number? (string->number s)) enough? + (lambda (s1) + (unless (1-letter? 'string1-numeric? s1) + (error 'string1-numeric? "~a expected, given ~e" 1-letter s1)) + (char-numeric? (string-ref s1 0)))) + +;; ----------------------------------------------------------------------------- + +;; I used copying here and I feel awful. +(check-expect (beginner-string1-alphabetic? "0") false) +(check-expect (beginner-string1-alphabetic? "a") true) +(check-error + (beginner-string1-alphabetic? "ab") + (string-append "string1-alphabetic?: " 1-letter " expected, given " + (format "~s" "ab"))) + +(define-teach beginner string1-alphabetic? + ;; is this + #; + (andmap (lambda (c) + (or (string<=? "A" x "Z") (string<=? "a" x "z"))) + (string->list s)) + ;; enough? + (lambda (s1) + (unless (1-letter? 'string1-alphabetic? s1) + (error 'string1-alphabetic? "~a expected, given ~e" 1-letter s1)) + (char-alphabetic? (string-ref s1 0)))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-string-whitespace? " ") true) +(check-expect (beginner-string-whitespace? " \t") true) +(check-expect (beginner-string-whitespace? "ABC") false) + +(define-teach beginner string-whitespace? + (lambda (s) + (unless (string? s) + (error 'string-upper-case? "string expected, given ~e" s)) + (andmap char-whitespace? (string->list s)))) + +;; ----------------------------------------------------------------------------- +;; I copied the next two, and I feel awful, too. +(check-expect (beginner-string-upper-case? " ") false) +(check-expect (beginner-string-upper-case? "AB\t") false) +(check-expect (beginner-string-upper-case? "ABC") true) + +(define-teach beginner string-upper-case? + (lambda (s) + (unless (string? s) + (error 'string-upper-case? "string expected, given ~e" s)) + (andmap char-upper-case? (string->list s)))) + +;; ----------------------------------------------------------------------------- + +(check-expect (beginner-string-lower-case? " ") false) +(check-expect (beginner-string-lower-case? "ab\t") false) +(check-expect (beginner-string-lower-case? "abc") true) + +(define-teach beginner string-lower-case? + (lambda (s) + (unless (string? s) + (error 'string-lower-case? "string expected, given ~e" s)) + (andmap char-lower-case? (string->list s)))) + +;; ----------------------------------------------------------------------------- + +;; !!! redefinition !!! (and copy from teachprims.ss) +;; QQQ: do we need a new name???? +(check-expect (intermediate-build-string 3 (lambda (x) "x")) "xxx") + +(define-teach intermediate build-string + (lambda (n f) + (unless (and (number? n) (integer? n) (>= n 0)) + (error 'build-string + "first argument must be of type , given ~e" + n)) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (error 'build-string + "second argument must be a that accepts one argument, given ~e" + f)) + (apply string-append + (build-list + n + (lambda (i) + (define r (f i)) + (unless (1-letter? 'build-string r) + (error 'build-string + "second argument must be a that produces a ~a, given ~e, which produced ~e for ~e" + 1-letter f r i)) + r))))) + +(test) \ No newline at end of file diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index f3a165787e..3d7c1102c8 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -1,1298 +1,1193 @@ +#lang scheme/base -(module port mzscheme - (require mzlib/etc - mzlib/contract - mzlib/list - "private/port.ss") +(require (for-syntax scheme/base) + mzlib/etc + scheme/contract + mzlib/list + "private/port.ss") - (define (input-port-with-progress-evts? ip) - (and (input-port? ip) - (port-provides-progress-evts? ip))) +(define (input-port-with-progress-evts? ip) + (and (input-port? ip) + (port-provides-progress-evts? ip))) - (define (mutable-bytes? b) - (and (bytes? b) (not (immutable? b)))) - (define (mutable-string? b) - (and (string? b) (not (immutable? b)))) +(define (mutable-bytes? b) + (and (bytes? b) (not (immutable? b)))) +(define (mutable-string? b) + (and (string? b) (not (immutable? b)))) - (define (line-mode-symbol? s) - (memq s '(linefeed return return-linefeed any any-one))) +(define (line-mode-symbol? s) + (memq s '(linefeed return return-linefeed any any-one))) - (define (evt?/false v) - (or (eq? #f v) (evt? v))) - - ;; ---------------------------------------- +(define (evt?/false v) + (or (eq? #f v) (evt? v))) - (define (strip-shell-command-start in) - (when (regexp-match-peek #rx#"^#![^\r\n]*" in) - (let loop ([s (read-line in)]) - (when (regexp-match #rx#"\\\\$" s) - (loop (read-line in)))))) +;; ---------------------------------------- - ;; ---------------------------------------- +(define (strip-shell-command-start in) + (when (regexp-match-peek #rx#"^#![^\r\n]*" in) + (let loop ([s (read-line in)]) + (when (regexp-match #rx#"\\\\$" s) + (loop (read-line in)))))) - (define (copy-port src dest . dests) - (unless (input-port? src) - (raise-type-error 'copy-port "input-port" src)) - (for-each - (lambda (dest) - (unless (output-port? dest) - (raise-type-error 'copy-port "output-port" dest))) - (cons dest dests)) - (let ([s (make-bytes 4096)] - [dests (cons dest dests)]) - (let loop () - (let ([c (read-bytes-avail! s src)]) - (cond - [(number? c) - (let loop ([dests dests]) - (unless (null? dests) - (let loop ([start 0]) - (unless (= start c) - (let ([c2 (write-bytes-avail s (car dests) start c)]) - (loop (+ start c2))))) - (loop (cdr dests)))) - (loop)] - [(procedure? c) - (let ([v (let-values ([(l col p) (port-next-location src)]) - (c (object-name src) l col p))]) - (let loop ([dests dests]) - (unless (null? dests) - (write-special v (car dests)) - (loop (cdr dests))))) - (loop)] - [else - ;; Must be EOF - (void)]))))) - - (define merge-input - (case-lambda - [(a b) (merge-input a b 4096)] - [(a b limit) - (or (input-port? a) - (raise-type-error 'merge-input "input-port" a)) - (or (input-port? b) - (raise-type-error 'merge-input "input-port" b)) - (or (not limit) - (and (number? limit) (positive? limit) (exact? limit) (integer? limit)) - (raise-type-error 'merge-input "positive exact integer or #f" limit)) - (let-values ([(rd wt) (make-pipe-with-specials limit)] - [(other-done?) #f] - [(sema) (make-semaphore 1)]) - (let ([copy - (lambda (from) - (thread - (lambda () - (copy-port from wt) - (semaphore-wait sema) - (if other-done? - (close-output-port wt) - (set! other-done? #t)) - (semaphore-post sema))))]) - (copy a) - (copy b) - rd))])) +;; ---------------------------------------- - ;; `make-input-port/read-to-peek' sometimes needs to wrap a special-value - ;; procedure so that it's only called once when the value is both - ;; peeked and read. - (define-values (struct:memoized make-memoized memoized? memoized-ref memoized-set!) - (make-struct-type 'memoized #f 1 0 #f null (current-inspector) 0)) - (define (memoize p) - (define result #f) - (make-memoized - (if (procedure-arity-includes? p 0) - ;; original p accepts 0 or 4 arguments: - (case-lambda - [() (unless result (set! result (box (p)))) (unbox result)] - [(src line col pos) - (unless result (set! result (box (p src line col pos)))) - (unbox result)]) - ;; original p accepts only 4 arguments: - (lambda (src line col pos) - (unless result (set! result (box (p src line col pos)))) - (unbox result))))) +(define (copy-port src dest . dests) + (unless (input-port? src) + (raise-type-error 'copy-port "input-port" src)) + (for-each + (lambda (dest) + (unless (output-port? dest) + (raise-type-error 'copy-port "output-port" dest))) + (cons dest dests)) + (let ([s (make-bytes 4096)] + [dests (cons dest dests)]) + (let loop () + (let ([c (read-bytes-avail! s src)]) + (cond + [(number? c) + (let loop ([dests dests]) + (unless (null? dests) + (let loop ([start 0]) + (unless (= start c) + (let ([c2 (write-bytes-avail s (car dests) start c)]) + (loop (+ start c2))))) + (loop (cdr dests)))) + (loop)] + [(procedure? c) + (let ([v (let-values ([(l col p) (port-next-location src)]) + (c (object-name src) l col p))]) + (let loop ([dests dests]) + (unless (null? dests) + (write-special v (car dests)) + (loop (cdr dests))))) + (loop)] + [else + ;; Must be EOF + (void)]))))) - ;; Not kill-safe. - ;; If the `read' proc returns an event, the event must produce - ;; 0 always (which implies that the `read' proc must not return - ;; a pipe input port). - (define make-input-port/read-to-peek - (opt-lambda (name read fast-peek close - [location-proc #f] - [count-lines!-proc void] - [init-position 1] - [buffer-mode-proc #f] - [buffering? #f] - [on-consumed #f]) - (define lock-semaphore (make-semaphore 1)) - (define commit-semaphore (make-semaphore 1)) - (define-values (peeked-r peeked-w) (make-pipe)) - (define special-peeked null) - (define special-peeked-tail #f) - (define progress-requested? #f) - (define use-manager? #f) - (define manager-th #f) - (define manager-ch (make-channel)) - (define resume-ch (make-channel)) - (define buf (make-bytes 4096)) - (define (try-again) - (wrap-evt - (semaphore-peek-evt lock-semaphore) - (lambda (x) 0))) - (define (suspend-manager) - (channel-put manager-ch 'suspend)) - (define (resume-manager) - (channel-put resume-ch 'resume)) - (define (with-manager-lock thunk) - (thread-resume manager-th (current-thread)) - (dynamic-wind suspend-manager thunk resume-manager)) - (define (make-progress) - ;; We dont worry about this byte getting picked up directly - ;; from peeked-r, because the pipe must have been empty when - ;; we grabed the lock, and since we've grabbed the lock, - ;; no other thread could have re-returned the pipe behind - ;; our back. - (write-byte 0 peeked-w) - (read-byte peeked-r)) - (define (consume-from-peeked s) - (let ([n (read-bytes-avail!* s peeked-r)]) - (when on-consumed - (on-consumed n)) - n)) - (define (read-it-with-lock s) - (if use-manager? - (with-manager-lock (lambda () (do-read-it s))) - (do-read-it s))) - (define (read-it s) - (call-with-semaphore - lock-semaphore - read-it-with-lock - try-again - s)) - (define (do-read-it s) - (if (byte-ready? peeked-r) - (if on-consumed - (consume-from-peeked s) - peeked-r) - ;; If nothing is saved from a peeking read, - ;; dispatch to `read', otherwise return - ;; previously peeked data - (cond - [(null? special-peeked) - (when progress-requested? (make-progress)) - (if (and buffering? - ((bytes-length s) . < . 10)) - ;; Buffering is enabled, so read more to move things - ;; along: - (let ([r (read buf)]) - (if (and (number? r) (positive? r)) - (begin - (write-bytes buf peeked-w 0 r) - (if on-consumed - (consume-from-peeked s) - peeked-r)) - (begin - (when on-consumed - (on-consumed r)) - r))) - ;; Just read requested amount: - (let ([v (read s)]) - (when on-consumed - (on-consumed v)) - v))] - [else (if (bytes? (mcar special-peeked)) - (let ([b (mcar special-peeked)]) - (write-bytes b peeked-w) - (set! special-peeked (mcdr special-peeked)) - (when (null? special-peeked) - (set! special-peeked-tail #f)) - (consume-from-peeked s)) - (let ([v (mcar special-peeked)]) - (make-progress) - (set! special-peeked (mcdr special-peeked)) - (when on-consumed - (on-consumed v)) - (when (null? special-peeked) - (set! special-peeked-tail #f)) - v))]))) - (define (peek-it-with-lock s skip unless-evt) - (if use-manager? - (with-manager-lock (lambda () (do-peek-it s skip unless-evt))) - (do-peek-it s skip unless-evt))) - (define (peek-it s skip unless-evt) - (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) - (if (eq? v 0) - (call-with-semaphore - lock-semaphore - peek-it-with-lock - try-again - s skip unless-evt) - v))) - (define (do-peek-it s skip unless-evt) - (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) - (if (eq? v 0) - ;; The peek may have failed because peeked-r is empty, - ;; because unless-evt is ready, or because the skip is - ;; far. Handle nicely the common case where there are no - ;; specials. - (cond - [(and unless-evt (sync/timeout 0 unless-evt)) - #f] - [(null? special-peeked) - ;; Empty special queue, so read through the original proc. - ;; We only only need - ;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w)) - ;; bytes, but if buffering is enabled, read more (up to size of - ;; buf) to help move things along. - (let* ([dest (if buffering? - buf - (make-bytes (- (+ skip (bytes-length s)) - (pipe-content-length peeked-w))))] - [r (read dest)]) - (cond - [(number? r) - ;; The nice case --- reading gave us more bytes - (write-bytes dest peeked-w 0 r) - ;; Now try again - (peek-bytes-avail!* s skip #f peeked-r)] - [(evt? r) - (if unless-evt - ;; Technically, there's a race condition here. - ;; We might choose r (and return 0) even when - ;; unless-evt becomes available first. However, - ;; this race is detectable only by the inside - ;; of `read'. - (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) - r)] - [else - (set! special-peeked (mcons r null)) - (set! special-peeked-tail special-peeked) - ;; Now try again - (do-peek-it s skip unless-evt)]))] - [else - ;; Non-empty special queue, so try to use it - (let* ([avail (pipe-content-length peeked-r)] - [sk (- skip avail)]) - (let loop ([sk sk] - [l special-peeked]) - (cond - [(null? l) - ;; Not enough even in the special queue. - ;; Read once and add it. - (let* ([t (make-bytes (min 4096 (+ sk (bytes-length s))))] - [r (read t)]) - (cond - [(evt? r) - (if unless-evt - ;; See note above - (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) - r)] - [(eq? r 0) - ;; Original read thinks a spin is ok, - ;; so we return 0 to skin, too. - 0] - [else (let ([v (if (number? r) - (subbytes t 0 r) - r)]) - (let ([pr (mcons v null)]) - (set-mcdr! special-peeked-tail pr) - (set! special-peeked-tail pr)) - ;; Got something; now try again - (do-peek-it s skip unless-evt))]))] - [(eof-object? (mcar l)) - ;; No peeking past an EOF - eof] - [(procedure? (mcar l)) - (if (zero? sk) - ;; We should call the procedure only once. Change - ;; (mcar l) to a memoizing function, if it isn't already: - (let ([proc (mcar l)]) - (if (memoized? proc) - proc - (let ([proc (memoize proc)]) - (set-mcar! l proc) - proc))) - ;; Skipping over special... - (loop (sub1 sk) (mcdr l)))] - [(bytes? (mcar l)) - (let ([len (bytes-length (mcar l))]) - (if (sk . < . len) - (let ([n (min (bytes-length s) - (- len sk))]) - (bytes-copy! s 0 (mcar l) sk (+ sk n)) - n) - (loop (- sk len) (mcdr l))))])))]) - v))) - (define (commit-it-with-lock amt unless-evt done-evt) - (if use-manager? - (with-manager-lock (lambda () (do-commit-it amt unless-evt done-evt))) - (do-commit-it amt unless-evt done-evt))) - (define (commit-it amt unless-evt done-evt) - (call-with-semaphore - lock-semaphore - commit-it-with-lock - #f - amt unless-evt done-evt)) - (define (do-commit-it amt unless-evt done-evt) - (if (sync/timeout 0 unless-evt) - #f - (let* ([avail (pipe-content-length peeked-r)] - [p-commit (min avail amt)]) - (let loop ([amt (- amt p-commit)] - [l special-peeked]) - (cond - [(amt . <= . 0) - ;; Enough has been peeked. Do commit... - (actual-commit p-commit l unless-evt done-evt)] - [(null? l) - ;; Requested commit was larger than previous peeks - #f] - [(bytes? (mcar l)) - (let ([bl (bytes-length (mcar l))]) - (if (bl . > . amt) - ;; Split the string - (let ([next (mcons - (subbytes (mcar l) amt) - (mcdr l))]) - (set-mcar! l (subbytes (mcar l) 0 amt)) - (set-mcdr! l next) - (when (eq? l special-peeked-tail) - (set! special-peeked-tail next)) - (loop 0 (mcdr l))) - ;; Consume this string... - (loop (- amt bl) (mcdr l))))] - [else - (loop (sub1 amt) (mcdr l))]))))) - (define (actual-commit p-commit l unless-evt done-evt) - ;; The `finish' proc finally, actually, will commit... - (define (finish) - (unless (zero? p-commit) - (peek-byte peeked-r (sub1 p-commit)) - (port-commit-peeked p-commit unless-evt always-evt peeked-r)) - (set! special-peeked l) - (when (null? special-peeked) - (set! special-peeked-tail #f)) - (when (and progress-requested? (zero? p-commit)) - (make-progress)) - #t) - ;; If we can sync done-evt immediately, then finish. - (if (sync/timeout 0 (wrap-evt done-evt (lambda (x) #t))) - (finish) - ;; We need to wait, so we'll have to release the lock. - ;; Send the work to a manager thread. - (let ([result-ch (make-channel)] - [w/manager? use-manager?]) - (if w/manager? - ;; Resume manager if it was running: - (resume-manager) - ;; Start manager if it wasn't running: - (begin - (set! manager-th (thread manage-commits)) - (set! use-manager? #t) - (thread-resume manager-th (current-thread)))) - ;; Sets use-manager? if the manager wasn't already running: - (channel-put manager-ch (list finish unless-evt done-evt result-ch)) - ;; Release locks: - (semaphore-post lock-semaphore) - (begin0 - ;; Wait for manager to complete commit: - (sync result-ch) - ;; Grab locks again, so they're released - ;; properly on exit: - (semaphore-wait lock-semaphore) - (when w/manager? - (suspend-manager)))))) - (define (manage-commits) - (let loop ([commits null]) - (apply - sync - (handle-evt manager-ch - (lambda (c) - (case c - [(suspend) - (channel-get resume-ch) - (loop commits)] - [else - ;; adding a commit - (loop (cons c commits))]))) - (map (lambda (c) - (define (send-result v) - ;; Create a new thread to send the result asynchronously: - (thread-resume - (thread (lambda () - (channel-put (list-ref c 3) v))) - (current-thread)) - (when (null? (cdr commits)) - (set! use-manager? #f)) - (loop (remq c commits))) - ;; Choose between done and unless: - (if (sync/timeout 0 (list-ref c 1)) - (handle-evt always-evt - (lambda (x) - (send-result #f))) - (choice-evt - (handle-evt (list-ref c 1) - (lambda (x) - ;; unless ready, which means that the commit must fail - (send-result #f))) - (handle-evt (list-ref c 2) - (lambda (x) - ;; done-evt ready, which means that the commit - ;; must succeed. - ;; If we get here, then commits are not - ;; suspended, so we implicitly have the - ;; lock. - ((list-ref c 0)) - (send-result #t)))))) - commits)))) - (make-input-port - name - ;; Read - read-it - ;; Peek - (if fast-peek - (let ([fast-peek-k (lambda (s skip) - (peek-it s skip #f))]) - (lambda (s skip unless-evt) - (if (or unless-evt - (byte-ready? peeked-r) - (mpair? special-peeked)) - (peek-it s skip unless-evt) - (fast-peek s skip fast-peek-k)))) - peek-it) - close - (lambda () - (set! progress-requested? #t) - (port-progress-evt peeked-r)) - commit-it - location-proc - count-lines!-proc - init-position - (and buffer-mode-proc - (case-lambda - [() (buffer-mode-proc)] - [(mode) - (set! buffering? (eq? mode 'block)) - (buffer-mode-proc mode)]))))) +(define merge-input + (case-lambda + [(a b) (merge-input a b 4096)] + [(a b limit) + (or (input-port? a) + (raise-type-error 'merge-input "input-port" a)) + (or (input-port? b) + (raise-type-error 'merge-input "input-port" b)) + (or (not limit) + (and (number? limit) (positive? limit) (exact? limit) (integer? limit)) + (raise-type-error 'merge-input "positive exact integer or #f" limit)) + (let-values ([(rd wt) (make-pipe-with-specials limit)] + [(other-done?) #f] + [(sema) (make-semaphore 1)]) + (let ([copy + (lambda (from) + (thread + (lambda () + (copy-port from wt) + (semaphore-wait sema) + (if other-done? + (close-output-port wt) + (set! other-done? #t)) + (semaphore-post sema))))]) + (copy a) + (copy b) + rd))])) - (define peeking-input-port - (opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) - (make-input-port/read-to-peek - name - (lambda (s) - (let ([r (peek-bytes-avail!* s delta #f orig-in)]) - (set! delta (+ delta (cond - [(number? r) r] - [else 1]))) - (if (eq? r 0) - (handle-evt orig-in (lambda (v) 0)) - r))) - (lambda (s skip default) - (peek-bytes-avail!* s (+ delta skip) #f orig-in)) - void))) +;; `make-input-port/read-to-peek' sometimes needs to wrap a special-value +;; procedure so that it's only called once when the value is both +;; peeked and read. +(define-values (struct:memoized make-memoized memoized? memoized-ref memoized-set!) + (make-struct-type 'memoized #f 1 0 #f null (current-inspector) 0)) +(define (memoize p) + (define result #f) + (make-memoized + (if (procedure-arity-includes? p 0) + ;; original p accepts 0 or 4 arguments: + (case-lambda + [() (unless result (set! result (box (p)))) (unbox result)] + [(src line col pos) + (unless result (set! result (box (p src line col pos)))) + (unbox result)]) + ;; original p accepts only 4 arguments: + (lambda (src line col pos) + (unless result (set! result (box (p src line col pos)))) + (unbox result))))) - (define relocate-input-port - (opt-lambda (p line col pos [close? #t]) - (transplant-to-relocate - transplant-input-port - p line col pos close?))) - - (define transplant-input-port - (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void]) - (make-input-port - (object-name p) - (lambda (s) (let ([v (read-bytes-avail!* s p)]) - (if (eq? v 0) - (wrap-evt p (lambda (x) 0)) - v))) - (lambda (s skip evt) - (let ([v (peek-bytes-avail!* s skip evt p)]) - (if (eq? v 0) - (choice-evt - (wrap-evt p (lambda (x) 0)) - (if evt - (wrap-evt evt (lambda (x) #f)) - never-evt)) - v))) - (lambda () - (when close? - (close-input-port p))) - (and (port-provides-progress-evts? p) - (lambda () - (port-progress-evt p))) - (and (port-provides-progress-evts? p) - (lambda (n evt target-evt) - (port-commit-peeked n evt target-evt p))) - location-proc - count-lines!-proc - pos))) - - ;; Not kill-safe. - (define make-pipe-with-specials - ;; This implementation of pipes is almost CML-style, with a manager thread - ;; to guard access to the pipe content. But we only enable the manager - ;; thread when write evts are active; otherwise, we use a lock semaphore. - ;; (Actually, the lock semaphore has to be used all the time, to guard - ;; the flag indicating whether the manager thread is running.) - (opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) - (let-values ([(r w) (make-pipe limit)] - [(more) null] - [(more-last) #f] - [(more-sema) #f] - [(close-w?) #f] - [(lock-semaphore) (make-semaphore 1)] - [(mgr-th) #f] - [(via-manager?) #f] - [(mgr-ch) (make-channel)]) - (define (flush-more) - (if (null? more) - (begin - (set! more-last #f) - (when close-w? - (close-output-port w))) - (when (bytes? (mcar more)) - (let ([amt (bytes-length (mcar more))]) - (let ([wrote (write-bytes-avail* (mcar more) w)]) - (if (= wrote amt) - (begin - (set! more (mcdr more)) - (flush-more)) - (begin - ;; This means that we let too many bytes - ;; get written while a special was pending. - ;; (The limit is disabled when a special - ;; is in the pipe.) - (set-mcar! more (subbytes (mcar more) wrote)) - ;; By peeking, make room for more: - (peek-byte r (sub1 (min (pipe-content-length w) - (- amt wrote)))) - (flush-more)))))))) - (define (read-one s) - (let ([v (read-bytes-avail!* s r)]) - (if (eq? v 0) - (if more-last - ;; Return a special - (let ([a (mcar more)]) - (set! more (mcdr more)) - (flush-more) - (lambda (file line col ppos) - a)) - ;; Nothing available, yet. - (begin - (unless more-sema - (set! more-sema (make-semaphore))) - (wrap-evt (semaphore-peek-evt more-sema) - (lambda (x) 0)))) - v))) - (define (close-it) - (set! close-w? #t) - (unless more-last - (close-output-port w)) - (when more-sema - (semaphore-post more-sema))) - (define (write-these-bytes str start end) - (begin0 - (if more-last - (let ([p (mcons (subbytes str start end) null)]) - (set-mcdr! more-last p) - (set! more-last p) - (- end start)) - (let ([v (write-bytes-avail* str w start end)]) - (if (zero? v) - (wrap-evt w (lambda (x) #f)) - v))) - (when more-sema - (semaphore-post more-sema) - (set! more-sema #f)))) - (define (write-spec v) - (let ([p (mcons v null)]) - (if more-last - (set-mcdr! more-last p) - (set! more p)) - (set! more-last p) - (when more-sema - (semaphore-post more-sema) - (set! more-sema #f)))) - (define (serve) - ;; A request is - ;; (list sym result-ch nack-evt . v) - ;; where `v' varies for different `sym's - ;; The possible syms are: read, reply, close, - ;; write, write-spec, write-evt, write-spec-evt - (let loop ([reqs null]) - (apply - sync - ;; Listen for a request: - (handle-evt mgr-ch - (lambda (req) - (let ([req - ;; Most requests we handle immediately and - ;; convert to a reply. The manager thread - ;; implicitly has the lock. - (let ([reply (lambda (v) - (list 'reply (cadr req) (caddr req) v))]) - (case (car req) - [(read) - (reply (read-one (cadddr req)))] - [(close) - (reply (close-it))] - [(write) - (reply (apply write-these-bytes (cdddr req)))] - [(write-spec) - (reply (write-spec (cadddr req)))] - [else req]))]) - (loop (cons req reqs))))) - (if (and (null? reqs) - via-manager?) - ;; If we can get the lock before another request - ;; turn off manager mode: - (handle-evt lock-semaphore - (lambda (x) - (set! via-manager? #f) - (semaphore-post lock-semaphore) - (loop null))) - never-evt) - (append - (map (lambda (req) - (case (car req) - [(reply) (handle-evt (channel-put-evt (cadr req) - (cadddr req)) - (lambda (x) - (loop (remq req reqs))))] - [(write-spec-evt) (if close-w? - ;; Report close error: - (handle-evt (channel-put-evt (cadr req) 'closed) - (lambda (x) - (loop (remq req reqs)))) - ;; Try to write special: - (handle-evt (channel-put-evt (cadr req) #t) - (lambda (x) - ;; We sync'd, so now we *must* write - (write-spec (cadddr req)) - (loop (remq req reqs)))))] - [(write-evt) (if close-w? - ;; Report close error: - (handle-evt (channel-put-evt (cadr req) 'closed) - (lambda (x) - (loop (remq req reqs)))) - ;; Try to write bytes: - (let* ([start (list-ref req 4)] - [end (list-ref req 5)] - [len (if more-last - (- end start) - (min (- end start) - (max 0 - (- limit (pipe-content-length w)))))]) - (if (and (zero? len) - (null? more)) - (handle-evt w (lambda (x) (loop reqs))) - (handle-evt (channel-put-evt (cadr req) len) - (lambda (x) - ;; We sync'd, so now we *must* write - (write-these-bytes (cadddr req) start (+ start len)) - (loop (remq req reqs)))))))])) - reqs) - ;; nack => remove request (could be anything) - (map (lambda (req) - (handle-evt (caddr req) - (lambda (x) - (loop (remq req reqs))))) - reqs))))) - (define (via-manager what req-sfx) - (thread-resume mgr-th (current-thread)) - (let ([ch (make-channel)]) - (sync (nack-guard-evt - (lambda (nack) - (channel-put mgr-ch (list* what ch nack req-sfx)) - ch))))) - (define (start-mgr) - (unless mgr-th - (set! mgr-th (thread serve))) - (set! via-manager? #t)) - (define (evt what req-sfx) - (nack-guard-evt - (lambda (nack) - (resume-mgr) - (let ([ch (make-channel)]) - (call-with-semaphore - lock-semaphore - (lambda () - (unless mgr-th - (set! mgr-th (thread serve))) - (set! via-manager? #t) - (thread-resume mgr-th (current-thread)) - (channel-put mgr-ch (list* what ch nack req-sfx)) - (wrap-evt ch (lambda (x) - (if (eq? x 'close) - (raise-mismatch-error 'write-evt "port is closed: " out) - x))))))))) - (define (resume-mgr) - (when mgr-th - (thread-resume mgr-th (current-thread)))) - (define in - ;; ----- Input ------ - (make-input-port/read-to-peek - in-name - (lambda (s) - (let ([v (read-bytes-avail!* s r)]) - (if (eq? v 0) - (begin - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'read (list s)) - (read-one s))))) - v))) - #f - void)) - (define out - ;; ----- Output ------ - (make-output-port - out-name - w - ;; write - (lambda (str start end buffer? w/break?) - (if (= start end) - #t - (begin - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'write (list str start end)) - (write-these-bytes str start end))))))) - ;; close - (lambda () - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'close null) - (close-it))))) - ;; write-special - (lambda (v buffer? w/break?) - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'write-spec (list v)) - (write-spec v))))) - ;; write-evt - (lambda (str start end) - (if (= start end) - (wrap-evt always-evt (lambda (x) 0)) - (evt 'write-evt (list str start end)))) - ;; write-special-evt - (lambda (v) - (evt 'write-spec-evt (list v))))) - (values in out)))) - - - (define input-port-append - (opt-lambda (close-orig? . ports) - (make-input-port - (map object-name ports) - (lambda (str) - ;; Reading is easy -- read from the first port, - ;; and get rid of it if the result is eof - (if (null? ports) - eof - (let ([n (read-bytes-avail!* str (car ports))]) - (cond - [(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))] - [(eof-object? n) - (when close-orig? - (close-input-port (car ports))) - (set! ports (cdr ports)) - 0] - [else n])))) - (lambda (str skip unless-evt) - ;; Peeking is more difficult, due to skips. - (let loop ([ports ports][skip skip]) - (if (null? ports) - eof - (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))]) - (cond - [(eq? n 0) - ;; Not ready, yet. - (peek-bytes-avail!-evt str skip unless-evt (car ports))] - [(eof-object? n) - ;; Port is exhausted, or we skipped past its input. - ;; If skip is not zero, we need to figure out - ;; how many chars were skipped. - (loop (cdr ports) - (- skip (compute-avail-to-skip skip (car ports))))] - [else n]))))) - (lambda () - (when close-orig? - (map close-input-port ports)))))) - - (define (convert-stream from from-port - to to-port) - (let ([c (bytes-open-converter from to)] - [in (make-bytes 4096)] - [out (make-bytes 4096)]) - (unless c - (error 'convert-stream "could not create converter from ~e to ~e" - from to)) - (dynamic-wind - void - (lambda () - (let loop ([got 0]) - (let ([n (read-bytes-avail! in from-port got)]) - (let ([got (+ got (if (number? n) - n - 0))]) - (let-values ([(wrote used status) (bytes-convert c in 0 got out)]) - (when (eq? status 'error) - (error 'convert-stream "conversion error")) - (unless (zero? wrote) - (write-bytes out to-port 0 wrote)) - (bytes-copy! in 0 in used got) - (if (not (number? n)) - (begin - (unless (= got used) - (error 'convert-stream "input stream ~a with a partial conversion" - (if (eof-object? n) "ended" "hit a special value"))) - (let-values ([(wrote status) (bytes-convert-end c out)]) - (when (eq? status 'error) - (error 'convert-stream "conversion-end error")) - (unless (zero? wrote) - (write-bytes out to-port 0 wrote)) - (if (eof-object? n) - ;; Success - (void) - (begin - (write-special n to-port) - (loop 0))))) - (loop (- got used)))))))) - (lambda () (bytes-close-converter c))))) - - ;; Helper for input-port-append; given a skip count - ;; and an input port, determine how many characters - ;; (up to upto) are left in the port. We figure this - ;; out using binary search. - (define (compute-avail-to-skip upto p) - (let ([str (make-bytes 1)]) - (let loop ([upto upto][skip 0]) - (if (zero? upto) - skip - (let* ([half (quotient upto 2)] - [n (peek-bytes-avail!* str (+ skip half) #f p)]) - (if (eq? n 1) - (loop (- upto half 1) (+ skip half 1)) - (loop half skip))))))) - - (define make-limited-input-port - (opt-lambda (port limit [close-orig? #t]) - (let ([got 0]) - (make-input-port - (object-name port) - (lambda (str) - (let ([count (min (- limit got) (bytes-length str))]) - (if (zero? count) - eof - (let ([n (read-bytes-avail!* str port 0 count)]) - (cond - [(eq? n 0) (wrap-evt port (lambda (x) 0))] - [(number? n) (set! got (+ got n)) n] - [(procedure? n) (set! got (add1 got)) n] - [else n]))))) - (lambda (str skip progress-evt) - (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) - (if (zero? count) - eof - (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)]) - (if (eq? n 0) - (wrap-evt port (lambda (x) 0)) - n))))) - (lambda () - (when close-orig? - (close-input-port port))))))) - - ;; ---------------------------------------- - - (define (poll-or-spawn go) - (poll-guard-evt - (lambda (poll?) - (if poll? - ;; In poll mode, call `go' directly: - (let ([v (go never-evt #f #t)]) - (if v - (wrap-evt always-evt (lambda (x) v)) - never-evt)) - ;; In non-poll mode, start a thread to call go - (nack-guard-evt - (lambda (nack) - (define ch (make-channel)) - (define ready (make-semaphore)) - (let ([t (thread (lambda () - (parameterize-break #t - (with-handlers ([exn:break? void]) - (semaphore-post ready) - (go nack ch #f)))))]) - (thread (lambda () - (sync nack) - (semaphore-wait ready) - (break-thread t)))) - ch)))))) - - (define (read-at-least-bytes!-evt orig-bstr input-port need-more? shrink combo - peek-offset prog-evt) - ;; go is the main reading function, either called directly for - ;; a poll, or called in a thread for a non-poll read - (define (go nack ch poll?) - (let try-again ([pos 0][bstr orig-bstr]) - (let* ([progress-evt (or prog-evt - (port-progress-evt input-port))] - [v ((if poll? - peek-bytes-avail!* - peek-bytes-avail!) - bstr (+ pos (or peek-offset 0)) progress-evt input-port pos)]) - (cond - ;; the first two cases below are shortcuts, and not - ;; strictly necessary - [(sync/timeout 0 nack) (void)] - [(sync/timeout 0 progress-evt) (if poll? - #f - (if prog-evt - (void) - (try-again pos bstr)))] - [(and poll? (equal? v 0)) #f] - [(and (number? v) (need-more? bstr (+ pos v))) - => (lambda (bstr) - (try-again (+ v pos) bstr))] - [else - (let* ([v2 (cond - [(number? v) (shrink bstr (+ v pos))] - [(positive? pos) pos] - [else v])] - [result (combo bstr v2)]) - (cond - [peek-offset - (if poll? - result - (sync (or prog-evt never-evt) - (channel-put-evt ch result)))] - [(port-commit-peeked (if (number? v2) v2 1) - progress-evt - (if poll? - always-evt - (channel-put-evt ch result)) - input-port) - result] - [(and (eof-object? eof) - (zero? pos) - (not (sync/timeout 0 progress-evt))) - ;; Must be a true end-of-file - (let ([result (combo bstr eof)]) - (if poll? - result - (channel-put ch result)))] - [poll? #f] - [else (try-again 0 orig-bstr)]))])))) - (if (zero? (bytes-length orig-bstr)) - (wrap-evt always-evt (lambda (x) 0)) - (poll-or-spawn go))) - - (define (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt) - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) (if (zero? v) - bstr - #f)) - (lambda (bstr v) v) - (lambda (bstr v) v) - peek-offset prog-evt)) - - (define (read-bytes-avail!-evt bstr input-port) - (-read-bytes-avail!-evt bstr input-port #f #f)) - - (define (peek-bytes-avail!-evt bstr peek-offset prog-evt input-port) - (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt)) - - (define (-read-bytes!-evt bstr input-port peek-offset prog-evt) - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) - (if (v . < . (bytes-length bstr)) - bstr - #f)) - (lambda (bstr v) v) - (lambda (bstr v) v) - peek-offset prog-evt)) - - (define (read-bytes!-evt bstr input-port) - (-read-bytes!-evt bstr input-port #f #f)) - - (define (peek-bytes!-evt bstr peek-offset prog-evt input-port) - (-read-bytes!-evt bstr input-port peek-offset prog-evt)) - - (define (-read-bytes-evt len input-port peek-offset prog-evt) - (let ([bstr (make-bytes len)]) +;; Not kill-safe. +;; If the `read' proc returns an event, the event must produce +;; 0 always (which implies that the `read' proc must not return +;; a pipe input port). +(define make-input-port/read-to-peek + (opt-lambda (name read fast-peek close + [location-proc #f] + [count-lines!-proc void] + [init-position 1] + [buffer-mode-proc #f] + [buffering? #f] + [on-consumed #f]) + (define lock-semaphore (make-semaphore 1)) + (define commit-semaphore (make-semaphore 1)) + (define-values (peeked-r peeked-w) (make-pipe)) + (define special-peeked null) + (define special-peeked-tail #f) + (define progress-requested? #f) + (define use-manager? #f) + (define manager-th #f) + (define manager-ch (make-channel)) + (define resume-ch (make-channel)) + (define buf (make-bytes 4096)) + (define (try-again) (wrap-evt - (-read-bytes!-evt bstr input-port peek-offset prog-evt) - (lambda (v) - (if (number? v) - (if (= v len) - bstr - (subbytes bstr 0 v)) - v))))) - - (define (read-bytes-evt len input-port) - (-read-bytes-evt len input-port #f #f)) - - (define (peek-bytes-evt len peek-offset prog-evt input-port) - (-read-bytes-evt len input-port peek-offset prog-evt)) - - (define (-read-string-evt goal input-port peek-offset prog-evt) - (if (zero? goal) - (wrap-evt always-evt (lambda (x) "")) - (let ([bstr (make-bytes goal)] - [c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) - (wrap-evt - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) - (if (= v (bytes-length bstr)) - ;; We can't easily use bytes-utf-8-length here, - ;; because we may need more bytes to figure out - ;; the true role of the last byte. The - ;; `bytes-convert' function lets us deal with - ;; the last byte properly. - (let-values ([(bstr2 used status) - (bytes-convert c bstr 0 v)]) - (let ([got (bytes-utf-8-length bstr2)]) - (if (= got goal) - ;; Done: - #f - ;; Need more bytes: - (let ([bstr2 (make-bytes (+ v (- goal got)))]) - (bytes-copy! bstr2 0 bstr) - bstr2)))) - ;; Need more bytes in bstr: - bstr)) - (lambda (bstr v) - ;; We may need one less than v, - ;; because we may have had to peek - ;; an extra byte to discover an - ;; error in the stream. - (if ((bytes-utf-8-length bstr #\? 0 v) . > . goal) - (sub1 v) - v)) - cons - peek-offset prog-evt) - (lambda (bstr+v) - (let ([bstr (car bstr+v)] - [v (cdr bstr+v)]) - (if (number? v) - (bytes->string/utf-8 bstr #\? 0 v) - v))))))) - - (define (read-string-evt goal input-port) - (-read-string-evt goal input-port #f #f)) - - (define (peek-string-evt goal peek-offset prog-evt input-port) - (-read-string-evt goal input-port peek-offset prog-evt)) - - (define (-read-string!-evt str input-port peek-offset prog-evt) - (wrap-evt - (-read-string-evt (string-length str) input-port peek-offset prog-evt) - (lambda (s) - (if (string? s) - (begin - (string-copy! str 0 s) - (string-length s)) - s)))) - - (define (read-string!-evt str input-port) - (-read-string!-evt str input-port #f #f)) - - (define (peek-string!-evt str peek-offset prog-evt input-port) - (-read-string!-evt str input-port peek-offset prog-evt)) - - (define (regexp-match-evt pattern input-port) - (define (go nack ch poll?) - (let try-again () - (let* ([progress-evt (port-progress-evt input-port)] - [m ((if poll? - regexp-match-peek-positions-immediate - regexp-match-peek-positions) - pattern input-port 0 #f progress-evt)]) - (cond - [(sync/timeout 0 nack) (void)] - [(sync/timeout 0 progress-evt) (try-again)] - [(not m) - (if poll? - #f - (sync nack - (handle-evt progress-evt - (lambda (x) (try-again)))))] - [else - (let ([m2 (map (lambda (p) - (and p - (let ([bstr (make-bytes (- (cdr p) (car p)))]) - (unless (= (car p) (cdr p)) - (let loop ([offset 0]) - (let ([v (peek-bytes-avail! bstr (car p) progress-evt input-port offset)]) - (unless (zero? v) - (when ((+ offset v) . < . (bytes-length bstr)) - (loop (+ offset v))))))) - bstr))) - m)]) - (cond - [(and (zero? (cdar m)) - (or poll? - (channel-put ch m2))) - m2] - [(port-commit-peeked (cdar m) - progress-evt - (if poll? - always-evt - (channel-put-evt ch m2)) - input-port) - m2] - [poll? #f] - [else (try-again)]))])))) - (poll-or-spawn go)) - - (define-syntax (newline-rx stx) - (syntax-case stx () - [(_ str) (datum->syntax-object #'here - (byte-regexp - (string->bytes/latin-1 - (format "^(?:(.*?)~a)|(.*?$)" - (syntax-e #'str)))))])) - - (define read-bytes-line-evt - (opt-lambda (input-port [mode 'linefeed]) - (wrap-evt - (regexp-match-evt (case mode - [(linefeed) (newline-rx "\n")] - [(return) (newline-rx "\r")] - [(return-linefeed) (newline-rx "\r\n")] - [(any) (newline-rx "(?:\r\n|\r|\n)")] - [(any-one) (newline-rx "[\r\n]")]) - input-port) - (lambda (m) - (or (cadr m) - (let ([l (caddr m)]) - (if (and l (zero? (bytes-length l))) - eof - l))))))) - - (define read-line-evt - (opt-lambda (input-port [mode 'linefeed]) - (wrap-evt - (read-bytes-line-evt input-port mode) - (lambda (s) - (if (eof-object? s) - s - (bytes->string/utf-8 s #\?)))))) - - (define (eof-evt input-port) - (wrap-evt - (regexp-match-evt #rx#"^$" input-port) - (lambda (x) - eof))) - - ;; -------------------------------------------------- - - ;; Helper for reencode-input-port: simulate the composition - ;; of a CRLF/CRNEL/NEL/LS -> LF decoding and some other - ;; decoding. - ;; The "converter" `c' is (mcons converter saved), where - ;; saved is #f if no byte is saved, otherwise it's a saved - ;; byte. It would be nicer and closer to the `bytes-convert' - ;; interface to not consume a trailing CR, but we don't - ;; know the inner encoding, and so we can't rewind it. - (define (bytes-convert/post-nl c buf buf-start buf-end dest) - (cond - [(and (mcdr c) (= buf-start buf-end)) - ;; No more bytes to convert; provide single - ;; saved byte if it's not #\return, otherwise report 'aborts - (if (eq? (mcdr c) (char->integer #\return)) - (values 0 0 'aborts) - (begin - (bytes-set! dest 0 (mcdr c)) - (set-mcdr! c #f) - (values 1 0 'complete)))] - [(and (mcdr c) (= 1 (bytes-length dest))) - ;; We have a saved byte, but the destination is only 1 byte. - ;; If the saved byte is a return, we need to try decoding more, - ;; which means we may end up saving a non-#\return byte: - (if (eq? (mcdr c) (char->integer #\return)) - (let-values ([(got-c used-c status) - (bytes-convert (mcar c) buf buf-start buf-end dest)]) - (if (positive? got-c) - (cond - [(eq? (bytes-ref dest 0) (char->integer #\newline)) - ;; Found CRLF, so just produce LF (and nothing to save) - (set-mcdr! c #f) - (values 1 used-c status)] + (semaphore-peek-evt lock-semaphore) + (lambda (x) 0))) + (define (suspend-manager) + (channel-put manager-ch 'suspend)) + (define (resume-manager) + (channel-put resume-ch 'resume)) + (define (with-manager-lock thunk) + (thread-resume manager-th (current-thread)) + (dynamic-wind suspend-manager thunk resume-manager)) + (define (make-progress) + ;; We dont worry about this byte getting picked up directly + ;; from peeked-r, because the pipe must have been empty when + ;; we grabed the lock, and since we've grabbed the lock, + ;; no other thread could have re-returned the pipe behind + ;; our back. + (write-byte 0 peeked-w) + (read-byte peeked-r)) + (define (consume-from-peeked s) + (let ([n (read-bytes-avail!* s peeked-r)]) + (when on-consumed (on-consumed n)) + n)) + (define (read-it-with-lock s) + (if use-manager? + (with-manager-lock (lambda () (do-read-it s))) + (do-read-it s))) + (define (read-it s) + (call-with-semaphore lock-semaphore read-it-with-lock try-again s)) + (define (do-read-it s) + (if (byte-ready? peeked-r) + (if on-consumed (consume-from-peeked s) peeked-r) + ;; If nothing is saved from a peeking read, dispatch to + ;; `read', otherwise return previously peeked data + (cond + [(null? special-peeked) + (when progress-requested? (make-progress)) + (if (and buffering? ((bytes-length s) . < . 10)) + ;; Buffering is enabled, so read more to move things + ;; along: + (let ([r (read buf)]) + (if (and (number? r) (positive? r)) + (begin (write-bytes buf peeked-w 0 r) + (if on-consumed (consume-from-peeked s) peeked-r)) + (begin (when on-consumed (on-consumed r)) + r))) + ;; Just read requested amount: + (let ([v (read s)]) + (when on-consumed (on-consumed v)) + v))] + [else (if (bytes? (mcar special-peeked)) + (let ([b (mcar special-peeked)]) + (write-bytes b peeked-w) + (set! special-peeked (mcdr special-peeked)) + (when (null? special-peeked) (set! special-peeked-tail #f)) + (consume-from-peeked s)) + (let ([v (mcar special-peeked)]) + (make-progress) + (set! special-peeked (mcdr special-peeked)) + (when on-consumed (on-consumed v)) + (when (null? special-peeked) (set! special-peeked-tail #f)) + v))]))) + (define (peek-it-with-lock s skip unless-evt) + (if use-manager? + (with-manager-lock (lambda () (do-peek-it s skip unless-evt))) + (do-peek-it s skip unless-evt))) + (define (peek-it s skip unless-evt) + (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) + (if (eq? v 0) + (call-with-semaphore lock-semaphore + peek-it-with-lock try-again s skip unless-evt) + v))) + (define (do-peek-it s skip unless-evt) + (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) + (if (eq? v 0) + ;; The peek may have failed because peeked-r is empty, + ;; because unless-evt is ready, or because the skip is + ;; far. Handle nicely the common case where there are no + ;; specials. + (cond + [(and unless-evt (sync/timeout 0 unless-evt)) + #f] + [(null? special-peeked) + ;; Empty special queue, so read through the original proc. + ;; We only only need + ;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w)) + ;; bytes, but if buffering is enabled, read more (up to size of + ;; buf) to help move things along. + (let* ([dest (if buffering? + buf + (make-bytes (- (+ skip (bytes-length s)) + (pipe-content-length peeked-w))))] + [r (read dest)]) + (cond + [(number? r) + ;; The nice case --- reading gave us more bytes + (write-bytes dest peeked-w 0 r) + ;; Now try again + (peek-bytes-avail!* s skip #f peeked-r)] + [(evt? r) + (if unless-evt + ;; Technically, there's a race condition here. + ;; We might choose r (and return 0) even when + ;; unless-evt becomes available first. However, + ;; this race is detectable only by the inside + ;; of `read'. + (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) + r)] [else - ;; Next char fits in a byte, so it isn't NEL, etc. - ;; Save it, and for now return the #\return. - (set-mcdr! c (bytes-ref dest 0)) - (bytes-set! dest 0 (char->integer #\newline)) - (values 1 used-c 'continues)]) - ;; Didn't decode any more; ask for bigger input, etc. - (values 0 0 status))) - ;; Saved a non-#\return, so use that up now. - (begin - (bytes-set! dest 0 (mcdr c)) - (set-mcdr! c #f) - (values 1 0 'continues)))] - [else - ;; Normal convert, maybe prefixed: - (let-values ([(got-c used-c status) - (bytes-convert (mcar c) buf buf-start buf-end dest - (if (mcdr c) 1 0))]) - (let* ([got-c (if (mcdr c) - ;; Insert saved character: - (begin - (bytes-set! dest 0 (char->integer #\return)) - (set-mcdr! c #f) - (add1 got-c)) - got-c)] - [got-c (if (and (positive? got-c) - (eq? (bytes-ref dest (sub1 got-c)) (char->integer #\return)) - (not (eq? status 'error))) - ;; Save trailing carriage return: - (begin - (set-mcdr! c (char->integer #\return)) - (sub1 got-c)) - got-c)]) - ;; Iterate through the converted bytes to apply the newline conversions: - (let loop ([i 0] - [j 0]) + (set! special-peeked (mcons r null)) + (set! special-peeked-tail special-peeked) + ;; Now try again + (do-peek-it s skip unless-evt)]))] + [else + ;; Non-empty special queue, so try to use it + (let* ([avail (pipe-content-length peeked-r)] + [sk (- skip avail)]) + (let loop ([sk sk] [l special-peeked]) + (cond + [(null? l) + ;; Not enough even in the special queue. + ;; Read once and add it. + (let* ([t (make-bytes (min 4096 (+ sk (bytes-length s))))] + [r (read t)]) + (cond + [(evt? r) + (if unless-evt + ;; See note above + (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) + r)] + [(eq? r 0) + ;; Original read thinks a spin is ok, + ;; so we return 0 to skin, too. + 0] + [else (let ([v (if (number? r) + (subbytes t 0 r) + r)]) + (let ([pr (mcons v null)]) + (set-mcdr! special-peeked-tail pr) + (set! special-peeked-tail pr)) + ;; Got something; now try again + (do-peek-it s skip unless-evt))]))] + [(eof-object? (mcar l)) + ;; No peeking past an EOF + eof] + [(procedure? (mcar l)) + (if (zero? sk) + ;; We should call the procedure only once. Change + ;; (mcar l) to a memoizing function, if it isn't already: + (let ([proc (mcar l)]) + (if (memoized? proc) + proc + (let ([proc (memoize proc)]) + (set-mcar! l proc) + proc))) + ;; Skipping over special... + (loop (sub1 sk) (mcdr l)))] + [(bytes? (mcar l)) + (let ([len (bytes-length (mcar l))]) + (if (sk . < . len) + (let ([n (min (bytes-length s) + (- len sk))]) + (bytes-copy! s 0 (mcar l) sk (+ sk n)) + n) + (loop (- sk len) (mcdr l))))])))]) + v))) + (define (commit-it-with-lock amt unless-evt done-evt) + (if use-manager? + (with-manager-lock (lambda () (do-commit-it amt unless-evt done-evt))) + (do-commit-it amt unless-evt done-evt))) + (define (commit-it amt unless-evt done-evt) + (call-with-semaphore lock-semaphore + commit-it-with-lock #f amt unless-evt done-evt)) + (define (do-commit-it amt unless-evt done-evt) + (if (sync/timeout 0 unless-evt) + #f + (let* ([avail (pipe-content-length peeked-r)] + [p-commit (min avail amt)]) + (let loop ([amt (- amt p-commit)] [l special-peeked]) (cond - [(= i got-c) - (values (- got-c (- i j)) used-c (if (and (eq? 'complete status) - (mcdr c)) - 'aborts - status))] + [(amt . <= . 0) + ;; Enough has been peeked. Do commit... + (actual-commit p-commit l unless-evt done-evt)] + [(null? l) + ;; Requested commit was larger than previous peeks + #f] + [(bytes? (mcar l)) + (let ([bl (bytes-length (mcar l))]) + (if (bl . > . amt) + ;; Split the string + (let ([next (mcons (subbytes (mcar l) amt) (mcdr l))]) + (set-mcar! l (subbytes (mcar l) 0 amt)) + (set-mcdr! l next) + (when (eq? l special-peeked-tail) + (set! special-peeked-tail next)) + (loop 0 (mcdr l))) + ;; Consume this string... + (loop (- amt bl) (mcdr l))))] + [else + (loop (sub1 amt) (mcdr l))]))))) + (define (actual-commit p-commit l unless-evt done-evt) + ;; The `finish' proc finally, actually, will commit... + (define (finish) + (unless (zero? p-commit) + (peek-byte peeked-r (sub1 p-commit)) + (port-commit-peeked p-commit unless-evt always-evt peeked-r)) + (set! special-peeked l) + (when (null? special-peeked) (set! special-peeked-tail #f)) + (when (and progress-requested? (zero? p-commit)) (make-progress)) + #t) + ;; If we can sync done-evt immediately, then finish. + (if (sync/timeout 0 (wrap-evt done-evt (lambda (x) #t))) + (finish) + ;; We need to wait, so we'll have to release the lock. + ;; Send the work to a manager thread. + (let ([result-ch (make-channel)] + [w/manager? use-manager?]) + (if w/manager? + ;; Resume manager if it was running: + (resume-manager) + ;; Start manager if it wasn't running: + (begin (set! manager-th (thread manage-commits)) + (set! use-manager? #t) + (thread-resume manager-th (current-thread)))) + ;; Sets use-manager? if the manager wasn't already running: + (channel-put manager-ch (list finish unless-evt done-evt result-ch)) + ;; Release locks: + (semaphore-post lock-semaphore) + (begin0 ;; Wait for manager to complete commit: + (sync result-ch) + ;; Grab locks again, so they're released + ;; properly on exit: + (semaphore-wait lock-semaphore) + (when w/manager? (suspend-manager)))))) + (define (manage-commits) + (let loop ([commits null]) + (apply + sync + (handle-evt manager-ch + (lambda (c) + (case c + [(suspend) + (channel-get resume-ch) + (loop commits)] + [else + ;; adding a commit + (loop (cons c commits))]))) + (map (lambda (c) + (define (send-result v) + ;; Create a new thread to send the result asynchronously: + (thread-resume + (thread (lambda () (channel-put (list-ref c 3) v))) + (current-thread)) + (when (null? (cdr commits)) + (set! use-manager? #f)) + (loop (remq c commits))) + ;; Choose between done and unless: + (if (sync/timeout 0 (list-ref c 1)) + (handle-evt always-evt (lambda (x) (send-result #f))) + (choice-evt + (handle-evt (list-ref c 1) + (lambda (x) + ;; unless ready, which means that the commit must fail + (send-result #f))) + (handle-evt (list-ref c 2) + (lambda (x) + ;; done-evt ready, which means that the commit + ;; must succeed. + ;; If we get here, then commits are not + ;; suspended, so we implicitly have the + ;; lock. + ((list-ref c 0)) + (send-result #t)))))) + commits)))) + (make-input-port + name + ;; Read + read-it + ;; Peek + (if fast-peek + (let ([fast-peek-k (lambda (s skip) (peek-it s skip #f))]) + (lambda (s skip unless-evt) + (if (or unless-evt + (byte-ready? peeked-r) + (mpair? special-peeked)) + (peek-it s skip unless-evt) + (fast-peek s skip fast-peek-k)))) + peek-it) + close + (lambda () + (set! progress-requested? #t) + (port-progress-evt peeked-r)) + commit-it + location-proc + count-lines!-proc + init-position + (and buffer-mode-proc + (case-lambda + [() (buffer-mode-proc)] + [(mode) + (set! buffering? (eq? mode 'block)) + (buffer-mode-proc mode)]))))) + +(define peeking-input-port + (opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) + (make-input-port/read-to-peek + name + (lambda (s) + (let ([r (peek-bytes-avail!* s delta #f orig-in)]) + (set! delta (+ delta (if (number? r) r 1))) + (if (eq? r 0) (handle-evt orig-in (lambda (v) 0)) r))) + (lambda (s skip default) + (peek-bytes-avail!* s (+ delta skip) #f orig-in)) + void))) + +(define relocate-input-port + (opt-lambda (p line col pos [close? #t]) + (transplant-to-relocate transplant-input-port p line col pos close?))) + +(define transplant-input-port + (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void]) + (make-input-port + (object-name p) + (lambda (s) + (let ([v (read-bytes-avail!* s p)]) + (if (eq? v 0) (wrap-evt p (lambda (x) 0)) v))) + (lambda (s skip evt) + (let ([v (peek-bytes-avail!* s skip evt p)]) + (if (eq? v 0) + (choice-evt + (wrap-evt p (lambda (x) 0)) + (if evt (wrap-evt evt (lambda (x) #f)) never-evt)) + v))) + (lambda () + (when close? (close-input-port p))) + (and (port-provides-progress-evts? p) + (lambda () (port-progress-evt p))) + (and (port-provides-progress-evts? p) + (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) + location-proc + count-lines!-proc + pos))) + +;; Not kill-safe. +(define make-pipe-with-specials + ;; This implementation of pipes is almost CML-style, with a manager thread + ;; to guard access to the pipe content. But we only enable the manager + ;; thread when write evts are active; otherwise, we use a lock semaphore. + ;; (Actually, the lock semaphore has to be used all the time, to guard + ;; the flag indicating whether the manager thread is running.) + (opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) + (let-values ([(r w) (make-pipe limit)] + [(more) null] + [(more-last) #f] + [(more-sema) #f] + [(close-w?) #f] + [(lock-semaphore) (make-semaphore 1)] + [(mgr-th) #f] + [(via-manager?) #f] + [(mgr-ch) (make-channel)]) + (define (flush-more) + (if (null? more) + (begin (set! more-last #f) + (when close-w? (close-output-port w))) + (when (bytes? (mcar more)) + (let ([amt (bytes-length (mcar more))]) + (let ([wrote (write-bytes-avail* (mcar more) w)]) + (if (= wrote amt) + (begin (set! more (mcdr more)) + (flush-more)) + (begin + ;; This means that we let too many bytes + ;; get written while a special was pending. + ;; (The limit is disabled when a special + ;; is in the pipe.) + (set-mcar! more (subbytes (mcar more) wrote)) + ;; By peeking, make room for more: + (peek-byte r (sub1 (min (pipe-content-length w) + (- amt wrote)))) + (flush-more)))))))) + (define (read-one s) + (let ([v (read-bytes-avail!* s r)]) + (if (eq? v 0) + (if more-last + ;; Return a special + (let ([a (mcar more)]) + (set! more (mcdr more)) + (flush-more) + (lambda (file line col ppos) a)) + ;; Nothing available, yet. + (begin (unless more-sema (set! more-sema (make-semaphore))) + (wrap-evt (semaphore-peek-evt more-sema) + (lambda (x) 0)))) + v))) + (define (close-it) + (set! close-w? #t) + (unless more-last (close-output-port w)) + (when more-sema (semaphore-post more-sema))) + (define (write-these-bytes str start end) + (begin0 (if more-last + (let ([p (mcons (subbytes str start end) null)]) + (set-mcdr! more-last p) + (set! more-last p) + (- end start)) + (let ([v (write-bytes-avail* str w start end)]) + (if (zero? v) (wrap-evt w (lambda (x) #f)) v))) + (when more-sema + (semaphore-post more-sema) + (set! more-sema #f)))) + (define (write-spec v) + (let ([p (mcons v null)]) + (if more-last (set-mcdr! more-last p) (set! more p)) + (set! more-last p) + (when more-sema + (semaphore-post more-sema) + (set! more-sema #f)))) + (define (serve) + ;; A request is + ;; (list sym result-ch nack-evt . v) + ;; where `v' varies for different `sym's + ;; The possible syms are: read, reply, close, + ;; write, write-spec, write-evt, write-spec-evt + (let loop ([reqs null]) + (apply + sync + ;; Listen for a request: + (handle-evt + mgr-ch + (lambda (req) + (let ([req + ;; Most requests we handle immediately and + ;; convert to a reply. The manager thread + ;; implicitly has the lock. + (let ([reply (lambda (v) + (list 'reply (cadr req) (caddr req) v))]) + (case (car req) + [(read) + (reply (read-one (cadddr req)))] + [(close) + (reply (close-it))] + [(write) + (reply (apply write-these-bytes (cdddr req)))] + [(write-spec) + (reply (write-spec (cadddr req)))] + [else req]))]) + (loop (cons req reqs))))) + (if (and (null? reqs) via-manager?) + ;; If we can get the lock before another request + ;; turn off manager mode: + (handle-evt lock-semaphore + (lambda (x) + (set! via-manager? #f) + (semaphore-post lock-semaphore) + (loop null))) + never-evt) + (append + (map (lambda (req) + (case (car req) + [(reply) + (handle-evt (channel-put-evt (cadr req) (cadddr req)) + (lambda (x) (loop (remq req reqs))))] + [(write-spec-evt) + (if close-w? + ;; Report close error: + (handle-evt (channel-put-evt (cadr req) 'closed) + (lambda (x) (loop (remq req reqs)))) + ;; Try to write special: + (handle-evt (channel-put-evt (cadr req) #t) + (lambda (x) + ;; We sync'd, so now we *must* write + (write-spec (cadddr req)) + (loop (remq req reqs)))))] + [(write-evt) + (if close-w? + ;; Report close error: + (handle-evt (channel-put-evt (cadr req) 'closed) + (lambda (x) (loop (remq req reqs)))) + ;; Try to write bytes: + (let* ([start (list-ref req 4)] + [end (list-ref req 5)] + [len (if more-last + (- end start) + (min (- end start) + (max 0 + (- limit (pipe-content-length w)))))]) + (if (and (zero? len) (null? more)) + (handle-evt w (lambda (x) (loop reqs))) + (handle-evt + (channel-put-evt (cadr req) len) + (lambda (x) + ;; We sync'd, so now we *must* write + (write-these-bytes (cadddr req) start (+ start len)) + (loop (remq req reqs)))))))])) + reqs) + ;; nack => remove request (could be anything) + (map (lambda (req) + (handle-evt (caddr req) + (lambda (x) (loop (remq req reqs))))) + reqs))))) + (define (via-manager what req-sfx) + (thread-resume mgr-th (current-thread)) + (let ([ch (make-channel)]) + (sync (nack-guard-evt + (lambda (nack) + (channel-put mgr-ch (list* what ch nack req-sfx)) + ch))))) + (define (start-mgr) + (unless mgr-th (set! mgr-th (thread serve))) + (set! via-manager? #t)) + (define (evt what req-sfx) + (nack-guard-evt + (lambda (nack) + (resume-mgr) + (let ([ch (make-channel)]) + (call-with-semaphore + lock-semaphore + (lambda () + (unless mgr-th (set! mgr-th (thread serve))) + (set! via-manager? #t) + (thread-resume mgr-th (current-thread)) + (channel-put mgr-ch (list* what ch nack req-sfx)) + (wrap-evt ch (lambda (x) + (if (eq? x 'close) + (raise-mismatch-error 'write-evt "port is closed: " out) + x))))))))) + (define (resume-mgr) + (when mgr-th (thread-resume mgr-th (current-thread)))) + (define in + ;; ----- Input ------ + (make-input-port/read-to-peek + in-name + (lambda (s) + (let ([v (read-bytes-avail!* s r)]) + (if (eq? v 0) + (begin (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? + (via-manager 'read (list s)) + (read-one s))))) + v))) + #f + void)) + (define out + ;; ----- Output ------ + (make-output-port + out-name + w + ;; write + (lambda (str start end buffer? w/break?) + (if (= start end) + #t + (begin + (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? + (via-manager 'write (list str start end)) + (write-these-bytes str start end))))))) + ;; close + (lambda () + (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? (via-manager 'close null) (close-it))))) + ;; write-special + (lambda (v buffer? w/break?) + (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? + (via-manager 'write-spec (list v)) + (write-spec v))))) + ;; write-evt + (lambda (str start end) + (if (= start end) + (wrap-evt always-evt (lambda (x) 0)) + (evt 'write-evt (list str start end)))) + ;; write-special-evt + (lambda (v) + (evt 'write-spec-evt (list v))))) + (values in out)))) + +(define input-port-append + (opt-lambda (close-orig? . ports) + (make-input-port + (map object-name ports) + (lambda (str) + ;; Reading is easy -- read from the first port, + ;; and get rid of it if the result is eof + (if (null? ports) + eof + (let ([n (read-bytes-avail!* str (car ports))]) + (cond + [(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))] + [(eof-object? n) + (when close-orig? (close-input-port (car ports))) + (set! ports (cdr ports)) + 0] + [else n])))) + (lambda (str skip unless-evt) + ;; Peeking is more difficult, due to skips. + (let loop ([ports ports][skip skip]) + (if (null? ports) + eof + (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))]) + (cond + [(eq? n 0) + ;; Not ready, yet. + (peek-bytes-avail!-evt str skip unless-evt (car ports))] + [(eof-object? n) + ;; Port is exhausted, or we skipped past its input. + ;; If skip is not zero, we need to figure out + ;; how many chars were skipped. + (loop (cdr ports) + (- skip (compute-avail-to-skip skip (car ports))))] + [else n]))))) + (lambda () + (when close-orig? + (map close-input-port ports)))))) + +(define (convert-stream from from-port to to-port) + (let ([c (bytes-open-converter from to)] + [in (make-bytes 4096)] + [out (make-bytes 4096)]) + (unless c + (error 'convert-stream "could not create converter from ~e to ~e" + from to)) + (dynamic-wind + void + (lambda () + (let loop ([got 0]) + (let ([n (read-bytes-avail! in from-port got)]) + (let ([got (+ got (if (number? n) n 0))]) + (let-values ([(wrote used status) (bytes-convert c in 0 got out)]) + (when (eq? status 'error) + (error 'convert-stream "conversion error")) + (unless (zero? wrote) + (write-bytes out to-port 0 wrote)) + (bytes-copy! in 0 in used got) + (if (not (number? n)) + (begin + (unless (= got used) + (error 'convert-stream + "input stream ~a with a partial conversion" + (if (eof-object? n) "ended" "hit a special value"))) + (let-values ([(wrote status) (bytes-convert-end c out)]) + (when (eq? status 'error) + (error 'convert-stream "conversion-end error")) + (unless (zero? wrote) + (write-bytes out to-port 0 wrote)) + (if (eof-object? n) + ;; Success + (void) + (begin (write-special n to-port) + (loop 0))))) + (loop (- got used)))))))) + (lambda () (bytes-close-converter c))))) + +;; Helper for input-port-append; given a skip count +;; and an input port, determine how many characters +;; (up to upto) are left in the port. We figure this +;; out using binary search. +(define (compute-avail-to-skip upto p) + (let ([str (make-bytes 1)]) + (let loop ([upto upto][skip 0]) + (if (zero? upto) + skip + (let* ([half (quotient upto 2)] + [n (peek-bytes-avail!* str (+ skip half) #f p)]) + (if (eq? n 1) + (loop (- upto half 1) (+ skip half 1)) + (loop half skip))))))) + +(define make-limited-input-port + (opt-lambda (port limit [close-orig? #t]) + (let ([got 0]) + (make-input-port + (object-name port) + (lambda (str) + (let ([count (min (- limit got) (bytes-length str))]) + (if (zero? count) + eof + (let ([n (read-bytes-avail!* str port 0 count)]) + (cond [(eq? n 0) (wrap-evt port (lambda (x) 0))] + [(number? n) (set! got (+ got n)) n] + [(procedure? n) (set! got (add1 got)) n] + [else n]))))) + (lambda (str skip progress-evt) + (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) + (if (zero? count) + eof + (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)]) + (if (eq? n 0) + (wrap-evt port (lambda (x) 0)) + n))))) + (lambda () + (when close-orig? + (close-input-port port))))))) + +;; ---------------------------------------- + +(define (poll-or-spawn go) + (poll-guard-evt + (lambda (poll?) + (if poll? + ;; In poll mode, call `go' directly: + (let ([v (go never-evt #f #t)]) + (if v (wrap-evt always-evt (lambda (x) v)) never-evt)) + ;; In non-poll mode, start a thread to call go + (nack-guard-evt + (lambda (nack) + (define ch (make-channel)) + (define ready (make-semaphore)) + (let ([t (thread (lambda () + (parameterize-break #t + (with-handlers ([exn:break? void]) + (semaphore-post ready) + (go nack ch #f)))))]) + (thread (lambda () + (sync nack) + (semaphore-wait ready) + (break-thread t)))) + ch)))))) + +(define (read-at-least-bytes!-evt orig-bstr input-port need-more? shrink combo + peek-offset prog-evt) + ;; go is the main reading function, either called directly for + ;; a poll, or called in a thread for a non-poll read + (define (go nack ch poll?) + (let try-again ([pos 0][bstr orig-bstr]) + (let* ([progress-evt (or prog-evt (port-progress-evt input-port))] + [v ((if poll? peek-bytes-avail!* peek-bytes-avail!) + bstr (+ pos (or peek-offset 0)) progress-evt input-port pos)]) + (cond + ;; the first two cases below are shortcuts, and not + ;; strictly necessary + [(sync/timeout 0 nack) (void)] + [(sync/timeout 0 progress-evt) + (cond [poll? #f] + [prog-evt (void)] + [else (try-again pos bstr)])] + [(and poll? (equal? v 0)) #f] + [(and (number? v) (need-more? bstr (+ pos v))) + => (lambda (bstr) (try-again (+ v pos) bstr))] + [else + (let* ([v2 (cond [(number? v) (shrink bstr (+ v pos))] + [(positive? pos) pos] + [else v])] + [result (combo bstr v2)]) + (cond + [peek-offset + (if poll? + result + (sync (or prog-evt never-evt) + (channel-put-evt ch result)))] + [(port-commit-peeked (if (number? v2) v2 1) + progress-evt + (if poll? + always-evt + (channel-put-evt ch result)) + input-port) + result] + [(and (eof-object? eof) + (zero? pos) + (not (sync/timeout 0 progress-evt))) + ;; Must be a true end-of-file + (let ([result (combo bstr eof)]) + (if poll? result (channel-put ch result)))] + [poll? #f] + [else (try-again 0 orig-bstr)]))])))) + (if (zero? (bytes-length orig-bstr)) + (wrap-evt always-evt (lambda (x) 0)) + (poll-or-spawn go))) + +(define (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt) + (read-at-least-bytes!-evt bstr input-port + (lambda (bstr v) (if (zero? v) bstr #f)) + (lambda (bstr v) v) + (lambda (bstr v) v) + peek-offset prog-evt)) + +(define (read-bytes-avail!-evt bstr input-port) + (-read-bytes-avail!-evt bstr input-port #f #f)) + +(define (peek-bytes-avail!-evt bstr peek-offset prog-evt input-port) + (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt)) + +(define (-read-bytes!-evt bstr input-port peek-offset prog-evt) + (read-at-least-bytes!-evt bstr input-port + (lambda (bstr v) + (if (v . < . (bytes-length bstr)) bstr #f)) + (lambda (bstr v) v) + (lambda (bstr v) v) + peek-offset prog-evt)) + +(define (read-bytes!-evt bstr input-port) + (-read-bytes!-evt bstr input-port #f #f)) + +(define (peek-bytes!-evt bstr peek-offset prog-evt input-port) + (-read-bytes!-evt bstr input-port peek-offset prog-evt)) + +(define (-read-bytes-evt len input-port peek-offset prog-evt) + (let ([bstr (make-bytes len)]) + (wrap-evt + (-read-bytes!-evt bstr input-port peek-offset prog-evt) + (lambda (v) + (if (number? v) + (if (= v len) bstr (subbytes bstr 0 v)) + v))))) + +(define (read-bytes-evt len input-port) + (-read-bytes-evt len input-port #f #f)) + +(define (peek-bytes-evt len peek-offset prog-evt input-port) + (-read-bytes-evt len input-port peek-offset prog-evt)) + +(define (-read-string-evt goal input-port peek-offset prog-evt) + (if (zero? goal) + (wrap-evt always-evt (lambda (x) "")) + (let ([bstr (make-bytes goal)] + [c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) + (wrap-evt + (read-at-least-bytes!-evt + bstr input-port + (lambda (bstr v) + (if (= v (bytes-length bstr)) + ;; We can't easily use bytes-utf-8-length here, + ;; because we may need more bytes to figure out + ;; the true role of the last byte. The + ;; `bytes-convert' function lets us deal with + ;; the last byte properly. + (let-values ([(bstr2 used status) + (bytes-convert c bstr 0 v)]) + (let ([got (bytes-utf-8-length bstr2)]) + (if (= got goal) + ;; Done: + #f + ;; Need more bytes: + (let ([bstr2 (make-bytes (+ v (- goal got)))]) + (bytes-copy! bstr2 0 bstr) + bstr2)))) + ;; Need more bytes in bstr: + bstr)) + (lambda (bstr v) + ;; We may need one less than v, + ;; because we may have had to peek + ;; an extra byte to discover an + ;; error in the stream. + (if ((bytes-utf-8-length bstr #\? 0 v) . > . goal) (sub1 v) v)) + cons + peek-offset prog-evt) + (lambda (bstr+v) + (let ([bstr (car bstr+v)] + [v (cdr bstr+v)]) + (if (number? v) + (bytes->string/utf-8 bstr #\? 0 v) + v))))))) + +(define (read-string-evt goal input-port) + (-read-string-evt goal input-port #f #f)) + +(define (peek-string-evt goal peek-offset prog-evt input-port) + (-read-string-evt goal input-port peek-offset prog-evt)) + +(define (-read-string!-evt str input-port peek-offset prog-evt) + (wrap-evt + (-read-string-evt (string-length str) input-port peek-offset prog-evt) + (lambda (s) + (if (string? s) + (begin (string-copy! str 0 s) + (string-length s)) + s)))) + +(define (read-string!-evt str input-port) + (-read-string!-evt str input-port #f #f)) + +(define (peek-string!-evt str peek-offset prog-evt input-port) + (-read-string!-evt str input-port peek-offset prog-evt)) + +(define (regexp-match-evt pattern input-port) + (define (go nack ch poll?) + (let try-again () + (let* ([progress-evt (port-progress-evt input-port)] + [m ((if poll? + regexp-match-peek-positions-immediate + regexp-match-peek-positions) + pattern input-port 0 #f progress-evt)]) + (cond + [(sync/timeout 0 nack) (void)] + [(sync/timeout 0 progress-evt) (try-again)] + [(not m) + (if poll? + #f + (sync nack + (handle-evt progress-evt + (lambda (x) (try-again)))))] + [else + (let ([m2 (map (lambda (p) + (and p + (let ([bstr (make-bytes (- (cdr p) (car p)))]) + (unless (= (car p) (cdr p)) + (let loop ([offset 0]) + (let ([v (peek-bytes-avail! bstr (car p) progress-evt input-port offset)]) + (unless (zero? v) + (when ((+ offset v) . < . (bytes-length bstr)) + (loop (+ offset v))))))) + bstr))) + m)]) + (cond + [(and (zero? (cdar m)) (or poll? (channel-put ch m2))) + m2] + [(port-commit-peeked + (cdar m) + progress-evt + (if poll? always-evt (channel-put-evt ch m2)) + input-port) + m2] + [poll? #f] + [else (try-again)]))])))) + (poll-or-spawn go)) + +(define-syntax (newline-rx stx) + (syntax-case stx () + [(_ str) + (datum->syntax + #'here + (byte-regexp (string->bytes/latin-1 + (format "^(?:(.*?)~a)|(.*?$)" (syntax-e #'str)))))])) + +(define read-bytes-line-evt + (lambda (input-port [mode 'linefeed]) + (wrap-evt + (regexp-match-evt (case mode + [(linefeed) (newline-rx "\n")] + [(return) (newline-rx "\r")] + [(return-linefeed) (newline-rx "\r\n")] + [(any) (newline-rx "(?:\r\n|\r|\n)")] + [(any-one) (newline-rx "[\r\n]")]) + input-port) + (lambda (m) + (or (cadr m) + (let ([l (caddr m)]) + (if (and l (zero? (bytes-length l))) eof l))))))) + +(define read-line-evt + (lambda (input-port [mode 'linefeed]) + (wrap-evt + (read-bytes-line-evt input-port mode) + (lambda (s) + (if (eof-object? s) s (bytes->string/utf-8 s #\?)))))) + +(define (eof-evt input-port) + (wrap-evt (regexp-match-evt #rx#"^$" input-port) + (lambda (x) eof))) + +;; -------------------------------------------------- + +;; Helper for reencode-input-port: simulate the composition +;; of a CRLF/CRNEL/NEL/LS -> LF decoding and some other +;; decoding. +;; The "converter" `c' is (mcons converter saved), where +;; saved is #f if no byte is saved, otherwise it's a saved +;; byte. It would be nicer and closer to the `bytes-convert' +;; interface to not consume a trailing CR, but we don't +;; know the inner encoding, and so we can't rewind it. +(define (bytes-convert/post-nl c buf buf-start buf-end dest) + (cond + [(and (mcdr c) (= buf-start buf-end)) + ;; No more bytes to convert; provide single + ;; saved byte if it's not #\return, otherwise report 'aborts + (if (eq? (mcdr c) (char->integer #\return)) + (values 0 0 'aborts) + (begin (bytes-set! dest 0 (mcdr c)) + (set-mcdr! c #f) + (values 1 0 'complete)))] + [(and (mcdr c) (= 1 (bytes-length dest))) + ;; We have a saved byte, but the destination is only 1 byte. + ;; If the saved byte is a return, we need to try decoding more, + ;; which means we may end up saving a non-#\return byte: + (if (eq? (mcdr c) (char->integer #\return)) + (let-values ([(got-c used-c status) + (bytes-convert (mcar c) buf buf-start buf-end dest)]) + (if (positive? got-c) + (cond + [(eq? (bytes-ref dest 0) (char->integer #\newline)) + ;; Found CRLF, so just produce LF (and nothing to save) + (set-mcdr! c #f) + (values 1 used-c status)] + [else + ;; Next char fits in a byte, so it isn't NEL, etc. + ;; Save it, and for now return the #\return. + (set-mcdr! c (bytes-ref dest 0)) + (bytes-set! dest 0 (char->integer #\newline)) + (values 1 used-c 'continues)]) + ;; Didn't decode any more; ask for bigger input, etc. + (values 0 0 status))) + ;; Saved a non-#\return, so use that up now. + (begin (bytes-set! dest 0 (mcdr c)) + (set-mcdr! c #f) + (values 1 0 'continues)))] + [else + ;; Normal convert, maybe prefixed: + (let-values ([(got-c used-c status) + (bytes-convert (mcar c) buf buf-start buf-end dest + (if (mcdr c) 1 0))]) + (let* ([got-c (if (mcdr c) + ;; Insert saved character: + (begin (bytes-set! dest 0 (char->integer #\return)) + (set-mcdr! c #f) + (add1 got-c)) + got-c)] + [got-c (if (and (positive? got-c) + (eq? (bytes-ref dest (sub1 got-c)) + (char->integer #\return)) + (not (eq? status 'error))) + ;; Save trailing carriage return: + (begin (set-mcdr! c (char->integer #\return)) + (sub1 got-c)) + got-c)]) + ;; Iterate through the converted bytes to apply the newline + ;; conversions: + (let loop ([i 0] [j 0]) + (cond + [(= i got-c) + (values (- got-c (- i j)) + used-c + (if (and (eq? 'complete status) (mcdr c)) + 'aborts + status))] [(eq? (bytes-ref dest i) (char->integer #\return)) - (cond - [(= (add1 i) got-c) - ;; Found lone CR: - (bytes-set! dest j (char->integer #\newline)) - (loop (add1 i) (add1 j))] - [(eq? (bytes-ref dest (add1 i)) (char->integer #\newline)) - ;; Found CRLF: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 2) (add1 j))] - [(and (eq? (bytes-ref dest (add1 i)) #o302) - (eq? (bytes-ref dest (+ i 2)) #o205)) - ;; Found CRNEL: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 3) (add1 j))] - [else - ;; Found lone CR: - (bytes-set! dest j (char->integer #\newline)) - (loop (add1 i) (add1 j))])] + (cond [(= (add1 i) got-c) + ;; Found lone CR: + (bytes-set! dest j (char->integer #\newline)) + (loop (add1 i) (add1 j))] + [(eq? (bytes-ref dest (add1 i)) (char->integer #\newline)) + ;; Found CRLF: + (bytes-set! dest j (char->integer #\newline)) + (loop (+ i 2) (add1 j))] + [(and (eq? (bytes-ref dest (add1 i)) #o302) + (eq? (bytes-ref dest (+ i 2)) #o205)) + ;; Found CRNEL: + (bytes-set! dest j (char->integer #\newline)) + (loop (+ i 3) (add1 j))] + [else + ;; Found lone CR: + (bytes-set! dest j (char->integer #\newline)) + (loop (add1 i) (add1 j))])] [(and (eq? (bytes-ref dest i) #o302) (eq? (bytes-ref dest (+ i 1)) #o205)) ;; Found NEL: @@ -1309,559 +1204,542 @@ (unless (= i j) (bytes-set! dest j (bytes-ref dest i))) (loop (add1 i) (add1 j))]))))])) - - (define reencode-input-port - (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] - [newline-convert? #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~e" msg) - port))]) - (let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) - (if newline-convert? - (mcons c #f) - c))] - [ready-bytes (make-bytes 1024)] - [ready-start 0] - [ready-end 0] - [buf (make-bytes 1024)] - [buf-start 0] - [buf-end 0] - [buf-eof? #f] - [buf-eof-result #f] - [buffer-mode (or (file-stream-buffer-mode port) - 'none)]) - ;; Main reader entry: - (define (read-it s) - (cond - [(> ready-end ready-start) - ;; We have leftover converted bytes: - (let ([cnt (min (bytes-length s) - (- ready-end ready-start))]) - (bytes-copy! s 0 ready-bytes ready-start (+ ready-start cnt)) - (set! ready-start (+ ready-start cnt)) - cnt)] - [else - ;; Try converting already-read bytes: - (let-values ([(got-c used-c status) (if (= buf-start buf-end) - (values 0 0 'aborts) - ((if newline-convert? - bytes-convert/post-nl - bytes-convert) - c buf buf-start buf-end s))]) - (when (positive? used-c) - (set! buf-start (+ used-c buf-start))) - (cond - [(positive? got-c) - ;; We converted some bytes into s. - got-c] - [(eq? status 'aborts) - (if buf-eof? - ;; Had an EOF or special in the stream. - (if (= buf-start buf-end) - (if (and newline-convert? (mcdr c)) ; should be bytes-convert-end - ;; Have leftover CR: - (begin - (bytes-set! s 0 (if (eq? (mcdr c) (char->integer #\return)) - (char->integer #\newline) - (mcdr c))) - (set-mcdr! c #f) - 1) - ;; Return EOF: - (begin0 - buf-eof-result - (set! buf-eof? #f) - (set! buf-eof-result #f))) - (handle-error s)) - ;; Need more bytes. - (begin - (when (positive? buf-start) - (bytes-copy! buf 0 buf buf-start buf-end) - (set! buf-end (- buf-end buf-start)) - (set! buf-start 0)) - (let* ([amt (bytes-length s)] - [c (read-bytes-avail!* buf port buf-end - (if (eq? buffer-mode 'block) - (bytes-length buf) - (min (bytes-length buf) - (+ buf-end amt))))]) - (cond - [(or (eof-object? c) - (procedure? c)) - ;; Got EOF/procedure - (set! buf-eof? #t) - (set! buf-eof-result c) - (read-it s)] - [(zero? c) - ;; No bytes ready --- try again later. - (wrap-evt port (lambda (v) 0))] - [else - ;; Got some bytes; loop to decode. - (set! buf-end (+ buf-end c)) - (read-it s)]))))] - [(eq? status 'error) - (handle-error s)] - [(eq? status 'continues) - ;; Need more room to make progress at all. - ;; Decode into ready-bytes. - (let-values ([(got-c used-c status) ((if newline-convert? - bytes-convert/post-nl - bytes-convert) + +(define reencode-input-port + (opt-lambda (port encoding [error-bytes #f] [close? #f] + [name (object-name port)] + [newline-convert? #f] + [decode-error (lambda (msg port) + (error 'reencode-input-port + (format "~a: ~e" msg) + port))]) + (let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) + (if newline-convert? (mcons c #f) c))] + [ready-bytes (make-bytes 1024)] + [ready-start 0] + [ready-end 0] + [buf (make-bytes 1024)] + [buf-start 0] + [buf-end 0] + [buf-eof? #f] + [buf-eof-result #f] + [buffer-mode (or (file-stream-buffer-mode port) 'none)]) + ;; Main reader entry: + (define (read-it s) + (cond + [(> ready-end ready-start) + ;; We have leftover converted bytes: + (let ([cnt (min (bytes-length s) (- ready-end ready-start))]) + (bytes-copy! s 0 ready-bytes ready-start (+ ready-start cnt)) + (set! ready-start (+ ready-start cnt)) + cnt)] + [else + ;; Try converting already-read bytes: + (let-values ([(got-c used-c status) + (if (= buf-start buf-end) + (values 0 0 'aborts) + ((if newline-convert? + bytes-convert/post-nl + bytes-convert) + c buf buf-start buf-end s))]) + (when (positive? used-c) (set! buf-start (+ used-c buf-start))) + (cond + [(positive? got-c) + ;; We converted some bytes into s. + got-c] + [(eq? status 'aborts) + (if buf-eof? + ;; Had an EOF or special in the stream. + (if (= buf-start buf-end) + (if (and newline-convert? (mcdr c)) ; should be bytes-convert-end + ;; Have leftover CR: + (begin + (bytes-set! s 0 + (if (eq? (mcdr c) (char->integer #\return)) + (char->integer #\newline) + (mcdr c))) + (set-mcdr! c #f) + 1) + ;; Return EOF: + (begin0 buf-eof-result + (set! buf-eof? #f) + (set! buf-eof-result #f))) + (handle-error s)) + ;; Need more bytes. + (begin + (when (positive? buf-start) + (bytes-copy! buf 0 buf buf-start buf-end) + (set! buf-end (- buf-end buf-start)) + (set! buf-start 0)) + (let* ([amt (bytes-length s)] + [c (read-bytes-avail!* + buf port buf-end + (if (eq? buffer-mode 'block) + (bytes-length buf) + (min (bytes-length buf) (+ buf-end amt))))]) + (cond + [(or (eof-object? c) (procedure? c)) + ;; Got EOF/procedure + (set! buf-eof? #t) + (set! buf-eof-result c) + (read-it s)] + [(zero? c) + ;; No bytes ready --- try again later. + (wrap-evt port (lambda (v) 0))] + [else + ;; Got some bytes; loop to decode. + (set! buf-end (+ buf-end c)) + (read-it s)]))))] + [(eq? status 'error) + (handle-error s)] + [(eq? status 'continues) + ;; Need more room to make progress at all. + ;; Decode into ready-bytes. + (let-values ([(got-c used-c status) ((if newline-convert? + bytes-convert/post-nl + bytes-convert) c buf buf-start buf-end ready-bytes)]) (unless (memq status '(continues complete)) - (decode-error "unable to make decoding progress" + (decode-error "unable to make decoding progress" port)) - (set! ready-start 0) - (set! ready-end got-c) - (set! buf-start (+ used-c buf-start)) - (read-it s))]))])) + (set! ready-start 0) + (set! ready-end got-c) + (set! buf-start (+ used-c buf-start)) + (read-it s))]))])) - ;; Raise exception or discard first buffered byte. - ;; We assume that read-bytes is empty - (define (handle-error s) - (if error-bytes - (begin - (set! buf-start (add1 buf-start)) - (let ([cnt (min (bytes-length s) - (bytes-length error-bytes))]) - (bytes-copy! s 0 error-bytes 0 cnt) - (bytes-copy! ready-bytes 0 error-bytes cnt) - (set! ready-start 0) - (set! ready-end (- (bytes-length error-bytes) cnt)) - cnt)) - (decode-error "decoding error in input stream" - port))) - - (unless c - (error 'reencode-input-port - "could not create converter from ~e to UTF-8" - encoding)) - - (make-input-port/read-to-peek - name - read-it - #f - (lambda () - (when close? - (close-input-port port)) - (bytes-close-converter (if newline-convert? - (mcar c) - c))) - #f void 1 - (case-lambda - [() buffer-mode] - [(mode) (set! buffer-mode mode)]) - (eq? buffer-mode 'block))))) - - ;; -------------------------------------------------- - - (define reencode-output-port - (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] - [convert-newlines-to #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~e" msg) - port))]) - (let ([c (bytes-open-converter "UTF-8" encoding)] - [ready-bytes (make-bytes 1024)] - [ready-start 0] - [ready-end 0] - [out-bytes (make-bytes 1024)] - [out-start 0] - [out-end 0] - [buffer-mode (or (file-stream-buffer-mode port) - 'block)] - [debuffer-buf #f] - [newline-buffer #f]) - (define-values (buffered-r buffered-w) (make-pipe 4096)) - - ;; The main writing entry point: - (define (write-it s start end no-buffer&block? enable-break?) - (cond - [(= start end) - ;; This is a flush request; no-buffer&block? must be #f - ;; Note: we could get stuck because only half an encoding - ;; is available in out-bytes. - (flush-buffer-pipe #f enable-break?) - (flush-some #f enable-break?) - (if (buffer-flushed?) - 0 - (write-it s start end no-buffer&block? enable-break?))] - [no-buffer&block? - (case (flush-all #t enable-break?) - [(not-done) - ;; We couldn't flush right away, so give up. - #f] - [(done) - (non-blocking-write s start end)] - [(stuck) - ;; We need more bytes to make progress. - ;; Add out-bytes and s into one string for non-blocking-write. - (let ([s2 (bytes-append (subbytes out-bytes out-start out-end) - (subbytes s start end))] - [out-len (- out-end out-start)]) - (let ([c (non-blocking-write s2 0 (bytes-length s2))]) - (and c - (begin - (set! out-start 0) - (set! out-end 0) - (- c out-len)))))])] - [(and (eq? buffer-mode 'block) - (zero? (pipe-content-length buffered-r))) - ;; The port system can buffer to a pipe faster, so give it a pipe. - buffered-w] - [else - ;; Flush/buffer from pipe, first: - (flush-buffer-pipe #f enable-break?) - ;; Flush as needed to make room in the buffer: - (make-buffer-room #f enable-break?) - ;; Buffer some bytes: - (let-values ([(s2 start2 cnt2 used) (convert-newlines s start - (- end start) - (- (bytes-length out-bytes) out-end))]) - (if (zero? used) - ;; No room --- try flushing again: - (write-it s start end #f enable-break?) - ;; Buffer and report success: - (begin - (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) - (set! out-end (+ cnt2 out-end)) - (case buffer-mode - [(none) (flush-all-now enable-break?)] - [(line) (when (regexp-match-positions #rx#"[\r\n]" s start (+ start used)) - (flush-all-now enable-break?))]) - used)))])) + ;; Raise exception or discard first buffered byte. + ;; We assume that read-bytes is empty + (define (handle-error s) + (if error-bytes + (begin + (set! buf-start (add1 buf-start)) + (let ([cnt (min (bytes-length s) + (bytes-length error-bytes))]) + (bytes-copy! s 0 error-bytes 0 cnt) + (bytes-copy! ready-bytes 0 error-bytes cnt) + (set! ready-start 0) + (set! ready-end (- (bytes-length error-bytes) cnt)) + cnt)) + (decode-error "decoding error in input stream" port))) - (define (convert-newlines s start cnt avail) - ;; If newline converting is on, try convert up to cnt - ;; bytes to produce a result that fits in avail bytes. - (if convert-newlines-to - ;; Conversion: - (let ([end (+ start cnt)] - [avail (min avail 1024)]) - (unless newline-buffer - (set! newline-buffer (make-bytes 1024))) - (let loop ([i start][j 0]) - (cond - [(or (= j avail) (= i end)) (values newline-buffer 0 j i)] - [(eq? (char->integer #\newline) (bytes-ref s i)) - ;; Newline conversion - (let ([len (bytes-length convert-newlines-to)]) - (if ((+ j len) . > . avail) - ;; No room - (values newline-buffer 0 j i) - ;; Room - (begin - (bytes-copy! newline-buffer j convert-newlines-to) + (unless c + (error 'reencode-input-port + "could not create converter from ~e to UTF-8" + encoding)) + + (make-input-port/read-to-peek + name + read-it + #f + (lambda () + (when close? (close-input-port port)) + (bytes-close-converter (if newline-convert? (mcar c) c))) + #f void 1 + (case-lambda + [() buffer-mode] + [(mode) (set! buffer-mode mode)]) + (eq? buffer-mode 'block))))) + +;; -------------------------------------------------- + +(define reencode-output-port + (opt-lambda (port encoding [error-bytes #f] [close? #f] + [name (object-name port)] + [convert-newlines-to #f] + [decode-error (lambda (msg port) + (error 'reencode-input-port + (format "~a: ~e" msg) + port))]) + (let ([c (bytes-open-converter "UTF-8" encoding)] + [ready-bytes (make-bytes 1024)] + [ready-start 0] + [ready-end 0] + [out-bytes (make-bytes 1024)] + [out-start 0] + [out-end 0] + [buffer-mode (or (file-stream-buffer-mode port) 'block)] + [debuffer-buf #f] + [newline-buffer #f]) + (define-values (buffered-r buffered-w) (make-pipe 4096)) + + ;; The main writing entry point: + (define (write-it s start end no-buffer&block? enable-break?) + (cond + [(= start end) + ;; This is a flush request; no-buffer&block? must be #f + ;; Note: we could get stuck because only half an encoding + ;; is available in out-bytes. + (flush-buffer-pipe #f enable-break?) + (flush-some #f enable-break?) + (if (buffer-flushed?) + 0 + (write-it s start end no-buffer&block? enable-break?))] + [no-buffer&block? + (case (flush-all #t enable-break?) + [(not-done) + ;; We couldn't flush right away, so give up. + #f] + [(done) + (non-blocking-write s start end)] + [(stuck) + ;; We need more bytes to make progress. + ;; Add out-bytes and s into one string for non-blocking-write. + (let ([s2 (bytes-append (subbytes out-bytes out-start out-end) + (subbytes s start end))] + [out-len (- out-end out-start)]) + (let ([c (non-blocking-write s2 0 (bytes-length s2))]) + (and c (begin (set! out-start 0) + (set! out-end 0) + (- c out-len)))))])] + [(and (eq? buffer-mode 'block) + (zero? (pipe-content-length buffered-r))) + ;; The port system can buffer to a pipe faster, so give it a pipe. + buffered-w] + [else + ;; Flush/buffer from pipe, first: + (flush-buffer-pipe #f enable-break?) + ;; Flush as needed to make room in the buffer: + (make-buffer-room #f enable-break?) + ;; Buffer some bytes: + (let-values ([(s2 start2 cnt2 used) + (convert-newlines s start + (- end start) + (- (bytes-length out-bytes) out-end))]) + (if (zero? used) + ;; No room --- try flushing again: + (write-it s start end #f enable-break?) + ;; Buffer and report success: + (begin + (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) + (set! out-end (+ cnt2 out-end)) + (case buffer-mode + [(none) (flush-all-now enable-break?)] + [(line) (when (regexp-match-positions #rx#"[\r\n]" s start + (+ start used)) + (flush-all-now enable-break?))]) + used)))])) + + (define (convert-newlines s start cnt avail) + ;; If newline converting is on, try convert up to cnt + ;; bytes to produce a result that fits in avail bytes. + (if convert-newlines-to + ;; Conversion: + (let ([end (+ start cnt)] + [avail (min avail 1024)]) + (unless newline-buffer + (set! newline-buffer (make-bytes 1024))) + (let loop ([i start][j 0]) + (cond + [(or (= j avail) (= i end)) (values newline-buffer 0 j i)] + [(eq? (char->integer #\newline) (bytes-ref s i)) + ;; Newline conversion + (let ([len (bytes-length convert-newlines-to)]) + (if ((+ j len) . > . avail) + ;; No room + (values newline-buffer 0 j i) + ;; Room + (begin (bytes-copy! newline-buffer j convert-newlines-to) (loop (add1 i) (+ j len)))))] - [else - (bytes-set! newline-buffer j (bytes-ref s i)) - (loop (add1 i) (add1 j))]))) - ;; No conversion: - (let ([cnt (min cnt avail)]) - (values s start cnt cnt)))) + [else + (bytes-set! newline-buffer j (bytes-ref s i)) + (loop (add1 i) (add1 j))]))) + ;; No conversion: + (let ([cnt (min cnt avail)]) + (values s start cnt cnt)))) - (define (make-buffer-room non-block? enable-break?) - (when (or (> ready-end ready-start) - (< (- (bytes-length out-bytes) out-end) 100)) - ;; Make room for conversion. - (flush-some non-block? enable-break?) ;; convert some - (flush-some non-block? enable-break?)) ;; write converted - ;; Make room in buffer - (when (positive? out-start) - (bytes-copy! out-bytes 0 out-bytes out-start out-end) - (set! out-end (- out-end out-start)) - (set! out-start 0))) + (define (make-buffer-room non-block? enable-break?) + (when (or (> ready-end ready-start) + (< (- (bytes-length out-bytes) out-end) 100)) + ;; Make room for conversion. + (flush-some non-block? enable-break?) ;; convert some + (flush-some non-block? enable-break?)) ;; write converted + ;; Make room in buffer + (when (positive? out-start) + (bytes-copy! out-bytes 0 out-bytes out-start out-end) + (set! out-end (- out-end out-start)) + (set! out-start 0))) - (define (flush-buffer-pipe non-block? enable-break?) - (let loop () - (if (zero? (pipe-content-length buffered-r)) - 'done - (begin - (unless debuffer-buf - (set! debuffer-buf (make-bytes 4096))) - (make-buffer-room non-block? enable-break?) - (let ([amt (- (bytes-length out-bytes) out-end)]) - (if (zero? amt) - 'stuck - (if convert-newlines-to - ;; Peek, convert newlines, write, then read converted amount: - (let ([cnt (peek-bytes-avail! debuffer-buf 0 #f buffered-r 0 amt)]) - (let-values ([(s2 start2 cnt2 used) - (convert-newlines debuffer-buf 0 cnt amt)]) - (bytes-copy! out-bytes out-end s2 start2 cnt2) - (set! out-end (+ cnt2 out-end)) - (read-bytes-avail! debuffer-buf buffered-r 0 used) - (loop))) - ;; Skip an indirection: read directly and write: - (let ([cnt (read-bytes-avail! debuffer-buf buffered-r 0 amt)]) - (bytes-copy! out-bytes out-end debuffer-buf 0 cnt) - (set! out-end (+ cnt out-end)) - (loop))))))))) - - (define (non-blocking-write s start end) - ;; For now, everything that we can flushed is flushed. - ;; Try to write the minimal number of bytes, and hope for the - ;; best. If none of all of the minimal bytes get written, - ;; everyone is happy enough. If some of the bytes get written, - ;; the we will have buffered bytes when we shouldn't have. - ;; That probably won't happen, but we can't guarantee it. - (if (sync/timeout 0.0 port) - ;; We should be able to write one byte... - (let loop ([len 1]) - (let*-values ([(s2 start2 len2 used) (convert-newlines s start (- end start) len)] - [(got-c used-c status) (bytes-convert c s2 start2 (+ start2 len2) ready-bytes)]) - (cond - [(positive? got-c) - (try-flush-ready got-c used-c) - ;; If used-c < len2, then we converted only partially --- which - ;; is strange, because we kept adding bytes one at a time. - ;; we will just guess is that the unused bytes were not converted - ;; bytes, and generally hope that this sort of encoding doesn't - ;; show up. - (- used (- len2 used-c))] - [(eq? status 'aborts) - (if (< len (- end start)) - ;; Try converting a bigger chunk - (loop (add1 len)) - ;; We can't flush half an encoding, so just buffer it. - (begin - (when (> len2 (bytes-length out-bytes)) + (define (flush-buffer-pipe non-block? enable-break?) + (let loop () + (if (zero? (pipe-content-length buffered-r)) + 'done + (begin + (unless debuffer-buf (set! debuffer-buf (make-bytes 4096))) + (make-buffer-room non-block? enable-break?) + (let ([amt (- (bytes-length out-bytes) out-end)]) + (if (zero? amt) + 'stuck + (if convert-newlines-to + ;; Peek, convert newlines, write, then read converted amount: + (let ([cnt (peek-bytes-avail! debuffer-buf 0 #f buffered-r + 0 amt)]) + (let-values ([(s2 start2 cnt2 used) + (convert-newlines debuffer-buf 0 cnt amt)]) + (bytes-copy! out-bytes out-end s2 start2 cnt2) + (set! out-end (+ cnt2 out-end)) + (read-bytes-avail! debuffer-buf buffered-r 0 used) + (loop))) + ;; Skip an indirection: read directly and write: + (let ([cnt (read-bytes-avail! debuffer-buf buffered-r + 0 amt)]) + (bytes-copy! out-bytes out-end debuffer-buf 0 cnt) + (set! out-end (+ cnt out-end)) + (loop))))))))) + + (define (non-blocking-write s start end) + ;; For now, everything that we can flushed is flushed. + ;; Try to write the minimal number of bytes, and hope for the + ;; best. If none of all of the minimal bytes get written, + ;; everyone is happy enough. If some of the bytes get written, + ;; the we will have buffered bytes when we shouldn't have. + ;; That probably won't happen, but we can't guarantee it. + (if (sync/timeout 0.0 port) + ;; We should be able to write one byte... + (let loop ([len 1]) + (let*-values ([(s2 start2 len2 used) + (convert-newlines s start (- end start) len)] + [(got-c used-c status) + (bytes-convert c s2 start2 (+ start2 len2) + ready-bytes)]) + (cond + [(positive? got-c) + (try-flush-ready got-c used-c) + ;; If used-c < len2, then we converted only partially + ;; --- which is strange, because we kept adding + ;; bytes one at a time. we will just guess is that + ;; the unused bytes were not converted bytes, and + ;; generally hope that this sort of encoding doesn't + ;; show up. + (- used (- len2 used-c))] + [(eq? status 'aborts) + (if (< len (- end start)) + ;; Try converting a bigger chunk + (loop (add1 len)) + ;; We can't flush half an encoding, so just buffer it. + (begin (when (> len2 (bytes-length out-bytes)) (raise-insane-decoding-length)) (bytes-copy! out-bytes 0 s2 start2 (+ start2 len2)) (set! out-start 0) (set! out-end len2) used))] - [(eq? status 'continues) - ;; Not enough room in ready-bytes!? We give up. - (raise-insane-decoding-length)] - [else - ;; Encoding error. Try to flush error bytes. - (let ([cnt (bytes-length error-bytes)]) - (bytes-copy! ready-bytes 0 error-bytes) - (try-flush-ready cnt 1) - used)]))) - ;; Port is not ready for writing: - #f)) + [(eq? status 'continues) + ;; Not enough room in ready-bytes!? We give up. + (raise-insane-decoding-length)] + [else + ;; Encoding error. Try to flush error bytes. + (let ([cnt (bytes-length error-bytes)]) + (bytes-copy! ready-bytes 0 error-bytes) + (try-flush-ready cnt 1) + used)]))) + ;; Port is not ready for writing: + #f)) - (define (write-special-it v no-buffer&block? enable-break?) - (cond - [(buffer-flushed?) - ((if no-buffer&block? - write-special-avail* - (if enable-break? - (lambda (v p) - (parameterize-break #t (write-special v p))) - write-special)) - v port)] - [else - ;; Note: we could get stuck because only half an encoding - ;; is available in out-bytes. - (flush-buffer-pipe no-buffer&block? enable-break?) - (flush-some no-buffer&block? enable-break?) - (if (or (buffer-flushed?) - (not no-buffer&block?)) - (write-special-it v no-buffer&block? enable-break?) - #f)])) - - ;; flush-all : -> 'done, 'not-done, or 'stuck - (define (flush-all non-block? enable-break?) - (if (eq? (flush-buffer-pipe non-block? enable-break?) 'done) - (let ([orig-none-ready? (= ready-start ready-end)] - [orig-out-start out-start] - [orig-out-end out-end]) - (flush-some non-block? enable-break?) - (if (buffer-flushed?) - 'done - ;; Couldn't flush everything. One possibility is that we need - ;; more bytes to convert before a flush. - (if (and orig-none-ready? - (= ready-start ready-end) - (= orig-out-start out-start) - (= orig-out-end out-end)) - 'stuck - 'not-done))) - 'stuck)) + (define (write-special-it v no-buffer&block? enable-break?) + (cond + [(buffer-flushed?) + ((if no-buffer&block? + write-special-avail* + (if enable-break? + (lambda (v p) (parameterize-break #t (write-special v p))) + write-special)) + v port)] + [else + ;; Note: we could get stuck because only half an encoding + ;; is available in out-bytes. + (flush-buffer-pipe no-buffer&block? enable-break?) + (flush-some no-buffer&block? enable-break?) + (if (or (buffer-flushed?) (not no-buffer&block?)) + (write-special-it v no-buffer&block? enable-break?) + #f)])) - (define (flush-all-now enable-break?) - (case (flush-all #f enable-break?) - [(not-done) (flush-all-now enable-break?)])) - - (define (buffer-flushed?) - (and (= ready-start ready-end) - (= out-start out-end) - (zero? (pipe-content-length buffered-r)))) - - ;; Try to flush immediately a certain number of bytes. - ;; we've already converted them, so we have to keep - ;; the bytes in any case. - (define (try-flush-ready got-c used-c) - (let ([c (write-bytes-avail* ready-bytes port 0 got-c)]) - (unless (= c got-c) - (set! ready-start c) - (set! ready-end got-c)))) + ;; flush-all : -> 'done, 'not-done, or 'stuck + (define (flush-all non-block? enable-break?) + (if (eq? (flush-buffer-pipe non-block? enable-break?) 'done) + (let ([orig-none-ready? (= ready-start ready-end)] + [orig-out-start out-start] + [orig-out-end out-end]) + (flush-some non-block? enable-break?) + (if (buffer-flushed?) + 'done + ;; Couldn't flush everything. One possibility is that we need + ;; more bytes to convert before a flush. + (if (and orig-none-ready? + (= ready-start ready-end) + (= orig-out-start out-start) + (= orig-out-end out-end)) + 'stuck + 'not-done))) + 'stuck)) - ;; Try to make progress flushing buffered bytes - (define (flush-some non-block? enable-break?) - (unless (= ready-start ready-end) - ;; Flush converted bytes: - (let ([cnt ((cond - [non-block? write-bytes-avail*] - [enable-break? write-bytes-avail/enable-break] - [else write-bytes-avail]) - ready-bytes port ready-start ready-end)]) - (set! ready-start (+ ready-start cnt)))) - (when (= ready-start ready-end) - ;; Convert more, if available: - (set! ready-start 0) - (set! ready-end 0) - (when (> out-end out-start) - (let-values ([(got-c used-c status) (bytes-convert c out-bytes out-start out-end ready-bytes)]) - (set! ready-end got-c) - (set! out-start (+ out-start used-c)) - (when (and (eq? status 'continues) - (zero? used-c)) - ;; Yikes! Size of ready-bytes isn't enough room for progress!? - (raise-insane-decoding-length)) - (when (and (eq? status 'error) - (zero? used-c)) - ;; No progress before an encoding error. - (if error-bytes - ;; Write error bytes and drop an output byte: - (begin - (set! out-start (add1 out-start)) - (bytes-copy! ready-bytes 0 error-bytes) - (set! ready-end (bytes-length error-bytes))) - ;; Raise an exception: - (begin - (set! out-start out-end) ;; flush buffer so close can work - (decode-error - "error decoding output to stream" - port)))))))) + (define (flush-all-now enable-break?) + (case (flush-all #f enable-break?) + [(not-done) (flush-all-now enable-break?)])) - ;; This error is used when decoding wants more bytes to make progress even - ;; though we've supplied hundreds of bytes - (define (raise-insane-decoding-length) - (decode-error "unable to make decoding progress" - port)) + (define (buffer-flushed?) + (and (= ready-start ready-end) + (= out-start out-end) + (zero? (pipe-content-length buffered-r)))) - ;; Check that a decoder is available: - (unless c - (error 'reencode-output-port - "could not create converter from ~e to UTF-8" - encoding)) + ;; Try to flush immediately a certain number of bytes. + ;; we've already converted them, so we have to keep + ;; the bytes in any case. + (define (try-flush-ready got-c used-c) + (let ([c (write-bytes-avail* ready-bytes port 0 got-c)]) + (unless (= c got-c) + (set! ready-start c) + (set! ready-end got-c)))) - (make-output-port - name - port - write-it - (lambda () - ;; Flush output - (write-it #"" 0 0 #f #f) - (when close? - (close-output-port port)) - (bytes-close-converter c)) - write-special-it - #f #f - #f void - 1 - (case-lambda - [() buffer-mode] - [(mode) (let ([old buffer-mode]) - (set! buffer-mode mode) - (when (or (and (eq? old 'block) - (memq mode '(none line))) - (and (eq? old 'line) - (memq mode '(none)))) - ;; Flush output - (write-it #"" 0 0 #f #f)))]))))) + ;; Try to make progress flushing buffered bytes + (define (flush-some non-block? enable-break?) + (unless (= ready-start ready-end) + ;; Flush converted bytes: + (let ([cnt ((cond [non-block? write-bytes-avail*] + [enable-break? write-bytes-avail/enable-break] + [else write-bytes-avail]) + ready-bytes port ready-start ready-end)]) + (set! ready-start (+ ready-start cnt)))) + (when (= ready-start ready-end) + ;; Convert more, if available: + (set! ready-start 0) + (set! ready-end 0) + (when (> out-end out-start) + (let-values ([(got-c used-c status) + (bytes-convert c out-bytes out-start out-end + ready-bytes)]) + (set! ready-end got-c) + (set! out-start (+ out-start used-c)) + (when (and (eq? status 'continues) (zero? used-c)) + ;; Yikes! Size of ready-bytes isn't enough room for progress!? + (raise-insane-decoding-length)) + (when (and (eq? status 'error) (zero? used-c)) + ;; No progress before an encoding error. + (if error-bytes + ;; Write error bytes and drop an output byte: + (begin (set! out-start (add1 out-start)) + (bytes-copy! ready-bytes 0 error-bytes) + (set! ready-end (bytes-length error-bytes))) + ;; Raise an exception: + (begin + (set! out-start out-end) ;; flush buffer so close can work + (decode-error + "error decoding output to stream" + port)))))))) - ;; ---------------------------------------- + ;; This error is used when decoding wants more bytes to make + ;; progress even though we've supplied hundreds of bytes + (define (raise-insane-decoding-length) + (decode-error "unable to make decoding progress" port)) - (define dup-output-port - (opt-lambda (p [close? #f]) - (let ([new (transplant-output-port p - (lambda () - (port-next-location p)) - (let-values ([(line col pos) - (port-next-location p)]) - (or pos - (file-position p))) - close? - (lambda () - (port-count-lines! p)))]) - (port-display-handler new (port-display-handler p)) - (port-write-handler new (port-write-handler p)) - new))) + ;; Check that a decoder is available: + (unless c + (error 'reencode-output-port + "could not create converter from ~e to UTF-8" + encoding)) - (define dup-input-port - (opt-lambda (p [close? #f]) - (let ([new (transplant-input-port p - (lambda () - (port-next-location p)) - (let-values ([(line col pos) - (port-next-location p)]) - (or pos - (file-position p))) - close? - (lambda () - (port-count-lines! p)))]) - (port-read-handler new (port-read-handler p)) - new))) + (make-output-port + name + port + write-it + (lambda () + ;; Flush output + (write-it #"" 0 0 #f #f) + (when close? + (close-output-port port)) + (bytes-close-converter c)) + write-special-it + #f #f + #f void + 1 + (case-lambda + [() buffer-mode] + [(mode) (let ([old buffer-mode]) + (set! buffer-mode mode) + (when (or (and (eq? old 'block) (memq mode '(none line))) + (and (eq? old 'line) (memq mode '(none)))) + ;; Flush output + (write-it #"" 0 0 #f #f)))]))))) - ;; ---------------------------------------- - - (provide open-output-nowhere - make-pipe-with-specials - make-input-port/read-to-peek - peeking-input-port - relocate-input-port - transplant-input-port - relocate-output-port - transplant-output-port - merge-input - copy-port - input-port-append - convert-stream - make-limited-input-port - reencode-input-port - reencode-output-port - dup-input-port - dup-output-port - strip-shell-command-start) - - (provide/contract (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts? - . -> . evt?)) - (peek-bytes-avail!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?)) - (peek-bytes!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-bytes-evt (exact-nonnegative-integer? input-port-with-progress-evts? - . -> . evt?)) - (peek-bytes-evt (exact-nonnegative-integer? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-string!-evt (mutable-string? input-port-with-progress-evts? - . -> . evt?)) - (peek-string!-evt (mutable-string? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-string-evt (exact-nonnegative-integer? input-port-with-progress-evts? - . -> . evt?)) - (peek-string-evt (exact-nonnegative-integer? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?) - input-port-with-progress-evts? - . -> . evt?)) +;; ---------------------------------------- - (read-bytes-line-evt (case-> - (input-port-with-progress-evts? . -> . evt?) - (input-port-with-progress-evts? line-mode-symbol? . -> . evt?))) - (read-line-evt (case-> - (input-port-with-progress-evts? . -> . evt?) - (input-port-with-progress-evts? line-mode-symbol? . -> . evt?))) - (eof-evt (input-port-with-progress-evts? . -> . evt?)))) +(define dup-output-port + (opt-lambda (p [close? #f]) + (let ([new (transplant-output-port + p + (lambda () (port-next-location p)) + (let-values ([(line col pos) (port-next-location p)]) + (or pos (file-position p))) + close? + (lambda () (port-count-lines! p)))]) + (port-display-handler new (port-display-handler p)) + (port-write-handler new (port-write-handler p)) + new))) + +(define dup-input-port + (opt-lambda (p [close? #f]) + (let ([new (transplant-input-port + p + (lambda () (port-next-location p)) + (let-values ([(line col pos) (port-next-location p)]) + (or pos (file-position p))) + close? + (lambda () (port-count-lines! p)))]) + (port-read-handler new (port-read-handler p)) + new))) + +;; ---------------------------------------- + +(provide open-output-nowhere + make-pipe-with-specials + make-input-port/read-to-peek + peeking-input-port + relocate-input-port + transplant-input-port + relocate-output-port + transplant-output-port + merge-input + copy-port + input-port-append + convert-stream + make-limited-input-port + reencode-input-port + reencode-output-port + dup-input-port + dup-output-port + strip-shell-command-start) + +(provide/contract + (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts? + . -> . evt?)) + (peek-bytes-avail!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false + input-port-with-progress-evts? + . -> . evt?)) + (read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?)) + (peek-bytes!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false + input-port-with-progress-evts? + . -> . evt?)) + (read-bytes-evt (exact-nonnegative-integer? input-port-with-progress-evts? + . -> . evt?)) + (peek-bytes-evt (exact-nonnegative-integer? exact-nonnegative-integer? + evt?/false input-port-with-progress-evts? + . -> . evt?)) + (read-string!-evt (mutable-string? input-port-with-progress-evts? + . -> . evt?)) + (peek-string!-evt (mutable-string? exact-nonnegative-integer? evt?/false + input-port-with-progress-evts? + . -> . evt?)) + (read-string-evt (exact-nonnegative-integer? input-port-with-progress-evts? + . -> . evt?)) + (peek-string-evt (exact-nonnegative-integer? exact-nonnegative-integer? + evt?/false input-port-with-progress-evts? + . -> . evt?)) + (regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?) + input-port-with-progress-evts? + . -> . evt?)) + + (read-bytes-line-evt (case-> (input-port-with-progress-evts? . -> . evt?) + (input-port-with-progress-evts? line-mode-symbol? + . -> . evt?))) + (read-line-evt (case-> (input-port-with-progress-evts? . -> . evt?) + (input-port-with-progress-evts? line-mode-symbol? + . -> . evt?))) + (eof-evt (input-port-with-progress-evts? . -> . evt?))) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 4b4c450d90..a600805fa7 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -199,6 +199,42 @@ [(_ orig-reduction-relation lang args ...) #'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)])) +;; the withs, freshs, and side-conditions come in backwards order +(define-for-syntax (bind-withs orig-name main stx body) + (let loop ([stx stx] + [body body]) + (syntax-case stx (side-condition where fresh) + [() body] + [((where x e) y ...) + (loop #'(y ...) #`(term-let ([x (term e)]) #,body))] + [((side-condition s ...) y ...) + (loop #'(y ...) #`(and s ... #,body))] + [((fresh x) y ...) + (identifier? #'x) + (loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))] + [((fresh x name) y ...) + (identifier? #'x) + (loop #'(y ...) + #`(term-let ([x (let ([the-name (term name)]) + (verify-name-ok '#,orig-name the-name) + (variable-not-in #,main the-name))]) + #,body))] + [((fresh (y) (x ...)) z ...) + (loop #'(z ...) + #`(term-let ([(y #,'...) + (variables-not-in #,main + (map (λ (_ignore_) 'y) + (term (x ...))))]) + #,body))] + [((fresh (y) (x ...) names) z ...) + (loop #'(z ...) + #`(term-let ([(y #,'...) + (let ([the-names (term names)] + [len-counter (term (x ...))]) + (verify-names-ok '#,orig-name the-names len-counter) + (variables-not-in #,main the-names))]) + #,body))]))) + (define-struct successful (result)) (define-syntax-set (do-reduction-relation) @@ -608,42 +644,6 @@ #,(bind-withs orig-name #'main sides/withs/freshs #'(make-successful (term to))))))))))) - ;; the withs, freshs, and side-conditions come in backwards order - (define (bind-withs orig-name main stx body) - (let loop ([stx stx] - [body body]) - (syntax-case stx (side-condition where fresh) - [() body] - [((where x e) y ...) - (loop #'(y ...) #`(term-let ([x (term e)]) #,body))] - [((side-condition s ...) y ...) - (loop #'(y ...) #`(and s ... #,body))] - [((fresh x) y ...) - (identifier? #'x) - (loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))] - [((fresh x name) y ...) - (identifier? #'x) - (loop #'(y ...) - #`(term-let ([x (let ([the-name (term name)]) - (verify-name-ok '#,orig-name the-name) - (variable-not-in #,main the-name))]) - #,body))] - [((fresh (y) (x ...)) z ...) - (loop #'(z ...) - #`(term-let ([(y #,'...) - (variables-not-in #,main - (map (λ (_ignore_) 'y) - (term (x ...))))]) - #,body))] - [((fresh (y) (x ...) names) z ...) - (loop #'(z ...) - #`(term-let ([(y #,'...) - (let ([the-names (term names)] - [len-counter (term (x ...))]) - (verify-names-ok '#,orig-name the-names len-counter) - (variables-not-in #,main the-names))]) - #,body))]))) - (define (process-extras stx orig-name name-table extras) (let ([the-name #f] [the-name-stx #f] @@ -1012,114 +1012,117 @@ (loop name (cdr names))]))]) (with-syntax ([(((tl-side-conds ...) ...) - (tl-bindings ...)) - (extract-side-conditions (syntax-e #'name) stx #'((stuff ...) ...))]) + (tl-bindings ...) + (tl-side-cond/binds ...)) + (parse-extras #'((stuff ...) ...))]) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) - (with-syntax ([(side-conditions-rewritten ...) - (map (λ (x) (rewrite-side-conditions/check-errs - lang-nts - 'define-metafunction - #t - x)) - (syntax->list (syntax ((side-condition lhs (and tl-side-conds ...)) ...))))] - [dom-side-conditions-rewritten - (and dom-ctcs - (rewrite-side-conditions/check-errs - lang-nts - 'define-metafunction - #f - dom-ctcs))] - [codom-side-conditions-rewritten - (rewrite-side-conditions/check-errs - lang-nts - 'define-metafunction - #f - codom-contract)] - [(rhs-fns ...) - (map (λ (lhs rhs bindings) - (let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) - (with-syntax ([(names ...) names] - [(names/ellipses ...) names/ellipses] - [rhs rhs] - [((tl-var tl-exp) ...) bindings]) - (syntax - (λ (name bindings) - (term-let-fn ((name name)) - (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - (term-let ([tl-var (term tl-exp)] ...) - (term rhs))))))))) - (syntax->list (syntax (lhs ...))) - (syntax->list (syntax (rhs ...))) - (syntax->list (syntax (tl-bindings ...))))] - [(name2 name-predicate) (generate-temporaries (syntax (name name)))] - [((side-cond ...) ...) - ;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level - (map (lambda (lhs scs) - (append - (let loop ([lhs lhs]) - (syntax-case lhs (side-condition term) - [(side-condition pat (term sc)) - (cons #'sc (loop #'pat))] - [_else null])) - scs)) - (syntax->list #'(lhs ...)) - (syntax->list #'((tl-side-conds ...) ...)))] - [(((bind-id . bind-pat) ...) ...) - ;; Also for pict, extract pattern bindings - (map extract-pattern-binds (syntax->list #'(lhs ...)))] - [(((rhs-bind-id . rhs-bind-pat) ...) ...) - ;; Also for pict, extract pattern bindings - (map extract-term-let-binds (syntax->list #'(rhs ...)))] - [(((where-id where-pat) ...) ...) - ;; Also for pict, extract where bindings - #'(tl-bindings ...)]) - (syntax-property - #`(begin - (define-values (name2 name-predicate) - (let ([sc `(side-conditions-rewritten ...)] - [dsc `dom-side-conditions-rewritten]) - (build-metafunction - lang - sc - (list rhs-fns ...) - #,(if prev-metafunction - (let ([term-fn (syntax-local-value prev-metafunction)]) - #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) - #''()) - #,(if prev-metafunction - (let ([term-fn (syntax-local-value prev-metafunction)]) - #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) - #''()) - (λ (f/dom cps rhss) - (make-metafunc-proc - (let ([name (lambda (x) (f/dom x))]) name) - (list (list (to-lw lhs-for-lw) - (list (to-lw/uq side-cond) ...) - (list (cons (to-lw bind-id) - (to-lw bind-pat)) - ... - (cons (to-lw rhs-bind-id) - (to-lw/uq rhs-bind-pat)) - ... - (cons (to-lw where-id) - (to-lw where-pat)) - ...) - (to-lw rhs)) - ...) - lang - #t ;; multi-args? - 'name - cps - rhss - (let ([name (lambda (x) (name-predicate x))]) name) - dsc - sc)) - dsc - 'codom-side-conditions-rewritten - 'name))) - (term-define-fn name name2)) - 'disappeared-use - (map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))] + (with-syntax ([(tl-withs ...) (map (λ (sc/b) (bind-withs syn-error-name '() sc/b #t)) + (syntax->list #'(tl-side-cond/binds ...)))]) + (with-syntax ([(side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + 'define-metafunction + #t + x)) + (syntax->list (syntax ((side-condition lhs tl-withs) ...))))] + [dom-side-conditions-rewritten + (and dom-ctcs + (rewrite-side-conditions/check-errs + lang-nts + 'define-metafunction + #f + dom-ctcs))] + [codom-side-conditions-rewritten + (rewrite-side-conditions/check-errs + lang-nts + 'define-metafunction + #f + codom-contract)] + [(rhs-fns ...) + (map (λ (lhs rhs bindings) + (let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) + (with-syntax ([(names ...) names] + [(names/ellipses ...) names/ellipses] + [rhs rhs] + [((tl-var tl-exp) ...) bindings]) + (syntax + (λ (name bindings) + (term-let-fn ((name name)) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + (term-let ([tl-var (term tl-exp)] ...) + (term rhs))))))))) + (syntax->list (syntax (lhs ...))) + (syntax->list (syntax (rhs ...))) + (syntax->list (syntax (tl-bindings ...))))] + [(name2 name-predicate) (generate-temporaries (syntax (name name)))] + [((side-cond ...) ...) + ;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level + (map (lambda (lhs scs) + (append + (let loop ([lhs lhs]) + (syntax-case lhs (side-condition term) + [(side-condition pat (term sc)) + (cons #'sc (loop #'pat))] + [_else null])) + scs)) + (syntax->list #'(lhs ...)) + (syntax->list #'((tl-side-conds ...) ...)))] + [(((bind-id . bind-pat) ...) ...) + ;; Also for pict, extract pattern bindings + (map extract-pattern-binds (syntax->list #'(lhs ...)))] + [(((rhs-bind-id . rhs-bind-pat) ...) ...) + ;; Also for pict, extract pattern bindings + (map extract-term-let-binds (syntax->list #'(rhs ...)))] + [(((where-id where-pat) ...) ...) + ;; Also for pict, extract where bindings + #'(tl-bindings ...)]) + (syntax-property + #`(begin + (define-values (name2 name-predicate) + (let ([sc `(side-conditions-rewritten ...)] + [dsc `dom-side-conditions-rewritten]) + (build-metafunction + lang + sc + (list rhs-fns ...) + #,(if prev-metafunction + (let ([term-fn (syntax-local-value prev-metafunction)]) + #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) + #''()) + #,(if prev-metafunction + (let ([term-fn (syntax-local-value prev-metafunction)]) + #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) + #''()) + (λ (f/dom cps rhss) + (make-metafunc-proc + (let ([name (lambda (x) (f/dom x))]) name) + (list (list (to-lw lhs-for-lw) + (list (to-lw/uq side-cond) ...) + (list (cons (to-lw bind-id) + (to-lw bind-pat)) + ... + (cons (to-lw rhs-bind-id) + (to-lw/uq rhs-bind-pat)) + ... + (cons (to-lw where-id) + (to-lw where-pat)) + ...) + (to-lw rhs)) + ...) + lang + #t ;; multi-args? + 'name + cps + rhss + (let ([name (lambda (x) (name-predicate x))]) name) + dsc + sc)) + dsc + 'codom-side-conditions-rewritten + 'name))) + (term-define-fn name name2)) + 'disappeared-use + (map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))] [(_ prev-metafunction name lang clauses ...) (begin (unless (identifier? #'name) @@ -1199,31 +1202,38 @@ (syntax->list #'(x ...))) (raise-syntax-error syn-error-name "error checking failed.2" stx))])) - (define (extract-side-conditions name stx stuffs) - (let loop ([stuffs (syntax->list stuffs)] + (define (parse-extras extras) + (let loop ([stuffs (syntax->list extras)] [side-conditionss '()] - [bindingss '()]) + [bindingss '()] + [bothss '()]) (cond [(null? stuffs) (list (reverse side-conditionss) - (reverse bindingss))] + (reverse bindingss) + (reverse bothss))] [else (let s-loop ([stuff (syntax->list (car stuffs))] [side-conditions '()] - [bindings '()]) + [bindings '()] + [boths '()]) (cond [(null? stuff) (loop (cdr stuffs) (cons (reverse side-conditions) side-conditionss) - (cons (reverse bindings) bindingss))] + (cons (reverse bindings) bindingss) + ; Want these in reverse order. + (cons boths bothss))] [else (syntax-case (car stuff) (where side-condition) [(side-condition tl-side-conds ...) (s-loop (cdr stuff) (append (syntax->list #'(tl-side-conds ...)) side-conditions) - bindings)] + bindings + (cons (car stuff) boths))] [(where x e) (s-loop (cdr stuff) side-conditions - (cons #'(x e) bindings))] + (cons #'(x e) bindings) + (cons (car stuff) boths))] [_ (raise-syntax-error 'define-metafunction "expected a side-condition or where clause" diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 6658379577..499b63e387 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -820,11 +820,13 @@ ; check-metafunction (let () (define-language empty) + (define-metafunction empty [(m 1) whatever] [(m 2) whatever]) (define-metafunction empty [(n (side-condition any #f)) any]) + (let ([generated null]) (test (begin (output @@ -832,6 +834,20 @@ (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1))) generated) (reverse '((1) (2))))) + + (test + (let/ec k + (define-language L (n 2)) + (define-metafunction L + [(f n) + n + (where number_2 ,(add1 (term n))) + (where number_3 ,(add1 (term number_2))) + (side-condition (k (term number_3)))] + [(f any) 0]) + (check-metafunction f (λ (_) #t))) + 4) + (test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples") (test (output (λ () (check-metafunction m (curry eq? 1)))) #rx"check-metafunction:.*counterexample found after 1 attempt with clause #1") diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index 969de8825b..71d95807a7 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -482,6 +482,17 @@ (test (term (f z)) (term ((z z) (z z))))) + (let () + (define-metafunction empty-language + [(f number_1) + number_1 + (where number_2 ,(add1 (term number_1))) + (where number_3 ,(add1 (term number_2))) + (side-condition (and (number? (term number_3)) + (= (term number_3) 4)))] + [(f any) 0]) + (test (term (f 2)) 2)) + (let () (define-language x-lang (x variable)) diff --git a/collects/schemeunit/test-suite-test.ss b/collects/schemeunit/test-suite-test.ss index 99870dd8ce..5a15acd01a 100644 --- a/collects/schemeunit/test-suite-test.ss +++ b/collects/schemeunit/test-suite-test.ss @@ -35,6 +35,35 @@ (check-exn exn:fail:contract? (lambda () (test-suite (check = 1 1))))) + + (test-case + "make-test-suite" + (let* ([before? #f] + [after? #f] + [ran? #f] + [results + (run-test + (make-test-suite + "dummy1" + (list + (make-test-case + "dummy-test-1" + (lambda () (check-true #t))) + (make-test-suite + "dummy2" + #:before (lambda () (set! before? #t)) + #:after (lambda () (set! after? #t)) + (list + (make-test-case + "dummy-test-2" + (lambda () + (set! ran? #t) + (check-true #t))))))))]) + (check-equal? (length results) 2) + (map (lambda (r) (check-pred test-success? r)) results) + (check-true before?) + (check-true after?) + (check-true ran?))) )) diff --git a/collects/schemeunit/test-suite.ss b/collects/schemeunit/test-suite.ss index da39ff4cd7..1d4eb1337c 100644 --- a/collects/schemeunit/test-suite.ss +++ b/collects/schemeunit/test-suite.ss @@ -10,7 +10,8 @@ test-suite-test-case-around test-suite-check-around delay-test - + make-test-suite + apply-test-suite define-test-suite @@ -124,6 +125,38 @@ #:after void-thunk test ...))])) +(define (tests->test-suite-action tests) + (lambda (fdown fup fhere seed) + (parameterize + ([current-seed seed]) + (for-each + (lambda (t) + (cond + [(schemeunit-test-suite? t) + (current-seed (apply-test-suite t fdown fup fhere (current-seed)))] + [(schemeunit-test-case? t) + (current-seed + (fhere t + (schemeunit-test-case-name t) + (schemeunit-test-case-action t) + (current-seed)))] + [else + (raise + (make-exn:test + (format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests) + (current-continuation-marks)))])) + tests) + (current-seed)))) + +;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite? +;; +;; Construct a test suite from a list of tests +(define (make-test-suite name #:before [before void-thunk] #:after [after void-thunk] tests) + (make-schemeunit-test-suite name + (tests->test-suite-action tests) + before + after)) + ;; ;; Shortcut helpers ;; diff --git a/collects/schemeunit/test-test.ss b/collects/schemeunit/test-test.ss index 5706275866..0511bb1d2b 100644 --- a/collects/schemeunit/test-test.ss +++ b/collects/schemeunit/test-test.ss @@ -281,5 +281,13 @@ check-info? check-info-name check-info-value) + + (test-case + "make-test-case constructs a test case" + (check-pred + test-success? + (car + (run-test + (make-test-case "dummy" (lambda () (check-true #t))))))) )) \ No newline at end of file diff --git a/collects/schemeunit/test.ss b/collects/schemeunit/test.ss index 4f409f364f..9f82130467 100644 --- a/collects/schemeunit/test.ss +++ b/collects/schemeunit/test.ss @@ -41,8 +41,10 @@ test-begin test-case test-suite + make-test-suite delay-test - (rename-out [schemeunit-test-case? test-case?] + (rename-out [make-schemeunit-test-case make-test-case] + [schemeunit-test-case? test-case?] [schemeunit-test-suite? test-suite?]) define-test-suite diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index d514f24f29..3be83de0db 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -20,7 +20,7 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib], @section{Unsafe Library Functions} @defproc[(ffi-lib [path (or/c path-string? #f)] - [version (or/c string? (listof string?) #f) #f]) any]{ + [version (or/c string? (listof (or/c string? #f)) #f) #f]) any]{ Returns an foreign-library value. If @scheme[path] is a path, the result represents the foreign library, which is opened in an @@ -29,14 +29,15 @@ OS-specific way (using @cpp{LoadLibrary} under Windows, and The path is not expected to contain the library suffix, which is added according to the current platform. If adding the suffix fails, -several other filename variations are tried --- retrying without an +several other filename variations are tried: retrying without an automatically added suffix, and using a full path of a file if it exists relative to the current directory (since the OS-level library function usually searches, unless the library name is an absolute path). An optional @scheme[version] string can be supplied, which is -appended to the name after any added suffix. If you need any of a few -possible versions, use a list of version strings, and @scheme[ffi-lib] -will try all of them. +appended to the name before or after the suffix, depending on platform +conventions, unless it is @scheme[#f] or @scheme[""]. If +@scheme[version] is a list, @scheme[ffi-lib] will try each of them in +order. If @scheme[path] is @scheme[#f], then the resulting foreign-library value represents all libraries loaded in the current process, @@ -45,10 +46,12 @@ particular, use @scheme[#f] to access C-level functionality exported by the run-time system (as described in @|InsideMzScheme|). Note: @scheme[ffi-lib] tries to look for the library file in a few -places like the PLT libraries (see @scheme[get-lib-search-dirs]), a -relative path, or a system search. However, if @cpp{dlopen} cannot -open a library, there is no reliable way to know why it failed, so if -all path combinations fail, it will raise an error with the result of +places, inluding the PLT libraries (see @scheme[get-lib-search-dirs]), +a relative path, or a system search. When @scheme[version] is a list, +different versions are tried through each route before continuing the +search with other routes. However, if @cpp{dlopen} cannot open a +library, there is no reliable way to know why it failed, so if all +path combinations fail, it will raise an error with the result of @cpp{dlopen} on the unmodified argument name. For example, if you have a local @filepath{foo.so} library that cannot be loaded because of a missing symbol, using @scheme[(ffi-lib "foo.so")] will fail with diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index fb24bba59c..7616f4254f 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1663,7 +1663,7 @@ Returns @scheme[#t] if @scheme[v] is an interface, @scheme[#f] otherwise.} Returns @scheme[#t] if @scheme[v] is a @tech{generic}, @scheme[#f] otherwise.} -@defproc[(object=? [a object?][b object?]) eq?]{ +@defproc[(object=? [a object?] [b object?]) boolean?]{ Determines if two objects are the same object, or not; this procedure uses @scheme[eq?], but also works properly with contracts.} @@ -1745,7 +1745,6 @@ not including fields whose names are local (i.e., declared with Returns two values, analogous to the return values of @scheme[struct-info]: -K% @itemize[ @item{@scheme[class]: a class or @scheme[#f]; the result is diff --git a/collects/sgl/gl.ss b/collects/sgl/gl.ss index 3be4084225..8f377ae9ae 100644 --- a/collects/sgl/gl.ss +++ b/collects/sgl/gl.ss @@ -10,11 +10,11 @@ (define gl-lib (case stype [(windows) (ffi-lib "opengl32")] [(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL")] - [else (ffi-lib "libGL")])) + [else (ffi-lib "libGL" '("1" ""))])) (define glu-lib (case stype [(windows) (ffi-lib "glu32")] [(macosx) (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGLU")] - [else (ffi-lib "libGLU")])) + [else (ffi-lib "libGLU" '("1" ""))])) (define (unavailable name) (lambda () (lambda x (error name "unavailable on this system")))) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 4b205b87af..24022e8808 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -694,6 +694,36 @@ (define (q x) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) +(let ([check (lambda (proc arities non-arities) + (test-comp `(module m scheme/base + (define f ,proc) + (print (procedure? f))) + `(module m scheme/base + (define f ,proc) + (print #t))) + (for-each + (lambda (a) + (test-comp `(module m scheme/base + (define f ,proc) + (print (procedure-arity-includes? f ,a))) + `(module m scheme/base + (define f ,proc) + (print #t)))) + arities) + (for-each + (lambda (a) + (test-comp `(module m scheme/base + (define f ,proc) + (print (procedure-arity-includes? f ,a))) + `(module m scheme/base + (define f ,proc) + (print #f)))) + non-arities))]) + (check '(lambda (x) x) '(1) '(0 2)) + (check '(lambda (x . y) x) '(1 2 3) '(0)) + (check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3)) + (check '(lambda (x [y #f]) y) '(1 2) '(0 3))) + (let ([test-dropped (lambda (cons-name . args) (test-comp `(let ([x 5]) diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index c4a7b5efe3..b94ac3a048 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -1,6 +1,7 @@ #lang scheme (require net/url web-server/http + web-server/http/bindings web-server/dispatch web-server/stuffers web-server/lang/abort-resume @@ -11,6 +12,7 @@ (provide (except-out (all-from-out scheme) #%module-begin) (all-from-out net/url web-server/http + web-server/http/bindings web-server/dispatch web-server/stuffers web-server/lang/abort-resume diff --git a/collects/web-server/scribblings/cache-table.scrbl b/collects/web-server/scribblings/cache-table.scrbl index 6c6512c7b5..e798dfa645 100644 --- a/collects/web-server/scribblings/cache-table.scrbl +++ b/collects/web-server/scribblings/cache-table.scrbl @@ -6,7 +6,7 @@ @defmodule[web-server/private/cache-table]{ -@filepath{private/cache-table.ss} provides a set of caching hash table +This module provides a set of caching hash table functions. @defproc[(make-cache-table) diff --git a/collects/web-server/scribblings/connection-manager.scrbl b/collects/web-server/scribblings/connection-manager.scrbl index 83dceed0f2..434b4db8b4 100644 --- a/collects/web-server/scribblings/connection-manager.scrbl +++ b/collects/web-server/scribblings/connection-manager.scrbl @@ -7,7 +7,7 @@ @defmodule[web-server/private/connection-manager]{ -@filepath{private/connection-manager.ss} provides functionality for managing pairs of +This module provides functionality for managing pairs of input and output ports. We have plans to allow a number of different strategies for doing this. diff --git a/collects/web-server/scribblings/contracts.scrbl b/collects/web-server/scribblings/contracts.scrbl index 5a4174860b..a4fed490a8 100644 --- a/collects/web-server/scribblings/contracts.scrbl +++ b/collects/web-server/scribblings/contracts.scrbl @@ -7,7 +7,7 @@ @defmodule[web-server/servlet/servlet-structs]{ -@filepath{servlet/servlet-structs.ss} provides a number of contracts +This module provides a number of contracts for use in servlets. @defthing[k-url? contract?]{ diff --git a/collects/web-server/scribblings/ctable-structs.scrbl b/collects/web-server/scribblings/ctable-structs.scrbl index c796b293e6..d9f97ebe50 100644 --- a/collects/web-server/scribblings/ctable-structs.scrbl +++ b/collects/web-server/scribblings/ctable-structs.scrbl @@ -9,7 +9,7 @@ @defmodule[web-server/configuration/configuration-table-structs]{ -@filepath{configuration/configuration-table-structs.ss} provides the following structures that +This module provides the following structures that represent a standard configuration (see @secref["web-server-unit.ss"]) of the @web-server . The contracts on this structure influence the valid types of values in the configuration table S-expression file format described in diff --git a/collects/web-server/scribblings/ctable.scrbl b/collects/web-server/scribblings/ctable.scrbl index 162560a514..0366511a90 100644 --- a/collects/web-server/scribblings/ctable.scrbl +++ b/collects/web-server/scribblings/ctable.scrbl @@ -8,7 +8,7 @@ @defmodule[web-server/configuration/configuration-table]{ -@filepath{configuration/configuration-table.ss} provides functions for +This module provides functions for reading, writing, parsing, and printing @scheme[configuration-table] structures. diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 9f323f00c3..574ebab182 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -27,7 +27,7 @@ documentation. @defmodule[web-server/dispatchers/dispatch]{ -@filepath{dispatchers/dispatch.ss} provides a few functions for dispatchers in general. +This module provides a few functions for dispatchers in general. @defthing[dispatcher/c contract?]{ Equivalent to @scheme[(connection? request? . -> . void)]. @@ -74,7 +74,7 @@ Consider the following example dispatcher, that captures the essence of URL rewr @defmodule[web-server/dispatchers/filesystem-map]{ -@filepath{dispatchers/filesystem-map.ss} provides a means of mapping +This module provides a means of mapping URLs to paths on the filesystem. @defthing[url->path/c contract?]{ diff --git a/collects/web-server/scribblings/file-box.scrbl b/collects/web-server/scribblings/file-box.scrbl index 10e1060936..31fe9747c4 100644 --- a/collects/web-server/scribblings/file-box.scrbl +++ b/collects/web-server/scribblings/file-box.scrbl @@ -9,7 +9,7 @@ As mentioned earlier, it is dangerous to rely on the store in Web Language servlets, due to the deployment scenarios available -to them. @filepath{lang/file-box.ss} provides a simple API to replace +to them. This module provides a simple API to replace boxes in a safe way. @defproc[(file-box? [v any/c]) diff --git a/collects/web-server/scribblings/lang-api.scrbl b/collects/web-server/scribblings/lang-api.scrbl index 07883b7c24..16757de287 100644 --- a/collects/web-server/scribblings/lang-api.scrbl +++ b/collects/web-server/scribblings/lang-api.scrbl @@ -45,6 +45,7 @@ An example @scheme['stateless] servlet module: These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http], +@schememodname[web-server/http/bindings], @schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/web-param], @schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and @schememodname[web-server/stuffers]. diff --git a/collects/web-server/scribblings/managers.scrbl b/collects/web-server/scribblings/managers.scrbl index 645e017ae9..d7e8eaa0aa 100644 --- a/collects/web-server/scribblings/managers.scrbl +++ b/collects/web-server/scribblings/managers.scrbl @@ -17,7 +17,7 @@ pluggable through the manager interface. @defmodule[web-server/managers/manager]{ -@filepath{managers/manager.ss} defines the manager interface. It is required by +This module defines the manager interface. It is required by the users and implementers of managers. @defstruct[manager ([create-instance ((-> void) . -> . number?)] @@ -65,7 +65,7 @@ the users and implementers of managers. @defmodule[web-server/managers/none]{ -@filepath{managers/none.ss} defines a manager constructor: +This module defines a manager constructor: @defproc[(create-none-manager (instance-expiration-handler expiration-handler/c)) manager?]{ @@ -90,7 +90,7 @@ Web Language. (See @secref["stateless"].) @defmodule[web-server/managers/timeouts]{ -@filepath{managers/timeouts.ss} defines a manager constructor: +This module defines a manager constructor: @defproc[(create-timeout-manager [instance-exp-handler expiration-handler/c] [instance-timeout number?] @@ -122,7 +122,7 @@ deployments of the @web-server . @defmodule[web-server/managers/lru]{ -@filepath{managers/lru.ss} defines a manager constructor: +This module defines a manager constructor: @defproc[(create-LRU-manager [instance-expiration-handler expiration-handler/c] diff --git a/collects/web-server/scribblings/mime-types.scrbl b/collects/web-server/scribblings/mime-types.scrbl index c911b77412..f7325b8aab 100644 --- a/collects/web-server/scribblings/mime-types.scrbl +++ b/collects/web-server/scribblings/mime-types.scrbl @@ -6,7 +6,7 @@ @defmodule[web-server/private/mime-types]{ -@filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types} +This module provides function for dealing with @filepath{mime.types} files. @defproc[(read-mime-types [p path-string?]) diff --git a/collects/web-server/scribblings/mod-map.scrbl b/collects/web-server/scribblings/mod-map.scrbl index 7e7fcc1bfc..3306450f0f 100644 --- a/collects/web-server/scribblings/mod-map.scrbl +++ b/collects/web-server/scribblings/mod-map.scrbl @@ -7,7 +7,7 @@ @defmodule[web-server/private/mod-map]{ The @schememodname[scheme/serialize] library provides the -functionality of serializing values. @filepath{private/mod-map.ss} +functionality of serializing values. This module compresses the serialized representation. @defproc[(compress-serial [sv list?]) diff --git a/collects/web-server/scribblings/namespace.scrbl b/collects/web-server/scribblings/namespace.scrbl index f49d1f67e3..bfe4b6fc8e 100644 --- a/collects/web-server/scribblings/namespace.scrbl +++ b/collects/web-server/scribblings/namespace.scrbl @@ -6,9 +6,9 @@ @defmodule[web-server/configuration/namespace]{ -@filepath{configuration/namespace.ss} provides a function to help create the -@scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions -of @filepath{dispatchers/dispatch-servlets.ss} and @filepath{dispatchers/dispatch-lang.ss}. +This module provides a function to help create the +@scheme[make-servlet-namespace] procedure needed by the @scheme[make] function +of @schememodname[web-server/dispatchers/dispatch-servlets]. @defthing[make-servlet-namespace/c contract?]{ Equivalent to diff --git a/collects/web-server/scribblings/responders.scrbl b/collects/web-server/scribblings/responders.scrbl index 27d35c5622..03cb9d7226 100644 --- a/collects/web-server/scribblings/responders.scrbl +++ b/collects/web-server/scribblings/responders.scrbl @@ -8,7 +8,7 @@ @defmodule[web-server/configuration/responders]{ -@filepath{configuration/responders.ss} provides some functions that help constructing HTTP responders. +This module provides some functions that help constructing HTTP responders. These functions are used by the default dispatcher constructor (see @secref["web-server-unit.ss"]) to turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance. diff --git a/collects/web-server/scribblings/stateless-usage.scrbl b/collects/web-server/scribblings/stateless-usage.scrbl index 2ba76f61ff..3ae1a7ea6b 100644 --- a/collects/web-server/scribblings/stateless-usage.scrbl +++ b/collects/web-server/scribblings/stateless-usage.scrbl @@ -6,19 +6,17 @@ A servlet has the following process performed on it automatically: @itemize[ @item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of - @scheme[let] and imperative features. (@filepath{lang/elim-letrec.ss})} + @scheme[let] and imperative features.} @item{The program is converted into ANF (Administrative Normal Form), - making all continuations explicit. (@filepath{lang/anormal.ss})} + making all continuations explicit.} @item{All continuations (and other continuations marks) are recorded in the continuation marks of the expression - they are the continuation of. (@filepath{lang/elim-callcc.ss})} - @item{All calls to external modules are identified and marked. - (@filepath{lang/elim-callcc.ss})} + they are the continuation of.} + @item{All calls to external modules are identified and marked.} @item{All uses of @scheme[call/cc] are removed and replaced with - equivalent gathering of the continuations through the continuation-marks. - (@filepath{lang/elim-callcc.ss})} + equivalent gathering of the continuations through the continuation-marks.} @item{The program is defunctionalized with a serializable data-structure for each - anonymous lambda. (@filepath{lang/defun.ss})} + anonymous lambda.} ] This process allows the continuations captured by your servlet to be serialized. diff --git a/collects/web-server/scribblings/timer.scrbl b/collects/web-server/scribblings/timer.scrbl index 9532a4c384..098b0fe38d 100644 --- a/collects/web-server/scribblings/timer.scrbl +++ b/collects/web-server/scribblings/timer.scrbl @@ -6,7 +6,7 @@ @defmodule[web-server/private/timer]{ -@filepath{private/timer.ss} provides a functionality for running +This module provides a functionality for running procedures after a given amount of time, that may be extended. @defstruct[timer ([evt evt?] diff --git a/collects/web-server/scribblings/url-param.scrbl b/collects/web-server/scribblings/url-param.scrbl index 4e2a7279c9..e1fd11094d 100644 --- a/collects/web-server/scribblings/url-param.scrbl +++ b/collects/web-server/scribblings/url-param.scrbl @@ -10,7 +10,7 @@ The @web-server needs to encode information in URLs. If this data is stored in the query string, than it will be overridden by browsers that make GET requests to those URLs with more query data. So, it must be encoded -in URL params. @filepath{private/url-param.ss} provides functions for helping +in URL params. This module provides functions for helping with this process. @defproc[(insert-param [u url?] diff --git a/collects/web-server/scribblings/util.scrbl b/collects/web-server/scribblings/util.scrbl index 58a748d839..c71446be23 100644 --- a/collects/web-server/scribblings/util.scrbl +++ b/collects/web-server/scribblings/util.scrbl @@ -10,7 +10,7 @@ @defmodule[web-server/private/util] There are a number of other miscellaneous utilities the @web-server -needs. They are provided by @filepath{private/util.ss}. +needs. They are provided by this module. @section{Contracts} @defthing[non-empty-string/c contract?]{Contract for non-empty strings.} diff --git a/collects/web-server/scribblings/web-param.scrbl b/collects/web-server/scribblings/web-param.scrbl index e6365d82f5..ab0639d790 100644 --- a/collects/web-server/scribblings/web-param.scrbl +++ b/collects/web-server/scribblings/web-param.scrbl @@ -7,7 +7,7 @@ @defmodule[web-server/lang/web-param]{ It is not easy to use @scheme[parameterize] in the -Web Language. @filepath{lang/web-param.ss} provides (roughly) the same +Web Language. This module provides (roughly) the same functionality in a way that is serializable. Like other serializable things in the Web Language, they are sensitive to source code modification. From 9f3d719b4eed1f835372f63f71bdfdc837a199cc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 20:26:27 +0000 Subject: [PATCH 099/156] Fix parsing of All to only use parse-values-type when appropriate. Fix tests for new names. Fix tests for parse-type not handling values. svn: r14752 --- .../unit-tests/parse-type-tests.ss | 10 ++-- .../unit-tests/remove-intersect-tests.ss | 46 ++++++++-------- .../unit-tests/type-equal-tests.ss | 22 ++++---- collects/typed-scheme/private/parse-type.ss | 54 ++++++++++--------- 4 files changed, 71 insertions(+), 61 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index 35b5561854..c451af0bb4 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -55,6 +55,10 @@ (test-suite nm (pt-test elems ...) ...)])) +(define N -Number) +(define B -Boolean) +(define Sym -Symbol) + (define (parse-type-tests) (pt-tests "parse-type tests" @@ -65,7 +69,7 @@ [(Listof Boolean) (make-Listof B)] [(Vectorof (Listof Symbol)) (make-Vector (make-Listof Sym))] [(pred Number) (make-pred-ty N)] - [(values Number Boolean Number) (-values (list N B N))] + [(-> (values Number Boolean Number)) (t:-> (-values (list N B N)))] [(Number -> Number) (t:-> N N)] [(Number -> Number) (t:-> N N)] [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)] @@ -80,8 +84,8 @@ [(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(All (a ...) (a ... -> Number)) (-polydots (a) ((list) [a a] . ->... . N))] - [(All (a ...) (values a ...)) - (-polydots (a) (make-ValuesDots (list) a 'a))] + [(All (a ...) (-> (values a ...))) + (-polydots (a) (t:-> (make-ValuesDots (list) a 'a)))] [(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(N N) N])] [1 (-val 1)] diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index 53b99e223f..95fc97fc2e 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -15,15 +15,15 @@ (define (restrict-tests) (restr-tests - [N (Un N Sym) N] - [N N N] - [(Un (-val 'foo) (-val 6)) (Un N Sym) (Un (-val 'foo) (-val 6))] - [N (-mu a (Un N Sym (make-Listof a))) N] - [(Un N B) (-mu a (Un N Sym (make-Listof a))) N] - [(-mu x (Un N (make-Listof x))) (Un Sym N B) N] - [(Un N -String Sym B) N N] + [-Number (Un -Number -Symbol) -Number] + [-Number -Number -Number] + [(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un (-val 'foo) (-val 6))] + [-Number (-mu a (Un -Number -Symbol (make-Listof a))) -Number] + [(Un -Number -Boolean) (-mu a (Un -Number -Symbol (make-Listof a))) -Number] + [(-mu x (Un -Number (make-Listof x))) (Un -Symbol -Number -Boolean) -Number] + [(Un -Number -String -Symbol -Boolean) -Number -Number] - [(-lst N) (-pair Univ Univ) (-pair N (-lst N))] + [(-lst -Number) (-pair Univ Univ) (-pair -Number (-lst -Number))] ;; FIXME #; [-Listof -Sexp (-lst (Un B N -String Sym))] @@ -40,18 +40,18 @@ (define (remove-tests) (remo-tests - [(Un N Sym) N Sym] - [N N (Un)] - [(-mu x (Un N Sym (make-Listof x))) N (Un Sym (make-Listof (-mu x (Un N Sym (make-Listof x)))))] - [(-mu x (Un N Sym B (make-Listof x))) N (Un Sym B (make-Listof (-mu x (Un N Sym B (make-Listof x)))))] - [(Un (-val #f) (-mu x (Un N Sym (make-Listof (-v x))))) - (Un B N) - (Un Sym (make-Listof (-mu x (Un N Sym (make-Listof x)))))] - [(Un (-val 'foo) (-val 6)) (Un N Sym) (Un)] - [(-> (Un Sym N) N) (-> N N) (Un)] - [(Un (-poly (a) (make-Listof a)) (-> N N)) (-> N N) (-poly (a) (make-Listof a))] - [(Un Sym N) (-poly (a) N) Sym] - [(-pair N (-v a)) (-pair Univ Univ) (Un)] + [(Un -Number -Symbol) -Number -Symbol] + [-Number -Number (Un)] + [(-mu x (Un -Number -Symbol (make-Listof x))) -Number (Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))] + [(-mu x (Un -Number -Symbol -Boolean (make-Listof x))) -Number (Un -Symbol -Boolean (make-Listof (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))))] + [(Un (-val #f) (-mu x (Un -Number -Symbol (make-Listof (-v x))))) + (Un -Boolean -Number) + (Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))] + [(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un)] + [(-> (Un -Symbol -Number) -Number) (-> -Number -Number) (Un)] + [(Un (-poly (a) (make-Listof a)) (-> -Number -Number)) (-> -Number -Number) (-poly (a) (make-Listof a))] + [(Un -Symbol -Number) (-poly (a) -Number) -Symbol] + [(-pair -Number (-v a)) (-pair Univ Univ) (Un)] )) (define-go @@ -62,11 +62,11 @@ (-mu list-rec (Un (-val '()) - (-pair (-mu x (Un B N -String Sym (-val '()) (-pair x x))) + (-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x))) list-rec)))) (define x2 (Un (-val '()) - (-pair (-mu x (Un B N -String Sym (-val '()) (-pair x x))) - (-mu x (Un B N -String Sym (-val '()) (-pair x x)))))) + (-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x))) + (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))))) (provide remove-tests restrict-tests) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 2a2625d943..57aaa47822 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -26,21 +26,21 @@ (define (type-equal-tests) (te-tests - [N N] - [(Un N) N] - [(Un N Sym B) (Un N B Sym)] - [(Un N Sym B) (Un Sym B N)] - [(Un N Sym B) (Un Sym N B)] - [(Un N Sym B) (Un B (Un Sym N))] - [(Un N Sym) (Un Sym N)] - [(-poly (x) (-> (Un Sym N) x)) (-poly (xyz) (-> (Un N Sym) xyz))] - [(-mu x (Un N Sym x)) (-mu y (Un N Sym y))] + [-Number -Number] + [(Un -Number) -Number] + [(Un -Number -Symbol -Boolean) (Un -Number -Boolean -Symbol)] + [(Un -Number -Symbol -Boolean) (Un -Symbol -Boolean -Number)] + [(Un -Number -Symbol -Boolean) (Un -Symbol -Number -Boolean)] + [(Un -Number -Symbol -Boolean) (Un -Boolean (Un -Symbol -Number))] + [(Un -Number -Symbol) (Un -Symbol -Number)] + [(-poly (x) (-> (Un -Symbol -Number) x)) (-poly (xyz) (-> (Un -Number -Symbol) xyz))] + [(-mu x (Un -Number -Symbol x)) (-mu y (Un -Number -Symbol y))] ;; found bug [FAIL (Un (-mu heap-node - (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))))) + (-struct 'heap-node #f (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))))) (-base 'heap-empty)) (Un (-mu heap-node - (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))))) + (-struct 'heap-node #f (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty))))) (-base 'heap-empty))])) (define-go diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 0818d2a574..b72a67c4a4 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -278,6 +278,27 @@ (parameterize ([current-orig-stx stx]) (parse/get stx t type))) +(define (parse-all-type stx parse-type) + (syntax-parse stx + [(All (vars ... v dd) t) + #:when (eq? (syntax-e #'dd) '...) + #:when (andmap identifier? (syntax->list #'(v vars ...))) + (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] + [tvars (map make-F vars)] + [v (syntax-e #'v)] + [tv (make-Dotted (make-F v))]) + (add-type-name-reference #'All) + (parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))]) + (make-PolyDots (append vars (list v)) (parse-type #'t))))] + [(All (vars ...) t) + #:when (andmap identifier? (syntax->list #'(vars ...))) + (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] + [tvars (map make-F vars)]) + (add-type-name-reference #'All) + (parameterize ([current-tvars (extend-env vars tvars (current-tvars))]) + (make-Poly vars (parse-type #'t))))] + [(All . rest) (tc-error "All: bad syntax")])) + (define (parse-type stx) (parameterize ([current-orig-stx stx]) (syntax-case* stx () @@ -423,27 +444,10 @@ [(quot t) (eq? (syntax-e #'quot) 'quote) (-val (syntax-e #'t))] - [(All (vars ... v dd) t) - (and (or (eq? (syntax-e #'All) 'All) - (eq? (syntax-e #'All) '∀)) - (eq? (syntax-e #'dd) '...) - (andmap identifier? (syntax->list #'(v vars ...)))) - (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] - [tvars (map make-F vars)] - [v (syntax-e #'v)] - [tv (make-Dotted (make-F v))]) - (add-type-name-reference #'All) - (parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))]) - (make-PolyDots (append vars (list v)) (parse-values-type #'t))))] - [(All (vars ...) t) - (and (or (eq? (syntax-e #'All) 'All) - (eq? (syntax-e #'All) '∀)) - (andmap identifier? (syntax->list #'(vars ...)))) - (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] - [tvars (map make-F vars)]) - (add-type-name-reference #'All) - (parameterize ([current-tvars (extend-env vars tvars (current-tvars))]) - (make-Poly vars (parse-values-type #'t))))] + [(All . rest) + (or (eq? (syntax-e #'All) 'All) + (eq? (syntax-e #'All) '∀)) + (parse-all-type stx parse-type)] [(Opaque p?) (eq? (syntax-e #'Opaque) 'Opaque) (begin @@ -487,9 +491,7 @@ Err] [else (tc-error/delayed "Unbound type name ~a" (syntax-e #'id)) - Err])] - - [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] + Err])] [(Opaque . rest) (eq? (syntax-e #'Opaque) 'Opqaue) (tc-error "Opaque: bad syntax")] [(U . rest) (eq? (syntax-e #'U) 'U) (tc-error "Union: bad syntax")] [(Vectorof . rest) (eq? (syntax-e #'Vectorof) 'Vectorof) (tc-error "Vectorof: bad syntax")] @@ -562,6 +564,10 @@ [(values tys ...) #:when (eq? (syntax-e #'values) 'values) (-values (map parse-type (syntax->list #'(tys ...))))] + [(All . rest) + #:when (or (eq? (syntax-e #'All) 'All) + (eq? (syntax-e #'All) '∀)) + (parse-all-type stx parse-values-type)] [t (-values (list (parse-type #'t)))]))) From dcc2ff72d9ba3f2fb21c1485cc86c59246be9dae Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 21:38:30 +0000 Subject: [PATCH 100/156] all tests now compile svn: r14753 --- .../typed-scheme/unit-tests/all-tests.ss | 2 +- .../typed-scheme/unit-tests/infer-tests.ss | 4 +- .../unit-tests/parse-type-tests.ss | 1 + .../typed-scheme/unit-tests/subst-tests.ss | 12 +-- .../unit-tests/type-annotation-test.ss | 29 +++---- .../unit-tests/typecheck-tests.ss | 80 ++++++++++--------- 6 files changed, 69 insertions(+), 59 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 32f70592d1..9821f9c72d 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -3,7 +3,7 @@ (require "test-utils.ss" "planet-requires.ss" - ;"typecheck-tests.ss" ;; doesn't compile yet + "typecheck-tests.ss" ;; doesn't compile yet "subtype-tests.ss" ;; pass "type-equal-tests.ss" ;; pass "remove-intersect-tests.ss" ;; pass diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index 8bcbd305a3..5159f9baee 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -18,7 +18,7 @@ (define (fv-tests) (test-suite "Tests for fv" - (fv-t N) + (fv-t -Number) [fv-t (-v a) a] [fv-t (-poly (a) a)] [fv-t (-poly (a b c d e) a)] @@ -27,7 +27,7 @@ [fv-t (-mu a (-lst a))] [fv-t (-mu a (-lst (-pair a (-v b)))) b] - [fv-t (->* null (-v a) N) a] ;; check that a is CONTRAVARIANT + [fv-t (->* null (-v a) -Number) a] ;; check that a is CONTRAVARIANT )) (define-syntax-rule (i2-t t1 t2 (a b) ...) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index c451af0bb4..0c6de8152f 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -102,6 +102,7 @@ )) +;; FIXME - add tests for parse-values-type, parse-tc-results (define-go parse-type-tests) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 02a018c787..c51fad89d1 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -13,12 +13,12 @@ (define (subst-tests) (test-suite "Tests for substitution" - (s N a (-v a) N) - (s... (N B) a (make-Function (list (make-arr-dots null N (-v a) 'a))) (N B . -> . N)) - (s... (N B) a (make-Function (list (make-arr-dots (list -String) N (-v a) 'a))) (-String N B . -> . N)) - (s... (N B) a (make-Function (list (make-arr-dots (list -String) N (-v b) 'a))) (-String (-v b) (-v b) . -> . N)) - (s... (N B) a (make-Function (list (make-arr-dots (list -String) N (-v b) 'b))) - (make-Function (list (make-arr-dots (list -String) N (-v b) 'b)))))) + (s -Number a (-v a) -Number) + (s... (-Number -Boolean) a (make-Function (list (make-arr-dots null -Number (-v a) 'a))) (-Number -Boolean . -> . -Number)) + (s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v a) 'a))) (-String -Number -Boolean . -> . -Number)) + (s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'a))) (-String (-v b) (-v b) . -> . -Number)) + (s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b))) + (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b)))))) (define-go subst-tests) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 12992f649c..76de434647 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (private type-annotation parse-type base-types) - (types convenience) + (types convenience utils) (env type-environments type-name-env init-envs) (utils tc-utils) (rep type-rep) @@ -11,25 +11,26 @@ (provide type-annotation-tests) (define-syntax-rule (tat ann-stx ty) - (check-type-equal? (format "~a" (quote ann-stx)) - (type-ascription (let ([ons (current-namespace)] - [ns (make-empty-namespace)]) - (parameterize ([current-namespace ns]) - (namespace-attach-module ons 'scheme/base ns) - (namespace-require 'scheme/base) - (namespace-require 'typed-scheme/private/prims) - (namespace-require 'typed-scheme/private/base-types) - (expand 'ann-stx)))) - ty)) + (check-tc-result-equal? (format "~a" (quote ann-stx)) + (type-ascription (let ([ons (current-namespace)] + [ns (make-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-attach-module ons 'scheme/base ns) + (namespace-require 'scheme/base) + (namespace-require 'typed-scheme/private/prims) + (namespace-require 'typed-scheme/private/base-types) + (namespace-require 'typed-scheme/private/base-types-extra) + (expand 'ann-stx)))) + ty)) #reader typed-scheme/typed-reader (define (type-annotation-tests) (test-suite "Type Annotation tests" - - (tat (ann foo : Number) N) + ;; FIXME - ask Ryan + ;(tat (ann foo : Number) (ret -Number)) (tat foo #f) - (tat (ann foo : 3) (-val 3)))) + (tat (ann foo : 3) (ret (-val 3))))) (define-go type-annotation-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ff39c7f171..2f142e237c 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -3,10 +3,11 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base) (for-template scheme/base)) -(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) +(require (private base-env prims type-annotation) (typecheck typechecker) - (rep type-rep effect-rep) - (utils tc-utils) + (rep type-rep filter-rep object-rep) + (types utils union convenience) + (utils tc-utils mutated-vars) (env type-name-env type-environments init-envs) (schemeunit)) @@ -20,10 +21,20 @@ (provide typecheck-tests g tc-expr/expand) +(define N -Number) +(define B -Boolean) +(define Sym -Symbol) + (define (g) (run typecheck-tests)) (define-namespace-anchor anch) +(define (-path t var [p null]) + (ret t + (-FS (list (make-NotTypeFilter (-val #f) p var)) + (list (make-TypeFilter (-val #f) p var))) + (make-Path p var))) + ;; check that a literal typechecks correctly (define-syntax tc-l @@ -45,11 +56,11 @@ ;; check that an expression typechecks correctly (define-syntax (tc-e stx) (syntax-case stx () - [(_ expr ty) (syntax/loc stx (tc-e expr ty (list) (list)))] - [(_ expr ty eff1 eff2) - (syntax/loc stx (check-tc-result-equal? (format "~a" 'expr) - (tc-expr/expand expr) - (ret ty eff1 eff2)))])) + [(_ expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))] + [(_ expr #:ret r) + (syntax/loc stx + (check-tc-result-equal? (format "~a" 'expr) (tc-expr/expand expr) r))] + [(_ expr ty f o) (syntax/loc stx (tc-e expr #:ret (ret ty f o)))])) (require (for-syntax syntax/kerncase)) @@ -76,8 +87,6 @@ (test-suite "Typechecker tests" #reader typed-scheme/typed-reader - (let ([-vet (lambda (x) (list (-vet x)))] - [-vef (lambda (x) (list (-vef x)))]) (test-suite "tc-expr tests" @@ -111,10 +120,10 @@ [tc-e (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] [tc-e (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)] - [tc-e (let: ([x : Number 5]) x) N (-vet #'x) (-vef #'x)] + [tc-e (let: ([x : Number 5]) x) #:ret (-path -Number #'x)] [tc-e (let-values ([(x) 4]) (+ x 1)) -Integer] [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) - B (list (-rest (-val #f) #'y)) (list)] + #:ret (ret -Boolean (-FS (list (make-TypeFilter (-val #f) #'y)) null))] [tc-e (values 3) -Integer] [tc-e (values) (-values (list))] [tc-e (values 3 #f) (-values (list -Integer (-val #f)))] @@ -149,13 +158,13 @@ [tc-e (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)] [tc-e (begin 3) -Integer] [tc-e (begin #f 3) -Integer] - [tc-e (begin #t) (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] - [tc-e (begin0 #t) (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] - [tc-e (begin0 #t 3) (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] - [tc-e #t (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] - [tc-e #f (-val #f) (list (make-False-Effect)) (list (make-False-Effect))] - [tc-e '#t (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] - [tc-e '#f (-val #f) (list (make-False-Effect)) (list (make-False-Effect))] + [tc-e (begin #t) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e (begin0 #t) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e (begin0 #t 3) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e #t #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e #f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))] + [tc-e '#t #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e '#f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))] [tc-e (if #f 'a 3) -Integer] [tc-e (if #f #f #t) (Un (-val #t))] [tc-e (when #f 3) -Void] @@ -178,7 +187,7 @@ [tc-e (let: ([x : Number 3]) (when (number? x) #t)) - (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] + #:ret (ret (-val #t) (-FS null (list (make-Bot))))] [tc-e (let: ([x : Number 3]) (when (boolean? x) #t)) -Void] @@ -195,13 +204,13 @@ 3)) N] - [tc-e (let ([x 1]) x) -Integer (-vet #'x) (-vef #'x)] - [tc-e (let ([x 1]) (boolean? x)) B (list (-rest B #'x)) (list (-rem B #'x))] - [tc-e (boolean? number?) B (list (-rest B #'number?)) (list (-rem B #'number?))] + [tc-e (let ([x 1]) x) #:ret (-path -Integer #'x)] + [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS ))] + [tc-e (boolean? number?) #:ret (-path -Boolean #'number?)] - [tc-e (let: ([x : (Option Number) #f]) x) (Un N (-val #f)) (-vet #'x) (-vef #'x)] - [tc-e (let: ([x : Any 12]) (not (not x))) - B (list (-rem (-val #f) #'x)) (list (-rest (-val #f) #'x))] + [tc-e (let: ([x : (Option Number) #f]) x) (-path (Un N (-val #f)) #'x)] + [tc-e (let: ([x : Any 12]) (not (not x))) + #:ret (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x)) (list (make-TypeFilter (-val #f) null #'x))))] [tc-e (let: ([x : (Option Number) #f]) (if (let ([z 1]) x) @@ -261,13 +270,12 @@ N] - [tc-e null (-val null) (-vet #'null) (-vef #'null)] + [tc-e null (-path (-val null) #'null)] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) x) - (Un (-val 'squarf) -Integer) - (-vet #'x) (-vef #'x)] + #:ret (-path (Un (-val 'squarf) -Integer) #'x)] [tc-e (if #t 1 2) -Integer] @@ -343,12 +351,12 @@ ;;; tests for and - [tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x))) B - (list (-rest N #'x) (-rest B #'x)) (list)] - [tc-e (let: ([x : Any 1]) (and (number? x) x)) (Un N (-val #f)) - (list (-rest N #'x) (make-Var-True-Effect #'x)) (list)] + [tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x))) + #:ret (ret B (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter B null #'x)) null))] + [tc-e (let: ([x : Any 1]) (and (number? x) x)) (Un N (-val #f)) + #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter (-val #f) null #'x)) null))] [tc-e (let: ([x : Any 1]) (and x (boolean? x))) B - (list (-rem (-val #f) #'x) (-rest B #'x)) (list)] + #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter (-val #f) null #'x)) null))] [tc-e (let: ([x : Any 3]) (if (and (list? x) (not (null? x))) @@ -572,7 +580,7 @@ (-polydots (a) ((list -String) (N a) . ->... . N))] ;; instantiating non-dotted terms [tc-e (inst (plambda: (a) ([x : a]) x) Integer) - (-Integer . -> . -Integer : (list (make-Latent-Var-True-Effect)) (list (make-Latent-Var-False-Effect)))] + (make-Function (list (make-arr (list -Integer) -Integer #:filter (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))))))] [tc-e (inst (plambda: (a) [x : a *] (apply list x)) Integer) ((list) -Integer . ->* . (-lst -Integer))] @@ -668,7 +676,7 @@ (fact 20))] #;[tc-err ] - )) + ) (test-suite "check-type tests" (test-exn "Fails correctly" exn:fail:syntax? (lambda () (parameterize ([orig-module-stx #'here]) From c2da52d661d95092e55a3bdc069949f2a1fe5683 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 21:41:23 +0000 Subject: [PATCH 101/156] Provide tc-literal. svn: r14754 --- collects/typed-scheme/typecheck/signatures.ss | 1 + collects/typed-scheme/typecheck/tc-expr-unit.ss | 3 +-- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index c5ef2012fa..d55063c333 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -11,6 +11,7 @@ (define-signature tc-expr^ ([cnt tc-expr (syntax? . -> . tc-results?)] + [cnt tc-literal (->* (syntax?) ((or/c #f Type/c)) Type/c)] [cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)] [cnt tc-expr/check/t (syntax? tc-results? . -> . Type/c)] [cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 03baae8c33..83cc3e86f0 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -23,8 +23,7 @@ ;; return the type of a literal value ;; scheme-value -> type -(d/c (tc-literal v-stx [expected #f]) - (-->* (syntax?) ((-or/c #f Type/c)) Type/c) +(define (tc-literal v-stx [expected #f]) (define-syntax-class exp (pattern i #:when expected From 1444c07c0af3f1ebfffe8db7e3782e96711ea2ef Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 23:11:57 +0000 Subject: [PATCH 102/156] polymorphic lambdas are true values. Use correct pattern. Return the appropriate types from apply, not the Values struct in the rng. svn: r14756 --- collects/typed-scheme/typecheck/tc-app.ss | 43 +++++++++++-------- .../typed-scheme/typecheck/tc-expr-unit.ss | 2 +- .../typed-scheme/typecheck/tc-lambda-unit.ss | 2 +- 3 files changed, 26 insertions(+), 21 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 1416aaceb4..470ea3f10d 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -166,6 +166,8 @@ (ret expected))])) (define (tc/apply f args) + (define (do-ret t) + (match t [(Values: (list (Result: ts _ _) ...)) (ret ts)])) (define f-ty (single-value f)) ;; produces the first n-1 elements of the list, and the last element (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) @@ -195,7 +197,7 @@ (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty)) (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) (printf/log "Non-poly apply, ... arg\n") - (ret (car rngs*))] + (do-ret (car rngs*))] [(and (car rests*) (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)]) (tc-expr/t tail))]) @@ -206,7 +208,7 @@ (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) "Simple arithmetic non-poly apply\n" "Simple non-poly apply\n")) - (ret (car rngs*))] + (do-ret (car rngs*))] [(and (car drests*) (let-values ([(tail-ty tail-bound) (with-handlers ([exn:fail? (lambda _ (values #f #f))]) @@ -216,9 +218,9 @@ (subtypes arg-tys (car doms*)) (subtype tail-ty (car (car drests*)))))) (printf/log "Non-poly apply, ... arg\n") - (ret (car rngs*))] + (do-ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '()) ..1)))) + [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests '()) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) @@ -242,7 +244,7 @@ (car rests*) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound @@ -255,7 +257,7 @@ (car rests*) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg [(and (car drests*) tail-bound @@ -263,7 +265,7 @@ (= (length (car doms*)) (length arg-tys)) (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result1: (Poly: vars (Function: '()))) @@ -294,7 +296,7 @@ (car rests*) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound @@ -308,7 +310,7 @@ (car rngs*) (fv (car rngs*)))) => (lambda (substitution) - (ret (subst-all substitution (car rngs*))))] + (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, same bound on ... [(and (car drests*) tail-bound @@ -317,7 +319,7 @@ (length arg-tys)) (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) => (lambda (substitution) - (ret (subst-all substitution (car rngs*))))] + (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, different bound on ... [(and (car drests*) tail-bound @@ -331,11 +333,11 @@ (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) - (ret (substitute-dotted (cadr (assq drest-bound substitution)) - tail-bound - drest-bound - (subst-all (alist-delete drest-bound substitution eq?) - (car rngs*)))))] + (do-ret (substitute-dotted (cadr (assq drest-bound substitution)) + tail-bound + drest-bound + (subst-all (alist-delete drest-bound substitution eq?) + (car rngs*)))))] ;; ... function, (List A B C etc) arg [(and (car drests*) (not tail-bound) @@ -347,7 +349,7 @@ (car (car drests*)) (car rngs*) (fv (car rngs*)))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) - (ret (subst-all substitution (car rngs*))))] + (do-ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result1: (PolyDots: vars (Function: '()))) @@ -373,7 +375,7 @@ [(#%plain-app not arg) (match (single-value #'arg) [(tc-result1: t (FilterSet: f+ f-) _) - (ret t (make-FilterSet f- f+))])] + (ret -Boolean (make-FilterSet f- f+))])] ;; (apply values l) gets special handling [(#%plain-app apply values e) (cond [(with-handlers ([exn:fail? (lambda _ #f)]) @@ -382,6 +384,8 @@ [else (tc/apply #'values #'(e))])] ;; rewrite this so that it takes advantages of all the special cases [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (apply . args)) expected)] + ;; handle apply specially + [(#%plain-app apply f . args) (tc/apply #'f #'args)] ;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value [(#%plain-app values arg) (single-value #'arg expected)] ;; handle `values' specially @@ -400,8 +404,6 @@ (for/list ([arg (syntax->list #'args)]) (single-value arg))]) (ret ts fs os))])] - ;; rewrite this so that it takes advantages of all the special cases - [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (apply . args)) expected)] ;; special case for keywords [(#%plain-app (#%plain-app kpe kws num fn) @@ -449,7 +451,10 @@ (tc/let-values #'((x) ...) #'(args ...) #'body #'(let-values ([(x) args] ...) . body) expected)] + ;; FIXME - make this work - doesn't work because the annotation + ;; on rst is not a normal annotation, may have * or ... ;; inference for ((lambda with dotted rest + #; [(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) #:when (<= (length (syntax->list #'(x ...))) (length (syntax->list #'(args ...)))) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 83cc3e86f0..75af7a45e5 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -121,7 +121,7 @@ ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) [(tc-result1: t _ _) t] - [t (int-err "tc-expr returned ~a, not a single tc-result, for ~a" t (syntax->datum e))])) + [t (int-err "tc-expr returned ~a, not a single tc-result, for ~a" t (syntax->datum e))])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 48f5a6e9cb..cb985758ee 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -277,7 +277,7 @@ ;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result (define (tc/lambda/internal form formals bodies expected) (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) - (ret (tc/plambda form formals bodies expected)) + (ret (tc/plambda form formals bodies expected) true-filter) (ret (tc/mono-lambda/type formals bodies expected) true-filter))) ;; tc/lambda : syntax syntax-list syntax-list -> tc-result From a828b89e92728243acea2e58dae064be28d83bbb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 23:12:13 +0000 Subject: [PATCH 103/156] Fix a lot of tests - 47 fail. svn: r14757 --- .../unit-tests/typecheck-tests.ss | 209 +++++++++--------- 1 file changed, 108 insertions(+), 101 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 2f142e237c..ae0e8d907a 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -18,6 +18,7 @@ (for-template (private base-env base-types))) +(require (for-syntax syntax/kerncase stxclass)) (provide typecheck-tests g tc-expr/expand) @@ -62,7 +63,9 @@ (check-tc-result-equal? (format "~a" 'expr) (tc-expr/expand expr) r))] [(_ expr ty f o) (syntax/loc stx (tc-e expr #:ret (ret ty f o)))])) -(require (for-syntax syntax/kerncase)) +(define-syntax (tc-e/t stx) + (syntax-parse stx + [(_ e t) #'(tc-e e #:ret (ret t (-FS (list) (list (make-Bot)))))])) ;; duplication of the mzscheme toplevel expander, necessary for expanding the rhs of defines ;; note that this ability is never used @@ -96,37 +99,37 @@ (+ 1 (car x)) 5)) N] - (tc-e (if (let ([y 12]) y) 3 4) -Integer) - (tc-e 3 -Integer) - (tc-e "foo" -String) + (tc-e/t (if (let ([y 12]) y) 3 4) -Integer) + (tc-e/t 3 -Integer) + (tc-e/t "foo" -String) (tc-e (+ 3 4) -Integer) - [tc-e (lambda: () 3) (-> -Integer)] - [tc-e (lambda: ([x : Number]) 3) (-> N -Integer)] - [tc-e (lambda: ([x : Number] [y : Boolean]) 3) (-> N B -Integer)] - [tc-e (lambda () 3) (-> -Integer)] - [tc-e (values 3 4) (-values (list -Integer -Integer))] + [tc-e/t (lambda: () 3) (-> -Integer : (-LFS (list) (list (make-LBot))))] + [tc-e/t (lambda: ([x : Number]) 3) (-> N -Integer : (-LFS (list) (list (make-LBot))))] + [tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (-> N B -Integer : (-LFS (list) (list (make-LBot))))] + [tc-e/t (lambda () 3) (-> -Integer : (-LFS (list) (list (make-LBot))))] + [tc-e (values 3 4) #:ret (ret (list -Integer -Integer) (list (-FS (list) (list (make-Bot))) (-FS (list) (list (make-Bot)))))] [tc-e (cons 3 4) (-pair -Integer -Integer)] [tc-e (cons 3 #{'() : (Listof -Integer)}) (make-Listof -Integer)] [tc-e (void) -Void] [tc-e (void 3 4) -Void] [tc-e (void #t #f '(1 2 3)) -Void] - [tc-e #(3 4 5) (make-Vector -Integer)] - [tc-e '(2 3 4) (-lst* -Integer -Integer -Integer)] - [tc-e '(2 3 #t) (-lst* -Integer -Integer (-val #t))] - [tc-e #(2 3 #t) (make-Vector (Un -Integer (-val #t)))] - [tc-e '(#t #f) (-lst* (-val #t) (-val #f))] - [tc-e (plambda: (a) ([l : (Listof a)]) (car l)) + [tc-e/t #(3 4 5) (make-Vector -Integer)] + [tc-e/t '(2 3 4) (-lst* -Integer -Integer -Integer)] + [tc-e/t '(2 3 #t) (-lst* -Integer -Integer (-val #t))] + [tc-e/t #(2 3 #t) (make-Vector (Un -Integer (-val #t)))] + [tc-e/t '(#t #f) (-lst* (-val #t) (-val #f))] + [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l)) + (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] + [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] - [tc-e (plambda: (a) ([l : (Listof a)]) (car l)) - (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] - [tc-e (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)] + [tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)] [tc-e (let: ([x : Number 5]) x) #:ret (-path -Number #'x)] [tc-e (let-values ([(x) 4]) (+ x 1)) -Integer] [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) #:ret (ret -Boolean (-FS (list (make-TypeFilter (-val #f) #'y)) null))] - [tc-e (values 3) -Integer] - [tc-e (values) (-values (list))] - [tc-e (values 3 #f) (-values (list -Integer (-val #f)))] + [tc-e/t (values 3) -Integer] + [tc-e (values) #:ret (ret null)] + [tc-e (values 3 #f) #:ret (ret (list -Integer (-val #f)) (list (-FS (list) (list (make-Bot))) (-FS (list (make-Bot)) (list))))] [tc-e (map #{values @ Symbol} '(a b c)) (make-Listof Sym)] [tc-e (letrec: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20)) @@ -142,11 +145,11 @@ N] [tc-e (let: ([v : (Un Number Boolean) #f]) (if (boolean? v) 5 (+ v 1))) - N] + #:ret (ret N (-FS null (list (make-NotTypeFilter -Boolean null #'v))))] [tc-e (let: ([f : (Number Number -> Number) +]) (f 3 4)) N] [tc-e (let: ([+ : (Boolean -> Number) (lambda: ([x : Boolean]) 3)]) (+ #f)) N] - [tc-e (when #f #t) (Un -Void)] - [tc-e (when (number? #f) (+ 4 5)) (Un -Integer -Void)] + [tc-e (when #f #t) -Void] + [tc-e (when (number? #f) (+ 4 5)) -Void] [tc-e (let: ([x : (Un #f Number) 7]) (if x (+ x 1) 3)) N] @@ -155,25 +158,25 @@ (+ x 4) 'bc)) N] - [tc-e (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)] - [tc-e (begin 3) -Integer] - [tc-e (begin #f 3) -Integer] - [tc-e (begin #t) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] - [tc-e (begin0 #t) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] - [tc-e (begin0 #t 3) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] - [tc-e #t #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e/t (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)] + [tc-e/t (begin 3) -Integer] + [tc-e/t (begin #f 3) -Integer] + [tc-e/t (begin #t) (-val #t)] + [tc-e/t (begin0 #t) (-val #t)] + [tc-e/t (begin0 #t 3) (-val #t)] + [tc-e/t #t (-val #t)] [tc-e #f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))] - [tc-e '#t #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e/t '#t (-val #t)] [tc-e '#f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))] - [tc-e (if #f 'a 3) -Integer] - [tc-e (if #f #f #t) (Un (-val #t))] + [tc-e/t (if #f 'a 3) -Integer] + [tc-e/t (if #f #f #t) (Un (-val #t))] [tc-e (when #f 3) -Void] - [tc-e '() (-val '())] - [tc-e (let: ([x : (Listof Number) '(1)]) - (cond [(pair? x) 1] - [(null? x) 1])) + [tc-e/t '() (-val '())] + [tc-e/t (let: ([x : (Listof Number) '(1)]) + (cond [(pair? x) 1] + [(null? x) 1])) -Integer] - [tc-e (lambda: ([x : Number] . [y : Number *]) (car y)) (->* (list N) N N)] + [tc-e/t (lambda: ([x : Number] . [y : Number *]) (car y)) (->* (list N) N N)] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3) N] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4 5) N] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4) N] @@ -181,18 +184,18 @@ [tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '(4 6 7)) N] [tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '()) N] - [tc-e (lambda: ([x : Number] . [y : Boolean *]) (car y)) (->* (list N) B B)] + [tc-e/t (lambda: ([x : Number] . [y : Boolean *]) (car y)) (->* (list N) B B)] [tc-e ((lambda: ([x : Number] . [y : Boolean *]) (car y)) 3) B] [tc-e (apply (lambda: ([x : Number] . [y : Boolean *]) (car y)) 3 '(#f)) B] - [tc-e (let: ([x : Number 3]) - (when (number? x) #t)) - #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e/t (let: ([x : Number 3]) + (when (number? x) #t)) + (-val #t)] [tc-e (let: ([x : Number 3]) (when (boolean? x) #t)) -Void] - [tc-e (let: ([x : Any 3]) + [tc-e/t (let: ([x : Any 3]) (if (list? x) (begin (car x) 1) 2)) -Integer] @@ -205,10 +208,10 @@ N] [tc-e (let ([x 1]) x) #:ret (-path -Integer #'x)] - [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS ))] - [tc-e (boolean? number?) #:ret (-path -Boolean #'number?)] + [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS (list (make-Bot)) null))] + [tc-e (boolean? number?) #:ret (ret -Boolean (-FS (list (make-Bot)) null))] - [tc-e (let: ([x : (Option Number) #f]) x) (-path (Un N (-val #f)) #'x)] + [tc-e (let: ([x : (Option Number) #f]) x) #:ret (-path (Un N (-val #f)) #'x)] [tc-e (let: ([x : Any 12]) (not (not x))) #:ret (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x)) (list (make-TypeFilter (-val #f) null #'x))))] @@ -222,7 +225,7 @@ [tc-err (map (lambda: ([x : Any] [y : Any]) 1) '(1))] [tc-e (map add1 '(1)) (-lst -Integer)] - [tc-e (let ([x 5]) + [tc-e/t (let ([x 5]) (if (eq? x 1) 12 14)) @@ -270,21 +273,23 @@ N] - [tc-e null (-path (-val null) #'null)] + [tc-e null #:ret (-path (-val null) #'null)] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) x) #:ret (-path (Un (-val 'squarf) -Integer) #'x)] - [tc-e (if #t 1 2) -Integer] + [tc-e/t (if #t 1 2) -Integer] ;; eq? as predicate [tc-e (let: ([x : (Un 'foo Number) 'foo]) - (if (eq? x 'foo) 3 x)) N] + (if (eq? x 'foo) 3 x)) + #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-e (let: ([x : (Un 'foo Number) 'foo]) - (if (eq? 'foo x) 3 x)) N] + (if (eq? 'foo x) 3 x)) + #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-err (let: ([x : (U String 'foo) 'foo]) (if (string=? x 'foo) @@ -299,25 +304,27 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? x sym) 3 x)) - -Integer] + #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? sym x) 3 x)) - -Integer] + #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] ;; equal? as predicate for symbols [tc-e (let: ([x : (Un 'foo Number) 'foo]) - (if (equal? x 'foo) 3 x)) N] + (if (equal? x 'foo) 3 x)) + #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-e (let: ([x : (Un 'foo Number) 'foo]) - (if (equal? 'foo x) 3 x)) N] + (if (equal? 'foo x) 3 x)) + #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? x sym) 3 x)) - -Integer] + #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? sym x) 3 x)) - -Integer] + #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] [tc-e (let: ([x : (Listof Symbol)'(a b c)]) (cond [(memq 'a x) => car] @@ -352,15 +359,15 @@ ;;; tests for and [tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x))) - #:ret (ret B (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter B null #'x)) null))] - [tc-e (let: ([x : Any 1]) (and (number? x) x)) (Un N (-val #f)) - #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter (-val #f) null #'x)) null))] - [tc-e (let: ([x : Any 1]) (and x (boolean? x))) B - #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter (-val #f) null #'x)) null))] + #:ret (ret B (-FS (list (make-Bot)) null))] + [tc-e (let: ([x : Any 1]) (and (number? x) x)) + #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-NotTypeFilter (-val #f) null #'x)) null))] + [tc-e (let: ([x : Any 1]) (and x (boolean? x))) + #:ret (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x) (make-TypeFilter -Boolean null #'x)) null))] - [tc-e (let: ([x : Any 3]) - (if (and (list? x) (not (null? x))) - (begin (car x) 1) 2)) + [tc-e/t (let: ([x : Any 3]) + (if (and (list? x) (not (null? x))) + (begin (car x) 1) 2)) -Integer] ;; set! tests @@ -404,30 +411,30 @@ Univ] ;; T-AbsPred - [tc-e (let ([p? (lambda: ([x : Any]) (number? x))]) - (lambda: ([x : Any]) (if (p? x) (add1 x) 12))) - (-> Univ N)] - [tc-e (let ([p? (lambda: ([x : Any]) (not (number? x)))]) - (lambda: ([x : Any]) (if (p? x) 12 (add1 x)))) - (-> Univ N)] - [tc-e (let* ([z 1] - [p? (lambda: ([x : Any]) (number? z))]) - (lambda: ([x : Any]) (if (p? x) 11 12))) - (-> Univ -Integer)] - [tc-e (let* ([z 1] - [p? (lambda: ([x : Any]) (number? z))]) - (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ)] - [tc-e (let* ([z 1] - [p? (lambda: ([x : Any]) (not (number? z)))]) - (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ)] - [tc-e (let* ([z 1] - [p? (lambda: ([x : Any]) z)]) - (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ)] + [tc-e/t (let ([p? (lambda: ([x : Any]) (number? x))]) + (lambda: ([x : Any]) (if (p? x) (add1 x) 12))) + (-> Univ N)] + [tc-e/t (let ([p? (lambda: ([x : Any]) (not (number? x)))]) + (lambda: ([x : Any]) (if (p? x) 12 (add1 x)))) + (-> Univ N)] + [tc-e/t (let* ([z 1] + [p? (lambda: ([x : Any]) (number? z))]) + (lambda: ([x : Any]) (if (p? x) 11 12))) + (-> Univ -Integer)] + [tc-e/t (let* ([z 1] + [p? (lambda: ([x : Any]) (number? z))]) + (lambda: ([x : Any]) (if (p? x) x 12))) + (-> Univ Univ)] + [tc-e/t (let* ([z 1] + [p? (lambda: ([x : Any]) (not (number? z)))]) + (lambda: ([x : Any]) (if (p? x) x 12))) + (-> Univ Univ)] + [tc-e/t (let* ([z 1] + [p? (lambda: ([x : Any]) z)]) + (lambda: ([x : Any]) (if (p? x) x 12))) + (-> Univ Univ)] - [tc-e (not 1) B] + [tc-e (not 1) #:ret (ret B (-FS (list (make-Bot)) null))] [tc-err ((lambda () 1) 2)] [tc-err (apply (lambda () 1) '(2))] @@ -450,7 +457,7 @@ (set! x "foo") x)] ;; w-c-m - [tc-e (with-continuation-mark 'key 'mark + [tc-e/t (with-continuation-mark 'key 'mark 3) -Integer] [tc-err (with-continuation-mark (5 4) 1 @@ -481,8 +488,8 @@ [tc-err (call-with-values (lambda () (values 2 1)) (lambda: ([x : String] [y : Number]) (+ x y)))] ;; quote-syntax - [tc-e #'3 (-Syntax -Integer)] - [tc-e #'(1 2 3) (-Syntax (-lst* -Integer -Integer -Integer))] + [tc-e/t #'3 (-Syntax -Integer)] + [tc-e/t #'(1 2 3) (-Syntax (-lst* -Integer -Integer -Integer))] ;; testing some primitives [tc-e (let ([app apply] @@ -555,7 +562,7 @@ ((null? x) sum))) N] - [tc-e (if #f 1 'foo) (-val 'foo)] + [tc-e/t (if #f 1 'foo) (-val 'foo)] [tc-e (list* 1 2 3) (-pair -Integer (-pair -Integer -Integer))] @@ -574,13 +581,13 @@ (apply (plambda: (b) ([x : Number] . [y : Number ... a]) x) 1 w))] - [tc-e (plambda: (a ...) ([z : String] . [w : Number ... a]) + [tc-e/t (plambda: (a ...) ([z : String] . [w : Number ... a]) (apply (plambda: (b ...) ([x : Number] . [y : Number ... b]) x) 1 w)) (-polydots (a) ((list -String) (N a) . ->... . N))] ;; instantiating non-dotted terms [tc-e (inst (plambda: (a) ([x : a]) x) Integer) - (make-Function (list (make-arr (list -Integer) -Integer #:filter (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))))))] + (make-Function (list (make-arr* (list -Integer) -Integer #:filters (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))))))] [tc-e (inst (plambda: (a) [x : a *] (apply list x)) Integer) ((list) -Integer . ->* . (-lst -Integer))] @@ -593,7 +600,7 @@ (-Integer B -Integer . -> . -Integer) . -> . -Integer)] - [tc-e (plambda: (z x y ...) () (inst map z x y ... y)) + [tc-e/t (plambda: (z x y ...) () (inst map z x y ... y)) (-polydots (z x y) (-> ((list ((list x) (y y) . ->... . z) (-lst x)) ((-lst y) y) . ->... . (-lst z))))] ;; error tests @@ -614,7 +621,7 @@ (if (number? x) (begin (f) (add1 x)) 12))] - + #; [tc-err (lambda: ([x : Any]) (if (number? (not (not x))) (add1 x) @@ -636,27 +643,27 @@ (apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c) 3 (list #\c) (map list (map list as))))] - [tc-e (plambda: (a ...) [as : a ... a] + [tc-e/t (plambda: (a ...) [as : a ... a] (apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c) 3 (list #\c) (map list as))) (-polydots (a) ((list) (a a) . ->... . -Integer))] ;; First is same as second, but with map explicitly instantiated. - [tc-e (plambda: (a ...) [ys : (a ... a -> Number) *] + [tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *] (lambda: [zs : a ... a] ((inst map Number (a ... a -> Number)) (lambda: ([y : (a ... a -> Number)]) (apply y zs)) ys))) (-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N))))] - [tc-e (plambda: (a ...) [ys : (a ... a -> Number) *] + [tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *] (lambda: [zs : a ... a] (map (lambda: ([y : (a ... a -> Number)]) (apply y zs)) ys))) (-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N))))] - [tc-e (lambda: ((x : (All (t) t))) + [tc-e/t (lambda: ((x : (All (t) t))) ((inst (inst x (All (t) (t -> t))) (All (t) t)) x)) From fbae33b1c3d49eca4a8f7d08bcd88f13d10eb4b1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 23:31:33 +0000 Subject: [PATCH 104/156] match based on symbol for : in -> svn: r14758 --- collects/typed-scheme/types/abbrev.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 1b5e2f930d..53729ed8b7 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -188,11 +188,12 @@ (make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))])) (define-syntax (-> stx) + (define-syntax-class c + (pattern x:id #:when (eq? ': (syntax-e #'x)))) (syntax-parse stx - #:literals (:) - [(_ dom ... rng : filters) + [(_ dom ... rng :c filters) #'(->* (list dom ...) rng : filters)] - [(_ dom ... rng : filters) + [(_ dom ... rng :c filters) #'(->* (list dom ...) rng : filters)] [(_ dom ... rng) #'(->* (list dom ...) rng)])) From 1ce4411ceb4d355d9ddda5e073c00923f78b08fb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 11 May 2009 19:40:58 +0000 Subject: [PATCH 105/156] fix tests to handle identifiers, down to 38 fails svn: r14775 --- .../unit-tests/typecheck-tests.ss | 55 ++++++++++++++----- 1 file changed, 40 insertions(+), 15 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ae0e8d907a..ffe77fe80b 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -9,7 +9,8 @@ (types utils union convenience) (utils tc-utils mutated-vars) (env type-name-env type-environments init-envs) - (schemeunit)) + (schemeunit) + stxclass) (require (for-syntax (utils tc-utils) (typecheck typechecker) @@ -44,6 +45,16 @@ (check-type-equal? (format "~a" 'lit) (tc-literal #'lit) ty)])) ;; local-expand and then typecheck an expression +(define-syntax (tc-expr/expand/values stx) + (syntax-case stx () + [(_ e) + #`(parameterize ([delay-errors? #f] + [current-namespace (namespace-anchor->namespace anch)] + [orig-module-stx (quote-syntax e)]) + (let ([ex (expand 'e)]) + (find-mutated-vars ex) + (values (lambda () (tc-expr ex)) ex)))])) + (define-syntax (tc-expr/expand stx) (syntax-case stx () [(_ e) @@ -58,6 +69,10 @@ (define-syntax (tc-e stx) (syntax-case stx () [(_ expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))] + [(_ expr #:proc p) + (syntax/loc stx + (let-values ([(t e) (tc-expr/expand/values expr)]) + (check-tc-result-equal? (format "~a" 'expr) (t) (p e))))] [(_ expr #:ret r) (syntax/loc stx (check-tc-result-equal? (format "~a" 'expr) (tc-expr/expand expr) r))] @@ -85,6 +100,16 @@ exn:fail:syntax? (lambda () (tc-expr/expand expr)))])) +(define-syntax-class (let-name n) + #:literals (let-values) + (pattern (let-values ([(i:id) _] ...) . _) + #:with x (list-ref (syntax->list #'(i ...)) n))) + +(define-syntax-rule (get-let-name id n e) + (syntax-parser + [p #:declare p (let-name n) + #:with id #'p.x + e])) (define (typecheck-tests) (test-suite @@ -123,10 +148,10 @@ [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] [tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)] - [tc-e (let: ([x : Number 5]) x) #:ret (-path -Number #'x)] + [tc-e (let: ([x : Number 5]) x) #:proc (get-let-name x 0 (-path -Number #'x))] [tc-e (let-values ([(x) 4]) (+ x 1)) -Integer] [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) - #:ret (ret -Boolean (-FS (list (make-TypeFilter (-val #f) #'y)) null))] + #:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS (list (make-TypeFilter (-val #f) #'y)) null))])] [tc-e/t (values 3) -Integer] [tc-e (values) #:ret (ret null)] [tc-e (values 3 #f) #:ret (ret (list -Integer (-val #f)) (list (-FS (list) (list (make-Bot))) (-FS (list (make-Bot)) (list))))] @@ -145,7 +170,7 @@ N] [tc-e (let: ([v : (Un Number Boolean) #f]) (if (boolean? v) 5 (+ v 1))) - #:ret (ret N (-FS null (list (make-NotTypeFilter -Boolean null #'v))))] + #:proc (get-let-name v 0 (ret N (-FS null (list (make-NotTypeFilter -Boolean null #'v)))))] [tc-e (let: ([f : (Number Number -> Number) +]) (f 3 4)) N] [tc-e (let: ([+ : (Boolean -> Number) (lambda: ([x : Boolean]) 3)]) (+ #f)) N] [tc-e (when #f #t) -Void] @@ -207,13 +232,13 @@ 3)) N] - [tc-e (let ([x 1]) x) #:ret (-path -Integer #'x)] + [tc-e (let ([x 1]) x) #:proc (get-let-name x 0 (-path -Integer #'x))] [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS (list (make-Bot)) null))] [tc-e (boolean? number?) #:ret (ret -Boolean (-FS (list (make-Bot)) null))] - [tc-e (let: ([x : (Option Number) #f]) x) #:ret (-path (Un N (-val #f)) #'x)] + [tc-e (let: ([x : (Option Number) #f]) x) #:proc (get-let-name x 0 (-path (Un N (-val #f)) #'x))] [tc-e (let: ([x : Any 12]) (not (not x))) - #:ret (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x)) (list (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 0 (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x)) (list (make-TypeFilter (-val #f) null #'x)))))] [tc-e (let: ([x : (Option Number) #f]) (if (let ([z 1]) x) @@ -278,7 +303,7 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) x) - #:ret (-path (Un (-val 'squarf) -Integer) #'x)] + #:proc (get-let-name x 1 (-path (Un (-val 'squarf) -Integer) #'x))] [tc-e/t (if #t 1 2) -Integer] @@ -286,10 +311,10 @@ ;; eq? as predicate [tc-e (let: ([x : (Un 'foo Number) 'foo]) (if (eq? x 'foo) 3 x)) - #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))] [tc-e (let: ([x : (Un 'foo Number) 'foo]) (if (eq? 'foo x) 3 x)) - #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))] [tc-err (let: ([x : (U String 'foo) 'foo]) (if (string=? x 'foo) @@ -304,23 +329,23 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? x sym) 3 x)) - #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 1 (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x)))))] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? sym x) 3 x)) - #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 1 (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x)))))] ;; equal? as predicate for symbols [tc-e (let: ([x : (Un 'foo Number) 'foo]) (if (equal? x 'foo) 3 x)) - #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))] [tc-e (let: ([x : (Un 'foo Number) 'foo]) (if (equal? 'foo x) 3 x)) - #:ret (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? x sym) 3 x)) - #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (get-let-name x 0 (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x)))))] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? sym x) 3 x)) From 7b4081eef114343991472b0839e336d35301802a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 15:13:17 +0000 Subject: [PATCH 106/156] Allow objects to be specified in -> Fix overlap to handle overlapping base types (numbers) svn: r14781 --- collects/typed-scheme/typecheck/tc-metafunctions.ss | 4 ++-- collects/typed-scheme/types/abbrev.ss | 4 ++-- collects/typed-scheme/types/remove-intersect.ss | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index cea9cb4499..6487fb093b 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -96,8 +96,8 @@ (-> LatentFilter/c Type/c Object? (or/c '() (list/c Filter/c))) (match* (lf s o) [((LBot:) _ _) (list (make-Bot))] - [((LNotTypeFilter: (? (lambda (t) (subtype s t))) (list) _) _ _) (list (make-Bot))] - [((LTypeFilter: (? (lambda (t) (not (overlap s t)))) (list) _) _ _) (list (make-Bot))] + [((LNotTypeFilter: (? (lambda (t) (subtype s t)) t) (list) _) _ _) (list (make-Bot))] + [((LTypeFilter: (? (lambda (t) (not (overlap s t))) t) (list) _) _ _) (list (make-Bot))] [(_ _ (Empty:)) null] [((LTypeFilter: t pi* _) _ (Path: pi x)) (list (make-TypeFilter t (append pi* pi) x))] [((LNotTypeFilter: t pi* _) _ (Path: pi x)) (list (make-NotTypeFilter t (append pi* pi) x))])) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 53729ed8b7..52c43d6fdd 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -191,8 +191,8 @@ (define-syntax-class c (pattern x:id #:when (eq? ': (syntax-e #'x)))) (syntax-parse stx - [(_ dom ... rng :c filters) - #'(->* (list dom ...) rng : filters)] + [(_ dom ... rng _:c filters _:c objects) + #'(->* (list dom ...) rng : filters : objects)] [(_ dom ... rng :c filters) #'(->* (list dom ...) rng : filters)] [(_ dom ... rng) diff --git a/collects/typed-scheme/types/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss index c7a1b219ee..0d76e51ba6 100644 --- a/collects/typed-scheme/types/remove-intersect.ss +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -23,7 +23,7 @@ (ormap (lambda (t*) (overlap t t*)) e)] [(or (list _ (? Poly?)) (list (? Poly?) _)) #t] ;; these can have overlap, conservatively - [(list (Base: s1 _) (Base: s2 _)) (eq? s1 s2)] + [(list (Base: s1 _) (Base: s2 _)) (or (subtype t1 t2) (subtype t2 t1))] [(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative [(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative [(list (Syntax: t) (Syntax: t*)) From c19b66d5db4d25746472d17fbd6f750e3eb474ef Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 15:17:30 +0000 Subject: [PATCH 107/156] add tests for overlap fix more typecheck tests - 29 failures svn: r14782 --- .../typed-scheme/unit-tests/all-tests.ss | 1 + .../unit-tests/remove-intersect-tests.ss | 15 ++++++++-- .../unit-tests/typecheck-tests.ss | 28 +++++++++++-------- 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 9821f9c72d..2d2172efd1 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -31,6 +31,7 @@ type-equal-tests restrict-tests remove-tests + overlap-tests parse-type-tests type-annotation-tests module-tests diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index 95fc97fc2e..88b6b7f055 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -5,6 +5,16 @@ (types convenience subtype union remove-intersect) (schemeunit)) +(define-syntax (over-tests stx) + (syntax-case stx () + [(_ [t1 t2 res] ...) + #'(test-suite "Tests for intersect" + (test-check (format "Overlap test: ~a ~a" t1 t2) (lambda (a b) (eq? (not (not a)) b)) (overlap t1 t2) res) ...)])) + +(define (overlap-tests) + (over-tests + [-Number -Integer #t])) + (define-syntax (restr-tests stx) (syntax-case stx () [(_ [t1 t2 res] ...) @@ -56,7 +66,8 @@ (define-go restrict-tests - remove-tests) + remove-tests + overlap-tests) (define x1 (-mu list-rec @@ -68,5 +79,5 @@ (Un (-val '()) (-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x))) (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))))) -(provide remove-tests restrict-tests) +(provide remove-tests restrict-tests overlap-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ffe77fe80b..44cffc4abf 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -80,7 +80,7 @@ (define-syntax (tc-e/t stx) (syntax-parse stx - [(_ e t) #'(tc-e e #:ret (ret t (-FS (list) (list (make-Bot)))))])) + [(_ e t) (syntax/loc stx (tc-e e #:ret (ret t (-FS (list) (list (make-Bot))))))])) ;; duplication of the mzscheme toplevel expander, necessary for expanding the rhs of defines ;; note that this ability is never used @@ -303,7 +303,7 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) x) - #:proc (get-let-name x 1 (-path (Un (-val 'squarf) -Integer) #'x))] + #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) (-path (Un (-val 'squarf) -Integer) #'x)])] [tc-e/t (if #t 1 2) -Integer] @@ -329,11 +329,13 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? x sym) 3 x)) - #:proc (get-let-name x 1 (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x)))))] + #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) + (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? sym x) 3 x)) - #:proc (get-let-name x 1 (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x)))))] + #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) + (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])] ;; equal? as predicate for symbols [tc-e (let: ([x : (Un 'foo Number) 'foo]) (if (equal? x 'foo) 3 x)) @@ -345,11 +347,13 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? x sym) 3 x)) - #:proc (get-let-name x 0 (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x)))))] + #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) + (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? sym x) 3 x)) - #:ret (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))] + #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) + (ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])] [tc-e (let: ([x : (Listof Symbol)'(a b c)]) (cond [(memq 'a x) => car] @@ -386,9 +390,9 @@ [tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x))) #:ret (ret B (-FS (list (make-Bot)) null))] [tc-e (let: ([x : Any 1]) (and (number? x) x)) - #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-NotTypeFilter (-val #f) null #'x)) null))] + #:proc (get-let-name x 0 (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-NotTypeFilter (-val #f) null #'x)) null)))] [tc-e (let: ([x : Any 1]) (and x (boolean? x))) - #:ret (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x) (make-TypeFilter -Boolean null #'x)) null))] + #:proc (get-let-name x 0 (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x) (make-TypeFilter -Boolean null #'x)) null)))] [tc-e/t (let: ([x : Any 3]) (if (and (list? x) (not (null? x))) @@ -441,19 +445,19 @@ (-> Univ N)] [tc-e/t (let ([p? (lambda: ([x : Any]) (not (number? x)))]) (lambda: ([x : Any]) (if (p? x) 12 (add1 x)))) - (-> Univ N)] + (-> Univ N : (-LFS null (list (make-LTypeFilter -Number null 0))))] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) 11 12))) - (-> Univ -Integer)] + (-> Univ -Integer : (-LFS null (list (make-LBot))))] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ)] + (-> Univ Univ : (-LFS null (list (make-LBot))))] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (not (number? z)))]) (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ)] + (-> Univ Univ : (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))) : (make-LPath null 0))] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) z)]) (lambda: ([x : Any]) (if (p? x) x 12))) From e796cd802bf056a93a0328901b9e6631f1e63ada Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 15:30:15 +0000 Subject: [PATCH 108/156] fix wrong results - 25 fails svn: r14783 --- .../tests/typed-scheme/unit-tests/all-tests.ss | 4 ++-- .../typed-scheme/unit-tests/typecheck-tests.ss | 18 ++++++++++++------ 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 2d2172efd1..cc94dbb81b 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -3,12 +3,12 @@ (require "test-utils.ss" "planet-requires.ss" - "typecheck-tests.ss" ;; doesn't compile yet + "typecheck-tests.ss" ;;fail "subtype-tests.ss" ;; pass "type-equal-tests.ss" ;; pass "remove-intersect-tests.ss" ;; pass "parse-type-tests.ss" ;; pass - "type-annotation-test.ss" ;; fail + "type-annotation-test.ss" ;; pass "module-tests.ss" ;; pass "subst-tests.ss" ;; pass "infer-tests.ss" ;; pass diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 44cffc4abf..a88434ba08 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -453,11 +453,15 @@ [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ : (-LFS null (list (make-LBot))))] + (-> Univ Univ : (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))) : (make-LPath null 0))] + [tc-e/t (let* ([z (ann 1 : Any)] + [p? (lambda: ([x : Any]) (not (number? z)))]) + (lambda: ([x : Any]) (if (p? x) x 12))) + (-> Univ Univ)] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (not (number? z)))]) (lambda: ([x : Any]) (if (p? x) x 12))) - (-> Univ Univ : (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))) : (make-LPath null 0))] + (-> Univ -Integer : (-LFS null (list (make-LBot))))] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) z)]) (lambda: ([x : Any]) (if (p? x) x 12))) @@ -615,10 +619,12 @@ 1 w)) (-polydots (a) ((list -String) (N a) . ->... . N))] ;; instantiating non-dotted terms - [tc-e (inst (plambda: (a) ([x : a]) x) Integer) - (make-Function (list (make-arr* (list -Integer) -Integer #:filters (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))))))] - [tc-e (inst (plambda: (a) [x : a *] (apply list x)) Integer) - ((list) -Integer . ->* . (-lst -Integer))] + [tc-e/t (inst (plambda: (a) ([x : a]) x) Integer) + (make-Function (list (make-arr* (list -Integer) -Integer + #:filters (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))) + #:object (make-LPath null 0))))] + [tc-e/t (inst (plambda: (a) [x : a *] (apply list x)) Integer) + ((list) -Integer . ->* . (-lst -Integer))] ;; instantiating dotted terms [tc-e (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer) From f24cbf99528313ea078cd74b71b16e4501b70815 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 16:52:55 +0000 Subject: [PATCH 109/156] Fix more tests with truth info. svn: r14784 --- .../unit-tests/typecheck-tests.ss | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index a88434ba08..d3c50970f0 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -603,8 +603,8 @@ [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -Integer)] [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (Un -String -Integer))] [tc-err (plambda: (b ...) [y : b ... b] (apply append (map list y)))] - [tc-e (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y)) - (-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))] + [tc-e/t (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y)) + (-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))] [tc-err (plambda: (a ...) ([z : String] . [w : Number ... a]) (apply (plambda: (b) ([x : Number] . [y : Number ... a]) x) @@ -627,13 +627,13 @@ ((list) -Integer . ->* . (-lst -Integer))] ;; instantiating dotted terms - [tc-e (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer) - (-Integer B -Integer . -> . -Integer)] - [tc-e (inst (plambda: (a ...) [xs : (a ... a -> Integer) ... a] 3) Integer Boolean Integer) - ((-Integer B -Integer . -> . -Integer) - (-Integer B -Integer . -> . -Integer) - (-Integer B -Integer . -> . -Integer) - . -> . -Integer)] + [tc-e/t (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer) + (-Integer B -Integer . -> . -Integer : (-LFS null (list (make-LBot))))] + [tc-e/t (inst (plambda: (a ...) [xs : (a ... a -> Integer) ... a] 3) Integer Boolean Integer) + ((-Integer B -Integer . -> . -Integer) + (-Integer B -Integer . -> . -Integer) + (-Integer B -Integer . -> . -Integer) + . -> . -Integer : (-LFS null (list (make-LBot))))] [tc-e/t (plambda: (z x y ...) () (inst map z x y ... y)) (-polydots (z x y) (-> ((list ((list x) (y y) . ->... . z) (-lst x)) ((-lst y) y) . ->... . (-lst z))))] @@ -706,10 +706,10 @@ ;; We need to make sure that even if a isn't free in the dotted type, that it gets replicated ;; appropriately. - [tc-e (inst (plambda: (a ...) [ys : Number ... a] - (apply + ys)) - Boolean String Number) - (N N N . -> . N)] + [tc-e/t (inst (plambda: (a ...) [ys : Number ... a] + (apply + ys)) + Boolean String Number) + (N N N . -> . N)] [tc-e (assq 'foo #{'((a b) (foo bar)) :: (Listof (List Symbol Symbol))}) (Un (-val #f) (-pair Sym (-pair Sym (-val null))))] From ce9f98098d8c6429e8586d3ff0cbe1cca2477ba0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 16:53:24 +0000 Subject: [PATCH 110/156] Type goes before symbol in drest. Handle tc-results properly in a few places. svn: r14785 --- collects/typed-scheme/typecheck/signatures.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 10 +++++----- collects/typed-scheme/typecheck/tc-dots-unit.ss | 4 ++-- collects/typed-scheme/typecheck/tc-expr-unit.ss | 4 ++-- collects/typed-scheme/typecheck/tc-lambda-unit.ss | 4 ++-- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index d55063c333..f50e5f923e 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -37,7 +37,7 @@ (define-signature tc-app^ ([cnt tc/app (syntax? . -> . tc-results?)] [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)] - [cnt tc/funapp (syntax? syntax? tc-result? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)])) + [cnt tc/funapp (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)])) (define-signature tc-let^ ([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 470ea3f10d..8ac95e8236 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -100,8 +100,8 @@ [name-assoc (map list names (syntax->list named-args))]) (let loop ([t (tc-expr cl)]) (match t - [(tc-result: (? Mu? t)) (loop (ret (unfold t)))] - [(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) + [(tc-result1: (? Mu? t)) (loop (ret (unfold t)))] + [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) (unless (= (length pos-tys) (length (syntax->list pos-args))) (tc-error/delayed "expected ~a positional arguments, but got ~a" @@ -129,7 +129,7 @@ #f))]) tnflds) (ret (make-Instance c))] - [(tc-result: t) + [(tc-result1: t) (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -227,7 +227,7 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1)))) + [(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -279,7 +279,7 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1)))) + [(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" diff --git a/collects/typed-scheme/typecheck/tc-dots-unit.ss b/collects/typed-scheme/typecheck/tc-dots-unit.ss index eb5e9c2f3a..ddffd4d724 100644 --- a/collects/typed-scheme/typecheck/tc-dots-unit.ss +++ b/collects/typed-scheme/typecheck/tc-dots-unit.ss @@ -35,8 +35,8 @@ (parameterize ([current-tvars (extend-env (list lbound) (list (make-DottedBoth (make-F lbound))) (current-tvars))]) - (match-let* ([ft (tc-expr #'f)] - [(tc-result: t) (tc/funapp #'f #'(l) ft (list (ret lty)) #f)]) + (match-let* ([ft (single-value #'f)] + [(tc-result1: t) (tc/funapp #'f #'(l) ft (list (ret lty)) #f)]) (values t lbound))))] [_ (tc-error "form cannot be used where a term of ... type is expected")]))) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 75af7a45e5..cb55d1abaf 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -192,8 +192,8 @@ [(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)) true-filter)] ;; mutation! [(set! id val) - (match-let* ([(tc-result: id-t) (tc-expr #'id)] - [(tc-result: val-t) (tc-expr #'val)]) + (match-let* ([(tc-result1: id-t) (single-value #'id)] + [(tc-result1: val-t) (single-value #'val)]) (unless (subtype val-t id-t) (tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) (ret -Void))] diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index cb985758ee..49a821e614 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -23,7 +23,7 @@ (d-s/c lam-result ([args (listof (list/c identifier? Type/c))] [kws (listof (list/c keyword? identifier? Type/c boolean?))] [rest (or/c #f Type/c)] - [drest (or/c #f (cons/c symbol? Type/c))] + [drest (or/c #f (cons/c Type/c symbol?))] [body tc-results?]) #:transparent) @@ -146,7 +146,7 @@ (map list arg-list arg-types) null #f - (cons bound rest-type) + (cons rest-type bound) (tc-exprs (syntax->list body)))))))] [else (let ([rest-type (get-type #'rest #:default Univ)]) From 5300481176a6067d1cf561aeb329ecc6d8f0c99f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 19:53:48 +0000 Subject: [PATCH 111/156] Move `hashof' contract combinator to utils/utils.ss Fix frees for arr to use `fix-bounds' properly. Match : symbolically in ->* svn: r14786 --- .../typed-scheme/infer/constraint-structs.ss | 12 ------- collects/typed-scheme/rep/type-rep.ss | 36 ++++++++++++------- collects/typed-scheme/types/abbrev.ss | 26 +++++++------- collects/typed-scheme/utils/utils.ss | 17 +++++++-- 4 files changed, 53 insertions(+), 38 deletions(-) diff --git a/collects/typed-scheme/infer/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss index ef2bccc281..604c8caa53 100644 --- a/collects/typed-scheme/infer/constraint-structs.ss +++ b/collects/typed-scheme/infer/constraint-structs.ss @@ -31,18 +31,6 @@ ;; don't want to rule them out too early (define-struct cset (maps) #:prefab) - -(define (hashof k/c v/c) - (flat-named-contract - (format "#" k/c v/c) - (lambda (h) - (define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c)) - (define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c)) - (and (hash? h) - (for/and ([(k v) h]) - (and (k/c? k) - (v/c? v))))))) - (provide/contract (struct c ([S Type?] [X symbol?] [T Type?])) (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)])) (struct dcon-exact ([fixed (listof c?)] [rest c?])) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 0d470720b8..76c0144302 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -146,18 +146,30 @@ [rest (or/c #f Type/c)] [drest (or/c #f (cons/c Type/c (or/c natural-number/c symbol?)))] [kws (listof Keyword?)]) - [#:frees (lambda (free*) - (combine-frees - (append (map (compose flip-variances free*) - (append (if rest (list rest) null) - (map Keyword-ty kws) - dom)) - (match drest - [(cons t (? symbol? bnd)) - (list (fix-bound (flip-variances (free* t)) bnd))] - [(cons t (? number? bnd)) (list (flip-variances (free* t)))] - [#f null]) - (list (free* rng)))))] + [#:frees (combine-frees + (append (map (compose flip-variances free-vars*) + (append (if rest (list rest) null) + (map Keyword-ty kws) + dom)) + (match drest + [(cons t (? symbol? bnd)) + (list (fix-bound (flip-variances (free-vars* t)) bnd))] + [(cons t (? number? bnd)) + (list (flip-variances (free-vars* t)))] + [#f null]) + (list (free-vars* rng)))) + (combine-frees + (append (map (compose flip-variances free-idxs*) + (append (if rest (list rest) null) + (map Keyword-ty kws) + dom)) + (match drest + [(cons t (? symbol? bnd)) + (list (flip-variances (free-idxs* t)))] + [(cons t (? number? bnd)) + (list (fix-bound (flip-variances (free-idxs* t)) bnd))] + [#f null]) + (list (free-idxs* rng))))] [#:fold-rhs (*arr (map type-rec-id dom) (type-rec-id rng) (and rest (type-rec-id rest)) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 52c43d6fdd..4178ea1a49 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -172,20 +172,22 @@ (make-Values (list (-result rng filters obj)))) rest drest (sort #:key Keyword-kw kws keyword* - (syntax-rules (:) +(define-syntax (->* stx) + (define-syntax-class c + (pattern x:id #:when (eq? ': (syntax-e #'x)))) + (syntax-parse stx [(_ dom rng) - (make-Function (list (make-arr* dom rng)))] + #'(make-Function (list (make-arr* dom rng)))] [(_ dom rst rng) - (make-Function (list (make-arr* dom rng #:rest rst)))] - [(_ dom rng : filters) - (make-Function (list (make-arr* dom rng #:filters filters)))] - [(_ dom rng : filters : object) - (make-Function (list (make-arr* dom rng #:filters filters #:object object)))] - [(_ dom rst rng : filters) - (make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))] - [(_ dom rst rng : filters : object) - (make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))])) + #'(make-Function (list (make-arr* dom rng #:rest rst)))] + [(_ dom rng :c filters) + #'(make-Function (list (make-arr* dom rng #:filters filters)))] + [(_ dom rng _:c filters _:c object) + #'(make-Function (list (make-arr* dom rng #:filters filters #:object object)))] + [(_ dom rst rng _:c filters) + #'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))] + [(_ dom rst rng _:c filters : object) + #'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))])) (define-syntax (-> stx) (define-syntax-class c diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 69041a536c..79c0b38517 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -23,7 +23,8 @@ at least theoretically. in-syntax symbol-append custom-printer - rep utils typecheck infer env private) + rep utils typecheck infer env private + hashof) (define-syntax (define-requirer stx) (syntax-parse stx @@ -318,4 +319,16 @@ at least theoretically. [(_ nm cnt) (if enable-contracts? (list #'[contracted (nm cnt)]) - (list #'nm))])) \ No newline at end of file + (list #'nm))])) + + +(define (hashof k/c v/c) + (flat-named-contract + (format "#" k/c v/c) + (lambda (h) + (define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c)) + (define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c)) + (and (hash? h) + (for/and ([(k v) h]) + (and (k/c? k) + (v/c? v))))))) \ No newline at end of file From 82c6720bc9d0ca4e31be19b31630a5781f39949b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 19:54:09 +0000 Subject: [PATCH 112/156] Fix more tests for false info svn: r14787 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index d3c50970f0..5def5fe1db 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -690,13 +690,13 @@ (lambda: ([y : (a ... a -> Number)]) (apply y zs)) ys))) - (-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N))))] + (-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N)) : (-LFS null (list (make-LBot)))))] [tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *] (lambda: [zs : a ... a] (map (lambda: ([y : (a ... a -> Number)]) (apply y zs)) ys))) - (-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N))))] + (-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N)) : (-LFS null (list (make-LBot)))))] [tc-e/t (lambda: ((x : (All (t) t))) ((inst (inst x (All (t) (t -> t))) From a8a64cfa7c6f50b7f01ecfe4f06f02e4ed769708 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 20:56:32 +0000 Subject: [PATCH 113/156] Special case for `call-with-values' handle subtyping with ... args svn: r14788 --- collects/typed-scheme/typecheck/tc-app.ss | 9 +++++++-- collects/typed-scheme/types/subtype.ss | 9 ++++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 8ac95e8236..9d3be77b06 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -211,12 +211,12 @@ (do-ret (car rngs*))] [(and (car drests*) (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values #f #f))]) + (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (tc/dots tail))]) (and tail-ty (eq? (cdr (car drests*)) tail-bound) (subtypes arg-tys (car doms*)) - (subtype tail-ty (car (car drests*)))))) + (subtype tail-ty (car (car drests*)))))) (printf/log "Non-poly apply, ... arg\n") (do-ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] @@ -365,6 +365,11 @@ #:literals (#%plain-app #%plain-lambda letrec-values quote values apply k:apply not list list* call-with-values do-make-object make-object cons andmap ormap) + ;; call-with-values + [(#%plain-app call-with-values prod con) + (match (tc/funapp #'prod #'() (single-value #'prod) null #f) + [(tc-results: ts fs os) + (tc/funapp #'con #'prod (single-value #'con) (map ret ts fs os) expected)])] ;; in eq? cases, call tc/eq [(#%plain-app eq?:comparator v1 v2) ;; make sure the whole expression is type correct diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 39570982e8..2ef1ba0b99 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -150,7 +150,14 @@ (subtype* t-rest s-rest) (kw-subtypes* t-kws s-kws) (subtype* s-rng t-rng))] - ;; FIXME - handle dotted varargs + ;; handle ... varargs when the bounds are the same + [((arr: s-dom s-rng #f (cons s-drest dbound) s-kws) + (arr: t-dom t-rng #f (cons t-drest dbound) t-kws)) + (subtype-seq A0 + (subtype* t-drest s-drest) + (subtypes* t-dom s-dom) + (kw-subtypes* t-kws s-kws) + (subtype* s-rng t-rng))] [(_ _) (fail! s t)]))) From 8fc6e38b1195cae7463ca277a8e2b06678961eb7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 21:31:21 +0000 Subject: [PATCH 114/156] Fix inference when filters/objects are not needed svn: r14790 --- collects/typed-scheme/infer/infer-unit.ss | 7 ++++++- collects/typed-scheme/typecheck/tc-app.ss | 4 ++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 7981b69d4d..71149d8f0b 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -393,6 +393,10 @@ [((Result: s f o) (Result: t f o)) (cg s t)] + ;; handle the trivial case where we need to filters/etc + [((Result: s f o) + (Result: t (LFilterSet: '() '()) (LEmpty:))) + (cg s t)] [(_ _) (cond [(subtype S T) empty] ;; or, nothing worked, and we fail @@ -452,6 +456,7 @@ (define (infer X S T R must-vars [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let ([cs (cgen/list null X S T)]) + ;(printf "cs: ~a~n" cs) (if (not expected) (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) @@ -486,4 +491,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -;(trace cgen subst-gen) +;(trace cgen/list) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 9d3be77b06..5ce4164805 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -259,7 +259,7 @@ (fv (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg - [(and (car drests*) + [(and (car drests*) tail-bound (eq? tail-bound (cdr (car drests*))) (= (length (car doms*)) @@ -316,7 +316,7 @@ tail-bound (eq? tail-bound (cdr (car drests*))) (= (length (car doms*)) - (length arg-tys)) + (length arg-tys)) (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] From 54eb4cc314dc31b7afdffcf5a1e00d70e02721fd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 21:50:16 +0000 Subject: [PATCH 115/156] formatting svn: r14791 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 5def5fe1db..12a14ae385 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -679,9 +679,9 @@ 3 (list #\c) (map list (map list as))))] [tc-e/t (plambda: (a ...) [as : a ... a] - (apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c) - 3 (list #\c) (map list as))) - (-polydots (a) ((list) (a a) . ->... . -Integer))] + (apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c) + 3 (list #\c) (map list as))) + (-polydots (a) ((list) (a a) . ->... . -Integer))] ;; First is same as second, but with map explicitly instantiated. [tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *] From f349525244ffac48741b12a147789cbbedd21852 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 12 May 2009 21:51:01 +0000 Subject: [PATCH 116/156] Contracts for lexical-env Fix type of quotient/remainer function svn: r14792 --- collects/typed-scheme/env/lexical-env.ss | 9 +++++++-- collects/typed-scheme/private/base-env.ss | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index b61332399a..51b7d22e68 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -3,10 +3,15 @@ (require (except-in "../utils/utils.ss" extend)) (require "type-environments.ss" "type-env.ss" + (only-in scheme/contract ->* ->) (utils tc-utils mutated-vars) - (types utils convenience)) + (only-in (rep type-rep) Type/c) + (except-in (types utils convenience) -> ->*)) -(provide (all-defined-out)) +(provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical) +(p/c + [lookup-type/lexical ((identifier?) (env?) . ->* . Type/c)] + [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)]) ;; the current lexical environment (define lexical-env (make-parameter (make-empty-env free-identifier=?))) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 398fd0e782..2c30681288 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -270,7 +270,7 @@ [quotient (-Integer -Integer . -> . -Integer)] [remainder (-Integer -Integer . -> . -Integer)] [quotient/remainder - (make-arr (list -Integer -Integer) (-values (list -Integer -Integer)))] + (make-Function (list (make-arr (list -Integer -Integer) (-values (list -Integer -Integer)))))] ;; parameter stuff From 8ca532220a402daace37d5b539d5c95c85e83544 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 13 May 2009 14:34:44 +0000 Subject: [PATCH 117/156] Enable inference for ((lambda with rest args when no annotation on rest arg svn: r14794 --- collects/typed-scheme/typecheck/tc-app.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 5ce4164805..1accdc8f71 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -456,13 +456,13 @@ (tc/let-values #'((x) ...) #'(args ...) #'body #'(let-values ([(x) args] ...) . body) expected)] - ;; FIXME - make this work - doesn't work because the annotation - ;; on rst is not a normal annotation, may have * or ... - ;; inference for ((lambda with dotted rest - #; + ;; inference for ((lambda with dotted rest [(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) #:when (<= (length (syntax->list #'(x ...))) (length (syntax->list #'(args ...)))) + ;; FIXME - remove this restriction - doesn't work because the annotation + ;; on rst is not a normal annotation, may have * or ... + #:when (not (type-annotation #'rst)) (let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) (with-syntax ([(fixed-args ...) fixed-args] [varg #`(#%plain-app list #,@varargs)]) From a3fb3575f9daccccc8ec053d585f3e8e9e192748 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 13 May 2009 16:16:39 +0000 Subject: [PATCH 118/156] rationalize get-type/infer to handle tc-results. Fix tc-let to handle tc-results in various places. svn: r14796 --- .../typed-scheme/private/type-annotation.ss | 33 ++++++++------- .../typed-scheme/typecheck/tc-let-unit.ss | 40 +++++-------------- 2 files changed, 26 insertions(+), 47 deletions(-) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index ae5fc69a95..e63b943c4e 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -4,8 +4,9 @@ (require (rep type-rep) (utils tc-utils) (env type-env) - (types subtype union convenience resolve) + (except-in (types subtype union convenience resolve utils) -> ->*) (private parse-type) + (only-in scheme/contract listof ->) scheme/match mzlib/trace) (provide type-annotation get-type @@ -89,40 +90,38 @@ (define (get-types stxs #:default [default #f]) (map (lambda (e) (get-type e #:default default)) stxs)) -;; get the type annotations on this list of identifiers -;; if not all identifiers have annotations, return the supplied inferred type -;; list[identifier] type -> list[type] -(define (get-type/infer stxs expr tc-expr tc-expr/check) +;; list[identifier] stx (stx -> tc-results?) (stx tc-results? -> tc-results?) -> tc-results? +(d/c (get-type/infer stxs expr tc-expr tc-expr/check) + ((listof identifier?) syntax? (syntax? . -> . tc-results?) (syntax? tc-results? . -> . tc-results?) . -> . tc-results?) (match stxs ['() - (tc-expr/check expr (-values null)) - (list)] + (tc-expr/check expr (ret null))] [(list stx) (cond [(type-annotation stx #:infer #t) => (lambda (ann) - (list (tc-expr/check expr ann)))] - [else (list (tc-expr expr))])] + (tc-expr/check expr (ret ann)))] + [else (tc-expr expr)])] [(list stx ...) (let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))]) (if (for/and ([a anns]) a) - (begin (tc-expr/check expr (-values anns)) anns) + (begin (tc-expr/check expr (ret anns))) (let ([ty (tc-expr expr)]) (match ty - [(Values: tys) + [(tc-results: tys) (if (not (= (length stxs) (length tys))) (begin (tc-error/delayed "Expression should produce ~a values, but produces ~a values of types ~a" (length stxs) (length tys) (stringify tys)) - (map (lambda _ (Un)) stxs)) - (map (lambda (stx ty a) - (cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)] - [else #;(log/noann stx ty) ty])) - stxs tys anns))] + (ret (map (lambda _ (Un)) stxs))) + (ret + (for/list ([stx stxs] [ty tys] [a anns]) + (cond [a => (lambda (ann) (check-type stx ty ann) ann)] + [else ty]))))] [ty (tc-error/delayed "Expression should produce ~a values, but produces one values of type ~a" (length stxs) ty) - (map (lambda _ (Un)) stxs)]))))])) + (ret (map (lambda _ (Un)) stxs))]))))])) ;; check that e-type is compatible with ty in context of stx diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index e1aa8fda99..d683efa9e9 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -34,27 +34,6 @@ (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body))))) -#| -;; this is more abstract, but sucks - (define ((mk f) namess exprs body form) - (let* ([names (map syntax->list (syntax->list namess))] - [exprs (syntax->list exprs)]) - (f (lambda (e->t namess types exprs) (do-check e->t namess types form exprs body)) names exprs))) - - (define tc/letrec-values - (mk (lambda (do names exprs) - (let ([types (map (lambda (l) (map get-type l)) names)]) - (do tc-expr/t names types exprs))))) - - (define tc/let-values - (mk (lambda (do names exprs) - (let* (;; the types of the exprs - [inferred-types (map tc-expr/t exprs)] - ;; the annotated types of the name (possibly using the inferred types) - [types (map get-type/infer names inferred-types)]) - (do (lambda (x) x) names types inferred-types))))) - |# - (define (tc/letrec-values/check namess exprs body form expected) (tc/letrec-values/internal namess exprs body form expected)) @@ -72,8 +51,7 @@ (andmap values expecteds) (tc-expr/check e (mk expecteds)) (tc-expr e))) - (match tcr - [(tc-result1: t) t])) + tcr) (define (tc/letrec-values/internal namess exprs body form expected) (let* ([names (map syntax->list (syntax->list namess))] @@ -100,8 +78,9 @@ ;; then check this expression separately (with-lexical-env/extend (list (car names)) - (list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) - (lambda (e t) (tc-expr/check/t e (ret t))))) + (list (match (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) + tc-expr/check) + [(tc-results: ts) ts])) (loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))] [else ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names) @@ -115,9 +94,8 @@ [(#%plain-lambda () _) (and expected (syntax-property e 'typechecker:called-in-tail-position)) (begin - (tc-expr/check e (-> expected)) - (-> expected))] - [_ (tc-expr/t e)])) + (tc-expr/check e (ret (-> expected))))] + [_ (tc-expr e)])) (define (tc/let-values namess exprs body form [expected #f]) (let* (;; a list of each name clause @@ -127,8 +105,10 @@ ;; the types of the exprs #;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)] ;; the annotated types of the name (possibly using the inferred types) - [types (for/list ([name names] [e exprs]) (get-type/infer name e (tc-expr-t/maybe-expected expected) - (lambda (e t) (tc-expr/check/t e (ret t)))))] + [types (for/list ([name names] [e exprs]) + (match (get-type/infer name e (tc-expr-t/maybe-expected expected) + tc-expr/check) + [(tc-results: ts) ts]))] ;; the clauses for error reporting [clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])]) (do-check void names types form types body clauses expected))) From 5f1b4a7daf99c2db91b1b9c1685a0dc9ef65614e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 13 May 2009 16:17:01 +0000 Subject: [PATCH 119/156] Fix two tests svn: r14797 --- .../typed-scheme/unit-tests/typecheck-tests.ss | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 12a14ae385..e1451fcb15 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -151,7 +151,7 @@ [tc-e (let: ([x : Number 5]) x) #:proc (get-let-name x 0 (-path -Number #'x))] [tc-e (let-values ([(x) 4]) (+ x 1)) -Integer] [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) - #:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS (list (make-TypeFilter (-val #f) #'y)) null))])] + #:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS (list (make-TypeFilter (-val #f) null #'y)) null))])] [tc-e/t (values 3) -Integer] [tc-e (values) #:ret (ret null)] [tc-e (values 3 #f) #:ret (ret (list -Integer (-val #f)) (list (-FS (list) (list (make-Bot))) (-FS (list (make-Bot)) (list))))] @@ -559,14 +559,14 @@ (* x z)) -Integer] - [tc-e (let () - (define: (f [x : Number]) : Number - (define: (g [y : Number]) : Number - (let*-values ([(#{z : Number} #{w : Number}) (values (g (f x)) 5)]) - (+ z w))) - (g 4)) - 5) - -Integer] + [tc-e/t (let () + (define: (f [x : Number]) : Number + (define: (g [y : Number]) : Number + (let*-values ([(#{z : Number} #{w : Number}) (values (g (f x)) 5)]) + (+ z w))) + (g 4)) + 5) + -Integer] [tc-err (let () (define x x) From 88159e24792f0e69d324b31b5fabb4b91e4e4ca9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 13 May 2009 21:25:41 +0000 Subject: [PATCH 120/156] add require svn: r14798 --- collects/tests/typed-scheme/unit-tests/infer-tests.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index 5159f9baee..0e60fbc341 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) (r:infer infer) - (types convenience union utils) + (types convenience union utils abbrev) (schemeunit)) From a47bb9e8c398c86607071632cce1bcf8f840d310 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 13 May 2009 21:25:56 +0000 Subject: [PATCH 121/156] inference for filters and objects svn: r14799 --- collects/typed-scheme/infer/infer-unit.ss | 53 +++++++++++++++-------- 1 file changed, 34 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 71149d8f0b..340550ef42 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -96,21 +96,38 @@ dmap))) cset)) -;; t and s must be *latent* effects -(define (cgen/eff V X t s) +;; t and s must be *latent* filters +(define (cgen/filter V X t s) (match* (t s) [(e e) (empty-cset X)] - ;; FIXME - do something here - #;#; - [((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: s)) - (cset-meet (cgen V X t s) (cgen V X s t))] - [((Latent-Remove-Effect: t) (Latent-Remove-Effect: s)) - (cset-meet (cgen V X t s) (cgen V X s t))] + ;; FIXME - is there something to be said about LBot? + [((LTypeFilter: t p i) (LTypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))] + [((LNotTypeFilter: t p i) (LNotTypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))] [(_ _) (fail! t s)])) -(define (cgen/eff/list V X ts ss) - (unless (>= (length ts) (length ss)) (fail! ts ss)) - (cset-meet* (for/list ([t ts] [s ss]) (cgen/eff V X t s)))) +(define (cgen/filters V X ts ss) + (cond + [(null? ss) (empty-cset X)] + ;; FIXME - this can be less conservative + [(= (length ts) (length ss)) + (cset-meet* (for/list ([t ts] [s ss]) (cgen/filter V X t s)))] + [else (fail! ts ss)])) + + +;; t and s must be *latent* filter sets +(define (cgen/filter-set V X t s) + (match* (t s) + [(e e) (empty-cset X)] + [((LFilterSet: t+ t-) (LFilterSet: s+ s-)) + (cset-meet (cgen/filters V X t+ s+) (cgen/filters V X t- s-))] + [(_ _) (fail! t s)])) + +(define (cgen/object V X t s) + (match* (t s) + [(e e) (empty-cset X)] + [(e (LEmpty:)) (empty-cset X)] + ;; FIXME - do something here + [(_ _) (fail! t s)])) (define (cgen/arr V X t-arr s-arr) (define (cg S T) (cgen V X S T)) @@ -390,13 +407,11 @@ (with-handlers ([exn:infer? (lambda (_) #f)]) (cgen/arr V X t-arr s-arr)))))] ;; this is overly conservative - [((Result: s f o) - (Result: t f o)) - (cg s t)] - ;; handle the trivial case where we need to filters/etc - [((Result: s f o) - (Result: t (LFilterSet: '() '()) (LEmpty:))) - (cg s t)] + [((Result: s f-s o-s) + (Result: t f-t o-t)) + (cset-meet* (list (cg s t) + (cgen/filter-set V X f-s f-t) + (cgen/object V X o-s o-t)))] [(_ _) (cond [(subtype S T) empty] ;; or, nothing worked, and we fail @@ -491,4 +506,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -;(trace cgen/list) +;(trace cgen cgen/filters cgen/filter) From b30338e0c55fcef33a43a844d963ad8cdcee998b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 14:45:07 +0000 Subject: [PATCH 122/156] Add start of type->contract test suite. Add test for poly annotation failure. svn: r14809 --- .../typed-scheme/unit-tests/all-tests.ss | 4 +++- .../typed-scheme/unit-tests/contract-tests.ss | 21 +++++++++++++++++++ .../unit-tests/typecheck-tests.ss | 3 +++ 3 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/unit-tests/contract-tests.ss diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index cc94dbb81b..7643cc07f9 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -12,6 +12,7 @@ "module-tests.ss" ;; pass "subst-tests.ss" ;; pass "infer-tests.ss" ;; pass + "contract-tests.ss" ) (require (r:infer infer infer-dummy) @@ -35,7 +36,8 @@ parse-type-tests type-annotation-tests module-tests - fv-tests)]) + fv-tests + contract-tests)]) (f)))) diff --git a/collects/tests/typed-scheme/unit-tests/contract-tests.ss b/collects/tests/typed-scheme/unit-tests/contract-tests.ss new file mode 100644 index 0000000000..a8b0f5ce4b --- /dev/null +++ b/collects/tests/typed-scheme/unit-tests/contract-tests.ss @@ -0,0 +1,21 @@ +#lang scheme/base + +(require "test-utils.ss" "planet-requires.ss" + (for-syntax scheme/base) + (for-template scheme/base) + (private type-contract) + (rep type-rep filter-rep object-rep) + (types utils union convenience) + (utils tc-utils mutated-vars) + (schemeunit) + stxclass) + +(define-syntax-rule (t e) + (test-not-exn (format "~a" e) (lambda () (type->contract e (lambda _ (error "type could not be converted to contract")))))) + +(define (contract-tests) + (test-suite "Contract Tests" + (t (-Number . -> . -Number)))) + +(define-go contract-tests) +(provide contract-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index e1451fcb15..60b3b38210 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -714,6 +714,9 @@ [tc-e (assq 'foo #{'((a b) (foo bar)) :: (Listof (List Symbol Symbol))}) (Un (-val #f) (-pair Sym (-pair Sym (-val null))))] + [tc-e/t (ann (lambda (x) x) (All (a) (a -> a))) + (-poly (a) (a . -> . a))] + #;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20))] From d8c613494e838711d2b85cc61607238d4c36baad Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 14:45:24 +0000 Subject: [PATCH 123/156] Fix type->contract of function types. svn: r14810 --- collects/typed-scheme/private/type-contract.ss | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 87377316e5..a4f22f20b6 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -70,18 +70,13 @@ #;(printf "~a~n" (syntax-object->datum #'cnts)) #'(or/c . cnts))] [(Function: arrs) - (let () + (let () (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f '()) - (values (map t->c/neg dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f '()) - (values (map t->c/neg dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f '() ) - (values (map t->c/neg dom) (map t->c rngs) (t->c/neg rst))] - [(arr: dom rng rst #f '()) - (values (map t->c/neg dom) (list (t->c rng)) (t->c/neg rst))])) + [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) + (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] + [_ (exit (fail))])) (with-syntax ([(dom* ...) dom*] [rng* (match rngs* From 775fa34f5f0ffeef340e477192606a5beea4734a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 15:11:33 +0000 Subject: [PATCH 124/156] Add some contracts in tc/plambda. Fix handling of tc-results vs types. svn: r14812 --- .../typed-scheme/typecheck/tc-lambda-unit.ss | 27 +++++++++++-------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 49a821e614..551a78ab7f 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -214,14 +214,16 @@ ;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; formals and bodies must by syntax-lists -(define (tc/plambda form formals bodies expected) - (define (maybe-loop form formals bodies expected) +(d/c (tc/plambda form formals bodies expected) + (syntax? syntax? syntax? (or/c tc-results? #f) . --> . Type/c) + (d/c (maybe-loop form formals bodies expected) + (syntax? syntax? syntax? tc-results? . --> . Type/c) (match expected - [(Function: _) (tc/mono-lambda/type formals bodies expected)] - [(or (Poly: _ _) (PolyDots: _ _)) + [(tc-result1: (Function: _)) (tc/mono-lambda/type formals bodies expected)] + [(tc-result1: (or (Poly: _ _) (PolyDots: _ _))) (tc/plambda form formals bodies expected)])) (match expected - [(Poly-names: ns expected*) + [(tc-result1: (and t (Poly-names: ns expected*))) (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) (when (and (pair? p) (eq? '... (car (last p)))) (tc-error "Expected a polymorphic function without ..., but given function had ...")) @@ -230,10 +232,10 @@ [literal-tvars tvars] [new-tvars (map make-F literal-tvars)] [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) - (maybe-loop form formals bodies expected*))]) + (maybe-loop form formals bodies (ret expected*)))]) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) - expected)] - [(PolyDots-names: (list ns ... dvar) expected*) + t)] + [(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*))) (let-values ([(tvars dotted) (let ([p (syntax-property form 'typechecker:plambda)]) @@ -249,8 +251,8 @@ (cons (make-Dotted (make-F dotted)) new-tvars) (current-tvars))]) - (maybe-loop form formals bodies expected*))]) - expected))] + (maybe-loop form formals bodies (ret expected*)))]) + t))] [#f (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda))) [(list tvars ... dotted-var '...) @@ -276,7 +278,10 @@ ;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic ;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result (define (tc/lambda/internal form formals bodies expected) - (if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) + (if (or (syntax-property form 'typechecker:plambda) + (match expected + [(tc-result1: t) (or (Poly? t) (PolyDots? t))] + [_ #f])) (ret (tc/plambda form formals bodies expected) true-filter) (ret (tc/mono-lambda/type formals bodies expected) true-filter))) From 1047f7625d2dfa53d2896fa44fde732873d86ba4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 18:57:02 +0000 Subject: [PATCH 125/156] Handle ValuesDots in check-below. Fix typo in valuesdots handling in values->tc-results Handle ValuesDots in do-ret. Don't try to construct silly wrappers for `apply values' Don't use rest as list extension if it's #f Fix tc-result handling for check-subforms/check Add stronger contracts for Scope Always generate substitution for infer/dots. Fix type of `time-apply' svn: r14815 --- collects/typed-scheme/env/type-alias-env.ss | 2 -- collects/typed-scheme/infer/infer-unit.ss | 2 +- collects/typed-scheme/private/base-env.ss | 10 ++++++---- collects/typed-scheme/rep/type-rep.ss | 13 ++++++------ .../typecheck/check-subforms-unit.ss | 5 +++-- collects/typed-scheme/typecheck/signatures.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 20 +++++++++++-------- .../typed-scheme/typecheck/tc-expr-unit.ss | 4 ++++ .../typecheck/tc-metafunctions.ss | 2 +- collects/typed-scheme/typed-scheme.ss | 2 +- 10 files changed, 36 insertions(+), 26 deletions(-) diff --git a/collects/typed-scheme/env/type-alias-env.ss b/collects/typed-scheme/env/type-alias-env.ss index dd9183d32c..f8506de824 100644 --- a/collects/typed-scheme/env/type-alias-env.ss +++ b/collects/typed-scheme/env/type-alias-env.ss @@ -31,8 +31,6 @@ (mapping-put! id (make-unresolved stx #f))) (define (register-resolved-type-alias id ty) - #;(when (eq? 'Number (syntax-e id)) - (printf "registering type ~a ~a~n~a~n" id (syntax-e id) ty)) (mapping-put! id (make-resolved ty))) (define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))]) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 340550ef42..ee36c67cb5 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -498,7 +498,7 @@ [cs (cset-meet cs-short cs-dotted*)]) (if (not expected) (subst-gen cs R must-vars) - (cset-meet cs (cgen null X R expected)))))) + (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) (define (infer/simple S T R) (infer (fv/list T) S T R)) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 2c30681288..c70355ae16 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -259,10 +259,12 @@ [apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] -[time-apply (-polydots (b a) (make-arr - (list ((list) (a a) . ->... . b) - (-lst a)) - (-values (list (-pair b (-val '())) N N N))))] +[time-apply (-polydots (b a) + (make-Function + (list (make-arr + (list ((list) (a a) . ->... . b) + (-lst a)) + (-values (list (-pair b (-val '())) N N N))))))] [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] [call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 76c0144302..bcebb693da 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -10,30 +10,31 @@ (define name-table (make-weak-hasheq)) -(define Type/c - (flat-named-contract - 'Type +(define Type/c? (λ (e) (and (Type? e) (not (Scope? e)) (not (arr? e)) (not (Values? e)) (not (ValuesDots? e)) - (not (Result? e)))))) + (not (Result? e))))) + +(define Type/c + (flat-named-contract 'Type Type/c?)) ;; Name = Symbol ;; Type is defined in rep-utils.ss ;; t must be a Type -(dt Scope ([t Type?]) [#:key (Type-key t)]) +(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) (lambda (sc) (define (f k sc) - (cond [(= 0 k) (not (Scope? sc))] + (cond [(= 0 k) (Type/c? sc)] [(not (Scope? sc)) #f] [else (f (sub1 k) (Scope-t sc))])) (f k sc)))) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss index 3e93d5eaa3..3ab084dc2e 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -61,7 +61,8 @@ [stx ;; this is a hander function (syntax-property form 'typechecker:exn-handler) - (tc-expr/check form (-> (Un) expected))] + (tc-expr/check form (match expected + [(tc-result1: e) (ret (-> (Un) e))]))] [stx ;; this is the body of the with-handlers (syntax-property form 'typechecker:exn-body) @@ -71,7 +72,7 @@ (loop #'a) (loop #'b))] [_ (void)]))) - (ret expected)) + expected) ;; typecheck the expansion of a with-handlers form ;; syntax -> any diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index f50e5f923e..c8a5eeb528 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -23,7 +23,7 @@ (define-signature check-subforms^ ([cnt check-subforms/ignore (syntax? . -> . any)] [cnt check-subforms/with-handlers (syntax? . -> . any)] - [cnt check-subforms/with-handlers/check (syntax? Type/c . -> . any)])) + [cnt check-subforms/with-handlers/check (syntax? tc-results? . -> . any)])) (define-signature tc-if^ ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 1accdc8f71..6f92e70b1a 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -167,7 +167,9 @@ (define (tc/apply f args) (define (do-ret t) - (match t [(Values: (list (Result: ts _ _) ...)) (ret ts)])) + (match t + [(Values: (list (Result: ts _ _) ...)) (ret ts)] + [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)])) (define f-ty (single-value f)) ;; produces the first n-1 elements of the list, and the last element (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) @@ -385,10 +387,10 @@ [(#%plain-app apply values e) (cond [(with-handlers ([exn:fail? (lambda _ #f)]) (untuple (tc-expr/t #'e))) - => (lambda (t) (ret (-values t)))] + => ret] [else (tc/apply #'values #'(e))])] ;; rewrite this so that it takes advantages of all the special cases - [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (apply . args)) expected)] + [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)] ;; handle apply specially [(#%plain-app apply f . args) (tc/apply #'f #'args)] ;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value @@ -543,8 +545,8 @@ t argtys expected)] ;; polymorphic ... type [((tc-result1: (and t (PolyDots: - (and vars (list fixed-vars ... dotted-var)) - (Function: (list (and arrs (arr: doms rngs (and #f rests) (cons dtys dbounds) '())) ...))))) + (and vars (list fixed-vars ... dotted-var)) + (Function: (list (and arrs (arr: doms rngs (and #f rests) (cons dtys dbounds) '())) ...))))) (list (tc-result1: argtys-t) ...)) (handle-clauses (doms dtys dbounds rngs arrs) f-stx args-stx (lambda (dom dty dbound rng arr) (and (<= (length dom) (length argtys)) @@ -577,8 +579,10 @@ ;; error type is a perfectly good fcn type [((tc-result1: (Error:)) _) (ret (make-Error))] ;; otherwise fail - [((tc-result1: f-ty) _) (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" f-ty)])) + [((tc-result1: f-ty) _) + ;(printf "ft: ~a argt: ~a~n" ftype0 argtys) + (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" f-ty)])) ;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? @@ -593,7 +597,7 @@ [(and rest (< (length t-a) (length dom))) (tc-error/expr #:return (ret t-r) "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) - (for ([dom-t (in-list-forever dom rest)] [a (syntax->list args-stx)] [arg-t (in-list t-a)]) + (for ([dom-t (if rest (in-list-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)]) (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (let* (;; Listof[Listof[LFilterSet]] [lfs-f (for/list ([lf lf-r]) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index cb55d1abaf..6661dd7f49 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -137,6 +137,10 @@ (unless (andmap subtype t1 t2) (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) expected] + [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound)) + (unless (andmap subtype t1 t2) + (tc-error/expr "1.5 Expected ~a, but got ~a" t2 t1)) + expected] [((tc-result1: t1 f o) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 6487fb093b..1a1d17c22a 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -146,7 +146,7 @@ ;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results? (define (values->tc-results tc formals) (match tc - [(ValuesDots: (list (Result: ts lfs los)) dty dbound) + [(ValuesDots: (list (Result: ts lfs los) ...) dty dbound) (ret ts (for/list ([lf lfs]) (merge-filter-sets diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 5646b76a53..e9249d8723 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -49,7 +49,7 @@ ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))) (lambda (e) (tc-error "Internal error: ~a" e))])] [parameterize (;; disable fancy printing - [custom-printer #t] + [custom-printer #f] ;; a cheat to avoid units [infer-param infer] ;; do we report multiple errors From af623cbdc7a021caefe909460df7ec59212e138f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 18:57:23 +0000 Subject: [PATCH 126/156] add test of `apply values' svn: r14816 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 60b3b38210..0033156b05 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -716,7 +716,7 @@ [tc-e/t (ann (lambda (x) x) (All (a) (a -> a))) (-poly (a) (a . -> . a))] - + [tc-e (apply values (list 1 2 3)) #:ret (ret (list -Integer -Integer -Integer))] #;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20))] From 792bacbd557e6395516f2d1d6686ce527014444e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 14 May 2009 18:57:43 +0000 Subject: [PATCH 127/156] turn printing back on svn: r14817 --- collects/typed-scheme/typed-scheme.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index e9249d8723..5646b76a53 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -49,7 +49,7 @@ ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))) (lambda (e) (tc-error "Internal error: ~a" e))])] [parameterize (;; disable fancy printing - [custom-printer #f] + [custom-printer #t] ;; a cheat to avoid units [infer-param infer] ;; do we report multiple errors From b2cf9c0006bb8db35d1de5a0d48042d8958b48c2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 15 May 2009 15:05:53 +0000 Subject: [PATCH 128/156] Fix typo so cdrs in paths are handled. svn: r14826 --- collects/typed-scheme/typecheck/tc-envops.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index da851f3839..c3a5bd4c2e 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -31,7 +31,7 @@ (make-Pair (update t (make-TypeFilter u rst x)) s)] [((Pair: t s) (NotTypeFilter: u (list* (CarPE:) rst) x)) (make-Pair (update t (make-NotTypeFilter u rst x)) s)] - [((Pair: t s) (TypeFilter: u (list* (CarPE:) rst) x)) + [((Pair: t s) (TypeFilter: u (list* (CdrPE:) rst) x)) (make-Pair t (update s (make-TypeFilter u rst x)))] [((Pair: t s) (NotTypeFilter: u (list* (CdrPE:) rst) x)) (make-Pair t (update s (make-NotTypeFilter u rst x)))] @@ -49,7 +49,7 @@ (restrict t u)] [(t (NotTypeFilter: u (list) _)) (remove t u)] - [(_ _) + [(t lo) (int-err "update along ill-typed path: ~a ~a" t lo)])) (define/contract (env+ env fs) From ddefd28d6d2bc1b5bacb7f2ef6667e90d6ba8165 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 15 May 2009 15:47:22 +0000 Subject: [PATCH 129/156] Fix handling of structs-as-functions. Subtyping should look up names in both positions. svn: r14827 --- collects/typed-scheme/typecheck/tc-app.ss | 4 ++-- collects/typed-scheme/types/subtype.ss | 6 +++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 6f92e70b1a..21ec4c0684 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -555,8 +555,8 @@ (infer/dots fixed-vars dotted-var argtys-t dom dty rng (fv rng) #:expected (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs - [(tc-result1: (and sty (Struct: _ _ _ (? Type? proc-ty) _ _ _))) - (tc/funapp f-stx (cons (syntax/loc f-stx dummy) args-stx) (ret proc-ty) (cons sty argtys) expected)] + [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _))) _) + (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)] ;; parameters are functions too [((tc-result1: (Param: in out)) (list)) (ret out)] [((tc-result1: (Param: in out)) (list (tc-result1: t))) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 2ef1ba0b99..0a1e4768ca 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -303,10 +303,14 @@ v))] [(list (Name: n) other) (let ([t (lookup-type-name n)]) - ;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other) (if (Type? t) (subtype* A0 t other) (fail! s t)))] + [(list other (Name: n)) + (let ([t (lookup-type-name n)]) + (if (Type? t) + (subtype* A0 other t) + (fail! t s)))] ;; Promises are covariant [(list (Struct: 'Promise _ (list t) _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _)) (subtype* A0 t t*)] ;; subtyping on values is pointwise From 7a24d39348fc652863895491310d101cfd7513cd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 15 May 2009 15:47:57 +0000 Subject: [PATCH 130/156] make struct-exec a little more interesting svn: r14828 --- collects/tests/typed-scheme/succeed/struct-exec.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/succeed/struct-exec.ss b/collects/tests/typed-scheme/succeed/struct-exec.ss index 23fb3d0641..0964a5d9e4 100644 --- a/collects/tests/typed-scheme/succeed/struct-exec.ss +++ b/collects/tests/typed-scheme/succeed/struct-exec.ss @@ -1,3 +1,3 @@ #lang typed-scheme -(define-typed-struct/exec X ([a : Number] [b : Boolean]) [(lambda: ([x : X]) (+ 3 )) : (X -> Number)]) +(define-typed-struct/exec X ([a : Number] [b : Boolean]) [(lambda: ([x : X]) (+ 3 (X-a x))) : (X -> Number)]) ((make-X 1 #f)) From ef095c931a30c98adf4dc2f326780f62173be9bd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 18 May 2009 22:17:32 +0000 Subject: [PATCH 131/156] Make env struct transparent. svn: r14857 --- collects/typed-scheme/env/type-environments.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 3a0b5679a1..12c570c27e 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -20,7 +20,7 @@ with-dotted-env/extend) ;; eq? has the type of equal?, and l is an alist (with conses!) -(r:d-s/c env ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)])) +(r:d-s/c env ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)]) #:transparent) (define (env-vals e) (map cdr (env-l e))) From e269f7aa7c0bf75b823e5f67931b4a9c5fb61723 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 18 May 2009 22:18:19 +0000 Subject: [PATCH 132/156] Parse (A -> B : C) correctly, B can't be a `values' svn: r14858 --- collects/typed-scheme/private/parse-type.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index b72a67c4a4..ad172a1df5 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -356,7 +356,8 @@ (eq? (syntax-e #':) ':)) (begin (add-type-name-reference (stx-cadr stx)) - (make-pred-ty (list (parse-type #'dom)) (parse-values-type #'rng) (parse-type #'pred-ty)))] + ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty + (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty)))] [(dom ... rest ::: -> rng) (and (eq? (syntax-e #'->) '->) (eq? (syntax-e #':::) '*)) From b8f944679e9ff255d094c4b50baa619364ae2813 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 18 May 2009 22:18:47 +0000 Subject: [PATCH 133/156] take path elems from the end svn: r14859 --- collects/typed-scheme/typecheck/tc-envops.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index c3a5bd4c2e..673de7ff3b 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -27,21 +27,21 @@ (Type/c Filter/c . -> . Type/c) (match* ((resolve t) lo) ;; pair ops - [((Pair: t s) (TypeFilter: u (list* (CarPE:) rst) x)) + [((Pair: t s) (TypeFilter: u (list rst ... (CarPE:)) x)) (make-Pair (update t (make-TypeFilter u rst x)) s)] - [((Pair: t s) (NotTypeFilter: u (list* (CarPE:) rst) x)) + [((Pair: t s) (NotTypeFilter: u (list rst ... (CarPE:)) x)) (make-Pair (update t (make-NotTypeFilter u rst x)) s)] - [((Pair: t s) (TypeFilter: u (list* (CdrPE:) rst) x)) + [((Pair: t s) (TypeFilter: u (list rst ... (CdrPE:)) x)) (make-Pair t (update s (make-TypeFilter u rst x)))] - [((Pair: t s) (NotTypeFilter: u (list* (CdrPE:) rst) x)) + [((Pair: t s) (NotTypeFilter: u (list rst ... (CdrPE:)) x)) (make-Pair t (update s (make-NotTypeFilter u rst x)))] ;; struct ops [((Struct: nm par flds proc poly pred cert) - (TypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) + (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-TypeFilter u rst x)))) proc poly pred cert)] [((Struct: nm par flds proc poly pred cert) - (NotTypeFilter: u (list* (StructPE: (? (lambda (s) (subtype t s)) s) idx) rst) x)) + (NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-NotTypeFilter u rst x)))) proc poly pred cert)] ;; otherwise @@ -49,8 +49,8 @@ (restrict t u)] [(t (NotTypeFilter: u (list) _)) (remove t u)] - [(t lo) - (int-err "update along ill-typed path: ~a ~a" t lo)])) + [(t* lo) + (int-err "update along ill-typed path: ~a ~a ~a" t t* lo)])) (define/contract (env+ env fs) (env? (listof Filter/c) . -> . env?) From 5f1895cfb587de8072572cdd3090db8e355a3d26 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 18 May 2009 22:19:05 +0000 Subject: [PATCH 134/156] Remove tc/if-twoarm/check svn: r14860 --- collects/typed-scheme/typecheck/signatures.ss | 8 ++++---- collects/typed-scheme/typecheck/tc-expr-unit.ss | 2 +- collects/typed-scheme/typecheck/tc-new-if.ss | 2 -- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index c8a5eeb528..e902aa2463 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require scheme/unit scheme/contract "../utils/utils.ss") -(require (rep type-rep) +(require scheme/unit scheme/contract + "../utils/utils.ss" + (rep type-rep) (utils unit-utils) (types utils)) (provide (all-defined-out)) @@ -26,8 +27,7 @@ [cnt check-subforms/with-handlers/check (syntax? tc-results? . -> . any)])) (define-signature tc-if^ - ([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-results?)] - [cnt tc/if-twoarm/check (syntax? syntax? syntax? tc-results? . -> . tc-results?)])) + ([cnt tc/if-twoarm ((syntax? syntax? syntax?) (tc-results?) . ->* . tc-results?)])) (define-signature tc-lambda^ ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 6661dd7f49..7050b5e918 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -228,7 +228,7 @@ (begin (tc-exprs/check (syntax->list #'es) Univ) (tc-expr/check #'e expected))] ;; if - [(if tst thn els) (tc/if-twoarm/check #'tst #'thn #'els expected)] + [(if tst thn els) (tc/if-twoarm #'tst #'thn #'els expected)] ;; lambda [(#%plain-lambda formals . body) (tc/lambda/check form #'(formals) #'(body) expected)] diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss index 6d6bc87be9..09568dae04 100644 --- a/collects/typed-scheme/typecheck/tc-new-if.ss +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -36,5 +36,3 @@ [(tc-results: t _ _) (tc-error/expr #:return (ret (or expected Err)) "Test expression expects one value, given ~a" t)])) - -(define tc/if-twoarm/check tc/if-twoarm) \ No newline at end of file From f71249500992e1b9a0729b1340d7ecc20cd8d563 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 May 2009 15:23:57 +0000 Subject: [PATCH 135/156] add syntax locations to cond* macro svn: r14868 --- collects/tests/typed-scheme/succeed/little-schemer.ss | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/little-schemer.ss b/collects/tests/typed-scheme/succeed/little-schemer.ss index 2233e8d244..ea7bd5e509 100644 --- a/collects/tests/typed-scheme/succeed/little-schemer.ss +++ b/collects/tests/typed-scheme/succeed/little-schemer.ss @@ -17,10 +17,11 @@ (define-syntax (cond* stx) (syntax-case stx (else) [(_ [pred expr id rhs] . rest) - #'(let ([id expr]) - (if (pred id) - rhs - (cond . rest)))] + (quasisyntax/loc stx + (let ([id expr]) + (if (pred id) + rhs + #,(syntax/loc #'rest (cond . rest)))))] [(_ [else . rest]) #'(begin . rest)] [(_ [p . rhs] . rest) #'(if p (begin . rhs) From 0cd135c3bb0f2250fd23613ad07fc3d298eeb052 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 May 2009 15:24:12 +0000 Subject: [PATCH 136/156] Add test for unreachble code with expected type. svn: r14869 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 0033156b05..1afd30efe4 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -42,7 +42,7 @@ (define-syntax tc-l (syntax-rules () [(_ lit ty) - (check-type-equal? (format "~a" 'lit) (tc-literal #'lit) ty)])) + (check-type-equal? (format "~s" 'lit) (tc-literal #'lit) ty)])) ;; local-expand and then typecheck an expression (define-syntax (tc-expr/expand/values stx) @@ -72,7 +72,7 @@ [(_ expr #:proc p) (syntax/loc stx (let-values ([(t e) (tc-expr/expand/values expr)]) - (check-tc-result-equal? (format "~a" 'expr) (t) (p e))))] + (check-tc-result-equal? (format "~s" 'expr) (t) (p e))))] [(_ expr #:ret r) (syntax/loc stx (check-tc-result-equal? (format "~a" 'expr) (tc-expr/expand expr) r))] @@ -717,6 +717,8 @@ [tc-e/t (ann (lambda (x) x) (All (a) (a -> a))) (-poly (a) (a . -> . a))] [tc-e (apply values (list 1 2 3)) #:ret (ret (list -Integer -Integer -Integer))] + + [tc-e (ann (if #t 3 "foo") Integer) -Integer] #;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20))] From eedafc034b99545161a3a3d254cbf43d73cc8b55 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 May 2009 15:24:55 +0000 Subject: [PATCH 137/156] Add flag for testing unreachability in env+. Use flag in if-unit. svn: r14870 --- collects/typed-scheme/typecheck/tc-envops.ss | 13 ++++-- collects/typed-scheme/typecheck/tc-new-if.ss | 43 +++++++++++++------- 2 files changed, 38 insertions(+), 18 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index 673de7ff3b..380010a754 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -52,10 +52,15 @@ [(t* lo) (int-err "update along ill-typed path: ~a ~a ~a" t t* lo)])) -(define/contract (env+ env fs) - (env? (listof Filter/c) . -> . env?) +;; sets the flag box to #f if anything becomes (U) +(d/c (env+ env fs flag) + (env? (listof Filter/c) (box/c #t). -> . env?) (for/fold ([Γ env]) ([f fs]) (match f - [(Bot:) (env-map (lambda (x) (cons (car x) (Un))) Γ)] + [(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) - (update-type/lexical (lambda (x t) (update t f)) x Γ)]))) + (update-type/lexical (lambda (x t) (let ([new-t (update t f)]) + (when (type-equal? new-t (Un)) + (set-box! flag #f)) + new-t)) + x Γ)]))) diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-new-if.ss index 09568dae04..6ebe28c2c7 100644 --- a/collects/typed-scheme/typecheck/tc-new-if.ss +++ b/collects/typed-scheme/typecheck/tc-new-if.ss @@ -1,12 +1,12 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) +(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" (rep type-rep filter-rep object-rep) (rename-in (types convenience subtype union utils comparison remove-intersect) [remove *remove]) - (env lexical-env) + (env lexical-env type-environments) (r:infer infer) (utils tc-utils mutated-vars) (typecheck tc-envops tc-metafunctions) @@ -19,20 +19,35 @@ (export tc-if^) (define (tc/if-twoarm tst thn els [expected #f]) - (define (tc e) (if expected (tc-expr/check e expected) (tc-expr e))) + (define (tc expr reachable?) + (unless reachable? (warn-unreachable expr)) + (cond + ;; if reachable? is #f, then we don't want to verify that this branch has the appropriate type + ;; in particular, it might be (void) + [(and expected reachable?) + (tc-expr/check expr expected)] + ;; this code is reachable, but we have no expected type + [reachable? (tc-expr expr)] + ;; otherwise, this code is unreachable + ;; and the resulting type should be the empty type + [(check-unreachable-code?) + (tc-expr/check expr Univ) + (ret (Un))] + [else (ret (Un))])) (match (single-value tst) [(tc-result1: _ (and f1 (FilterSet: fs+ fs-)) _) - (match-let ([(tc-results: ts fs2 os2) (with-lexical-env (env+ (lexical-env) fs+) (tc thn))] - [(tc-results: us fs3 os3) (with-lexical-env (env+ (lexical-env) fs-) (tc els))]) - ;; if we have the same number of values in both cases - (cond [(= (length ts) (length us)) - (combine-results - (for/list ([t ts] [u us] [o2 os2] [o3 os3] [f2 fs2] [f3 fs3]) - (combine-filter f1 f2 f3 t u o2 o3)))] - [else - (tc-error/expr #:return (ret Err) - "Expected the same number of values from both branches of if expression, but got ~a and ~a" - (length ts) (length us))]))] + (let-values ([(flag+ flag-) (values (box #t) (box #t))]) + (match-let ([(tc-results: ts fs2 os2) (with-lexical-env (env+ (lexical-env) fs+ flag+) (tc thn (unbox flag+)))] + [(tc-results: us fs3 os3) (with-lexical-env (env+ (lexical-env) fs- flag-) (tc els (unbox flag-)))]) + ;; if we have the same number of values in both cases + (cond [(= (length ts) (length us)) + (combine-results + (for/list ([t ts] [u us] [o2 os2] [o3 os3] [f2 fs2] [f3 fs3]) + (combine-filter f1 f2 f3 t u o2 o3)))] + [else + (tc-error/expr #:return (ret Err) + "Expected the same number of values from both branches of if expression, but got ~a and ~a" + (length ts) (length us))])))] [(tc-results: t _ _) (tc-error/expr #:return (ret (or expected Err)) "Test expression expects one value, given ~a" t)])) From 6d1257e624f6165003af3ddb53d8a3fdf91a14ce Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 May 2009 16:27:44 +0000 Subject: [PATCH 138/156] Pass the right argument to unfold. Fix tc/rec-lambda/check for tc-results in appropriate places. svn: r14871 --- collects/typed-scheme/typecheck/signatures.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 10 ++++++---- collects/typed-scheme/typecheck/tc-lambda-unit.ss | 9 +++++---- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index e902aa2463..a1031cf6f9 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -32,7 +32,7 @@ (define-signature tc-lambda^ ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-results?)] [cnt tc/lambda/check (syntax? syntax? syntax? tc-results? . -> . tc-results?)] - [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) Type/c . -> . Type/c)])) + [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) tc-results? . -> . tc-results?)])) (define-signature tc-app^ ([cnt tc/app (syntax? . -> . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 21ec4c0684..aa98361614 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -100,7 +100,7 @@ [name-assoc (map list names (syntax->list named-args))]) (let loop ([t (tc-expr cl)]) (match t - [(tc-result1: (? Mu? t)) (loop (ret (unfold t)))] + [(tc-result1: (? Mu? t*)) (loop (ret (unfold t*)))] [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) (unless (= (length pos-tys) (length (syntax->list pos-args))) @@ -151,10 +151,12 @@ (generalize (tc-expr/t ac))))] [ts (cons ts1 ann-ts)]) ;; check that the actual arguments are ok here - (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) + (for/list ([a (syntax->list #'(actuals ...))] + [t ann-ts]) + (tc-expr/check a (ret t))) ;; then check that the function typechecks with the inferred types (tc/rec-lambda/check form args body lp ts expected) - (ret expected))] + expected)] ;; special case when argument needs inference [_ (let ([ts (for/list ([ac (syntax->list actuals)] @@ -163,7 +165,7 @@ (type-annotation f #:infer #t) (generalize (tc-expr/t ac))))]) (tc/rec-lambda/check form args body lp ts expected) - (ret expected))])) + expected)])) (define (tc/apply f args) (define (do-ret t) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 551a78ab7f..3fb1baae4e 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -197,7 +197,7 @@ (= 1 (length (syntax->list formals)))) (let loop ([expected expected]) (match expected - [(tc-result1: (Mu: _ _)) (loop (unfold expected))] + [(tc-result1: (and t (Mu: _ _))) (loop (ret (unfold t)))] [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) @@ -299,14 +299,15 @@ ;; name : the name of the loop ;; args : the types of the actual arguments to the loop ;; ret : the expected return type of the whole expression -(define (tc/rec-lambda/check form formals body name args ret) +(define (tc/rec-lambda/check form formals body name args return) (with-lexical-env/extend (syntax->list formals) args - (let* ([t (make-arr args ret)] + (let* ([r (tc-results->values return)] + [t (make-arr args r)] [ft (make-Function (list t))]) (with-lexical-env/extend (list name) (list ft) - (begin (tc-exprs/check (syntax->list body) ret) ft))))) + (begin (tc-exprs/check (syntax->list body) return) (ret ft)))))) ;(trace tc/mono-lambda) From 19c4aa6ba450fdbcaf927fd6391987cc4deca69e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 May 2009 18:35:59 +0000 Subject: [PATCH 139/156] Sort unions on re-construction to make contract happy. Use resolve-once more. Improve `overlap', in particular use keys. Resolve names and apps before doing structure comparison. svn: r14884 --- collects/typed-scheme/env/init-envs.ss | 2 +- collects/typed-scheme/infer/infer-unit.ss | 13 +-- collects/typed-scheme/infer/infer.ss | 1 + collects/typed-scheme/infer/restrict.ss | 19 ++-- collects/typed-scheme/rep/type-rep.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 1 + .../typed-scheme/types/remove-intersect.ss | 89 ++++++++++++------- collects/typed-scheme/types/subtype.ss | 19 ++-- 8 files changed, 86 insertions(+), 60 deletions(-) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index 4b87fadc95..73d1a9a1da 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -22,7 +22,7 @@ (define (gen-constructor sym) (string->symbol (string-append "make-" (substring (symbol->string sym) 7)))) (match v - [(Union: elems) `(make-Union (list ,@(map sub elems)))] + [(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) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index ee36c67cb5..8888f0b72f 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -2,7 +2,7 @@ (require (except-in "../utils/utils.ss")) (require (rep free-variance type-rep filter-rep rep-utils) - (types convenience union subtype remove-intersect) + (types convenience union subtype remove-intersect resolve) (except-in (utils tc-utils) make-env) (env type-name-env) (except-in (types utils) Dotted) @@ -347,9 +347,9 @@ (App: (Name: n*) args* _)) (unless (free-identifier=? n n*) (fail! S T)) - (let ([x (instantiate-poly (lookup-type-name n) args)] - [y (instantiate-poly (lookup-type-name n) args*)]) - (cg x y))] + (cg (resolve-once S) (resolve-once T))] + [((App: _ _ _) _) (cg (resolve-once S) T)] + [(_ (App: _ _ _)) (cg S (resolve-once T))] [((Values: ss) (Values: ts)) (unless (= (length ss) (length ts)) (fail! ss ts)) @@ -471,7 +471,7 @@ (define (infer X S T R must-vars [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let ([cs (cgen/list null X S T)]) - ;(printf "cs: ~a~n" cs) + (printf "cs: ~a~n" cs) (if (not expected) (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) @@ -480,6 +480,7 @@ (define (infer/vararg X S T T-var R must-vars [expected #f]) (define new-T (if T-var (extend S T T-var) T)) (and ((length S) . >= . (length T)) + (printf "calling infer~n") (infer X S new-T R must-vars expected))) ;; like infer, but dotted-var is the bound on the ... @@ -506,4 +507,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -;(trace cgen cgen/filters cgen/filter) +(trace subst-gen cgen) diff --git a/collects/typed-scheme/infer/infer.ss b/collects/typed-scheme/infer/infer.ss index c660783ed0..8222f69f43 100644 --- a/collects/typed-scheme/infer/infer.ss +++ b/collects/typed-scheme/infer/infer.ss @@ -3,6 +3,7 @@ (require (except-in "../utils/utils.ss" infer)) (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" "restrict.ss" "promote-demote.ss" + mzlib/trace (only-in scheme/unit provide-signature-elements define-values/invoke-unit/infer link) (utils unit-utils)) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/infer/restrict.ss index 140e276db5..587bbe7d26 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -2,9 +2,9 @@ (require "../utils/utils.ss") (require (rep type-rep) - (types utils union subtype remove-intersect) + (types utils union subtype remove-intersect resolve) "signatures.ss" - scheme/match) + scheme/match mzlib/trace) (import infer^) (export restrict^) @@ -12,26 +12,27 @@ ;; NEW IMPL ;; restrict t1 to be a subtype of t2 -(define (restrict t1 t2) +(define (restrict* t1 t2) ;; we don't use union map directly, since that might produce too many elements (define (union-map f l) (match l [(Union: es) (let ([l (map f es)]) - ;(printf "l is ~a~n" l) + (printf "l is ~a~n" l) (apply Un l))])) (cond [(subtype t1 t2) t1] ;; already a subtype [(match t2 [(Poly: vars t) (let ([subst (infer vars (list t1) (list t) t1 vars)]) - (and subst (restrict t1 (subst-all subst t1))))] + (and subst (restrict* t1 (subst-all subst t1))))] [_ #f])] - [(Union? t1) (union-map (lambda (e) (restrict e t2)) t1)] - [(Mu? t1) - (restrict (unfold t1) t2)] - [(Mu? t2) (restrict t1 (unfold t2))] + [(Union? t1) (union-map (lambda (e) (restrict* e t2)) t1)] + [(needs-resolving? t1) (restrict* (resolve-once t1) t2)] + [(needs-resolving? t2) (restrict* t1 (resolve-once t2))] [(subtype t2 t1) t2] ;; we don't actually want this - want something that's a part of t1 [(not (overlap t1 t2)) (Un)] ;; there's no overlap, so the restriction is empty [else t2] ;; t2 and t1 have a complex relationship, so we punt )) +(trace restrict*) +(define restrict restrict*) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index bcebb693da..1ad80fd394 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -224,7 +224,7 @@ [else #f])]) ;; elems : Listof[Type] -(dt Union ([elems (and/c (listof Type/c) +(dt Union ([elems (and/c (listof Type/c) (lambda (es) (let-values ([(sorted? k) (for/fold ([sorted? #t] diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index aa98361614..d7b175b347 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -538,6 +538,7 @@ (PolyDots: vars (Function: (list (and arrs (arr: doms rngs rests (and drests #f) '())) ...)))))) (list (tc-result1: argtys-t) ...)) + (printf "simple poly case: ~a~n" t) (handle-clauses (doms rngs rests arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) diff --git a/collects/typed-scheme/types/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss index 0d76e51ba6..f942070337 100644 --- a/collects/typed-scheme/types/remove-intersect.ss +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -1,7 +1,7 @@ #lang scheme/base (require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) +(require (rep type-rep rep-utils) (types union subtype resolve convenience utils) scheme/match mzlib/trace) @@ -9,41 +9,62 @@ (define (overlap t1 t2) - (match (list t1 t2) - [(list (Univ:) _) #t] - [(list _ (Univ:)) #t] - [(list (F: _) _) #t] - [(list _ (F: _)) #t] - [(list (Name: n) (Name: n*)) (free-identifier=? n n*)] - [(list (? Mu?) _) (overlap (unfold t1) t2)] - [(list _ (? Mu?)) (overlap t1 (unfold t2))] - [(list (Union: e) t) - (ormap (lambda (t*) (overlap t* t)) e)] - [(list t (Union: e)) - (ormap (lambda (t*) (overlap t t*)) e)] - [(or (list _ (? Poly?)) (list (? Poly?) _)) - #t] ;; these can have overlap, conservatively - [(list (Base: s1 _) (Base: s2 _)) (or (subtype t1 t2) (subtype t2 t1))] - [(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative - [(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative - [(list (Syntax: t) (Syntax: t*)) - (overlap t t*)] - [(or (list (Syntax: _) _) - (list _ (Syntax: _))) - #f] - [(list (Base: _ _) _) #f] - [(list _ (Base: _ _)) #f] - [(list (Value: (? pair? v)) (Pair: _ _)) #t] - [(list (Pair: _ _) (Value: (? pair? v))) #t] - [(list (Pair: a b) (Pair: a* b*)) - (and (overlap a a*) - (overlap b b*))] - [(or (list (Pair: _ _) _) - (list _ (Pair: _ _))) - #f] - [else #t])) + (let ([ks (Type-key t1)] [kt (Type-key t2)]) + (cond + [(and (symbol? ks) (symbol? kt) (not (eq? ks kt))) #f] + [(and (symbol? ks) (pair? kt) (not (memq ks kt))) #f] + [(and (symbol? kt) (pair? ks) (not (memq kt ks))) #f] + [(and (pair? ks) (pair? kt) + (for/and ([i (in-list ks)]) (not (memq i kt)))) + #f] + [else + (match (list t1 t2) + [(list (Univ:) _) #t] + [(list _ (Univ:)) #t] + [(list (F: _) _) #t] + [(list _ (F: _)) #t] + [(list (Name: n) (Name: n*)) (free-identifier=? n n*)] + [(list (? Mu?) _) (overlap (unfold t1) t2)] + [(list _ (? Mu?)) (overlap t1 (unfold t2))] + [(list (Union: e) t) + (ormap (lambda (t*) (overlap t* t)) e)] + [(list t (Union: e)) + (ormap (lambda (t*) (overlap t t*)) e)] + [(or (list _ (? Poly?)) (list (? Poly?) _)) + #t] ;; these can have overlap, conservatively + [(list (Base: s1 _) (Base: s2 _)) (or (subtype t1 t2) (subtype t2 t1))] + [(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative + [(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative + [(list (Syntax: t) (Syntax: t*)) + (overlap t t*)] + [(or (list (Syntax: _) _) + (list _ (Syntax: _))) + #f] + [(list (Base: _ _) _) #f] + [(list _ (Base: _ _)) #f] + [(list (Value: (? pair? v)) (Pair: _ _)) #t] + [(list (Pair: _ _) (Value: (? pair? v))) #t] + [(list (Pair: a b) (Pair: a* b*)) + (and (overlap a a*) + (overlap b b*))] + [(or (list (Pair: _ _) _) + (list _ (Pair: _ _))) + #f] + [(list (Struct: n _ flds _ _ _ _) + (Struct: n _ flds* _ _ _ _)) + (for/and ([f flds] [f* flds*]) (overlap f f*))] + ;; n and n* must be different, so there's no overlap + [(list (Struct: n #f flds _ _ _ _) + (Struct: n* #f flds* _ _ _ _)) + #f] + [(list (Struct: n p flds _ _ _ _) + (Struct: n* p* flds* _ _ _ _)) + (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))] + [else #t])]))) +(trace overlap) + ;(trace restrict) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 0a1e4768ca..5a7005078a 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -260,15 +260,6 @@ ;; for unions, we check the cross-product [(list (Union: es) t) (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0)] [(list s (Union: es)) (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)] - ;; subtyping on immutable structs is covariant - [(list (Struct: nm _ flds #f _ _ _) (Struct: nm _ flds* #f _ _ _)) - (subtypes* A0 flds flds*)] - [(list (Struct: nm _ flds proc _ _ _) (Struct: nm _ flds* proc* _ _ _)) - (subtypes* A0 (cons proc flds) (cons proc* flds*))] - ;; subtyping on structs follows the declared hierarchy - [(list (Struct: nm (? Type? parent) flds proc _ _ _) other) - ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) - (subtype* A0 parent other)] ;; applications and names are structs too [(list (App: (Name: n) args stx) other) (let ([t (lookup-type-name n)]) @@ -311,6 +302,16 @@ (if (Type? t) (subtype* A0 other t) (fail! t s)))] + ;; subtyping on immutable structs is covariant + [(list (Struct: nm _ flds #f _ _ _) (Struct: nm _ flds* #f _ _ _)) + (printf "subtyping on structs: ~a ~a~n" flds flds*) + (subtypes* A0 flds flds*)] + [(list (Struct: nm _ flds proc _ _ _) (Struct: nm _ flds* proc* _ _ _)) + (subtypes* A0 (cons proc flds) (cons proc* flds*))] + ;; subtyping on structs follows the declared hierarchy + [(list (Struct: nm (? Type? parent) flds proc _ _ _) other) + ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) + (subtype* A0 parent other)] ;; Promises are covariant [(list (Struct: 'Promise _ (list t) _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _)) (subtype* A0 t t*)] ;; subtyping on values is pointwise From c4762078e32003f60402872f27ce94f2561f7b15 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 May 2009 23:40:03 +0000 Subject: [PATCH 140/156] Remove lots of debugging code. Use `needs-resolving?' in subtype. Make resolve-{app,name} handle not-yet-bound names. svn: r14890 --- collects/typed-scheme/infer/infer-unit.ss | 4 +- collects/typed-scheme/infer/restrict.ss | 3 +- collects/typed-scheme/typecheck/tc-app.ss | 1 - .../typed-scheme/types/remove-intersect.ss | 2 +- collects/typed-scheme/types/resolve.ss | 19 ++++-- collects/typed-scheme/types/subtype.ss | 63 ++++--------------- 6 files changed, 28 insertions(+), 64 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index 8888f0b72f..bb9f7b0b01 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -471,7 +471,6 @@ (define (infer X S T R must-vars [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let ([cs (cgen/list null X S T)]) - (printf "cs: ~a~n" cs) (if (not expected) (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) @@ -480,7 +479,6 @@ (define (infer/vararg X S T T-var R must-vars [expected #f]) (define new-T (if T-var (extend S T T-var) T)) (and ((length S) . >= . (length T)) - (printf "calling infer~n") (infer X S new-T R must-vars expected))) ;; like infer, but dotted-var is the bound on the ... @@ -507,4 +505,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -(trace subst-gen cgen) +;(trace subst-gen cgen) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/infer/restrict.ss index 587bbe7d26..d4ef3cd463 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -18,7 +18,6 @@ (match l [(Union: es) (let ([l (map f es)]) - (printf "l is ~a~n" l) (apply Un l))])) (cond [(subtype t1 t2) t1] ;; already a subtype @@ -34,5 +33,5 @@ [(not (overlap t1 t2)) (Un)] ;; there's no overlap, so the restriction is empty [else t2] ;; t2 and t1 have a complex relationship, so we punt )) -(trace restrict*) (define restrict restrict*) +;(trace restrict*) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index d7b175b347..aa98361614 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -538,7 +538,6 @@ (PolyDots: vars (Function: (list (and arrs (arr: doms rngs rests (and drests #f) '())) ...)))))) (list (tc-result1: argtys-t) ...)) - (printf "simple poly case: ~a~n" t) (handle-clauses (doms rngs rests arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) diff --git a/collects/typed-scheme/types/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss index f942070337..02c77acb93 100644 --- a/collects/typed-scheme/types/remove-intersect.ss +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -63,7 +63,7 @@ [else #t])]))) -(trace overlap) +;(trace overlap) ;(trace restrict) diff --git a/collects/typed-scheme/types/resolve.ss b/collects/typed-scheme/types/resolve.ss index 520cc444f7..a558255bbd 100644 --- a/collects/typed-scheme/types/resolve.ss +++ b/collects/typed-scheme/types/resolve.ss @@ -6,24 +6,31 @@ (utils tc-utils) (types utils) scheme/match + scheme/contract mzlib/trace) -(provide resolve-name resolve-app needs-resolving? resolve-once resolve) +(provide resolve-name resolve-app needs-resolving? resolve) +(p/c [resolve-once (Type/c . -> . (or/c Type/c #f))]) (define (resolve-name t) (match t - [(Name: n) (lookup-type-name n)] + [(Name: n) (let ([t (lookup-type-name n)]) + (if (Type? t) t #f))] [_ (int-err "resolve-name: not a name ~a" t)])) (define (resolve-app rator rands stx) (parameterize ([current-orig-stx stx]) (match rator - [(Poly: _ _) + [(Poly-unsafe: n _) + (unless (= n (length rands)) + (tc-error "wrong number of arguments to polymorphic type: expected ~a and got ~a" + n (length rands))) (instantiate-poly rator rands)] - [(Name: _) (resolve-app (resolve-name rator) rands stx)] + [(Name: _) (let ([r (resolve-name rator)]) + (and r (resolve-app r rands stx)))] [(Mu: _ _) (resolve-app (unfold rator) rands)] [(App: r r* s) (resolve-app (resolve-app r r* s) rands)] - [_ (tc-error "resolve-app: not a proper operator ~a" rator)]))) + [_ (tc-error "cannot apply a non-polymorphic type: ~a" rator)]))) (define (needs-resolving? t) (or (Mu? t) (App? t) (Name? t))) @@ -36,3 +43,5 @@ (define (resolve t) (if (needs-resolving? t) (resolve-once t) t)) + +;(trace resolve-app) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index 5a7005078a..26a08fe78c 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -248,63 +248,22 @@ [(list s (Poly: vs b)) (=> unmatch) (if (null? (fv b)) (subtype* A0 s b) (unmatch))] - ;; names are compared for equality: - [(list (Name: n) (Name: n*)) - (=> unmatch) - (if (free-identifier=? n n*) - A0 - (unmatch))] - ;; just unfold the recursive types - [(list _ (? Mu?)) (subtype* A0 s (unfold t))] - [(list (? Mu?) _) (subtype* A0 (unfold s) t)] + ;; rec types, applications and names (that aren't the same + [(list (? needs-resolving? s) other) + (let ([s* (resolve-once s)]) + (if (Type? s*) ;; needed in case this was a name that hasn't been resolved yet + (subtype* A0 s* other) + (fail! s t)))] + [(list other (? needs-resolving? t)) + (let ([t* (resolve-once t)]) + (if (Type? t*) ;; needed in case this was a name that hasn't been resolved yet + (subtype* A0 other t*) + (fail! s t)))] ;; for unions, we check the cross-product [(list (Union: es) t) (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0)] [(list s (Union: es)) (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)] - ;; applications and names are structs too - [(list (App: (Name: n) args stx) other) - (let ([t (lookup-type-name n)]) - (unless (Type? t) - (fail! s t)) - #;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other - (instantiate-poly t args)) - (unless (Poly? t) - (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) - (match t [(Poly-unsafe: n _) - (unless (= n (length args)) - (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" - n (length args)))]) - (let ([v (subtype* A0 (instantiate-poly t args) other)]) - #;(printf "val: ~a~n" v) - v))] - [(list other (App: (Name: n) args stx)) - (let ([t (lookup-type-name n)]) - (unless (Type? t) - (fail! s t)) - #;(printf "subtype: 2 app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other - (instantiate-poly t args)) - (unless (Poly? t) - (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) - (match t [(Poly-unsafe: n _) - (unless (= n (length args)) - (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" - n (length args)))]) - ;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args)) - (let ([v (subtype* A0 other (instantiate-poly t args))]) - #;(printf "2 val: ~a~n" v) - v))] - [(list (Name: n) other) - (let ([t (lookup-type-name n)]) - (if (Type? t) - (subtype* A0 t other) - (fail! s t)))] - [(list other (Name: n)) - (let ([t (lookup-type-name n)]) - (if (Type? t) - (subtype* A0 other t) - (fail! t s)))] ;; subtyping on immutable structs is covariant [(list (Struct: nm _ flds #f _ _ _) (Struct: nm _ flds* #f _ _ _)) - (printf "subtyping on structs: ~a ~a~n" flds flds*) (subtypes* A0 flds flds*)] [(list (Struct: nm _ flds proc _ _ _) (Struct: nm _ flds* proc* _ _ _)) (subtypes* A0 (cons proc flds) (cons proc* flds*))] From 06e252b1a15cfe159f4f6c2047ccbaf01e895009 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 20 May 2009 23:54:14 +0000 Subject: [PATCH 141/156] Convert to syntax-parse. Use tc-results->values where appropriate. svn: r14891 --- collects/typed-scheme/typecheck/tc-let-unit.ss | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index d683efa9e9..2faed2c6b9 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -1,14 +1,14 @@ #lang scheme/unit (require (rename-in "../utils/utils.ss" [infer r:infer])) -(require "signatures.ss" +(require "signatures.ss" "tc-metafunctions.ss" (types utils convenience) (private type-annotation parse-type) (env lexical-env type-alias-env type-env) syntax/free-vars mzlib/trace scheme/match - syntax/kerncase + syntax/kerncase stxclass (for-template scheme/base "internal-forms.ss")) @@ -90,11 +90,10 @@ ;; this is so match can provide us with a syntax property to ;; say that this binding is only called in tail position (define ((tc-expr-t/maybe-expected expected) e) - (kernel-syntax-case e #f + (syntax-parse e #:literals (#%plain-lambda) [(#%plain-lambda () _) - (and expected (syntax-property e 'typechecker:called-in-tail-position)) - (begin - (tc-expr/check e (ret (-> expected))))] + #:when (and expected (syntax-property e 'typechecker:called-in-tail-position)) + (tc-expr/check e (ret (-> (tc-results->values expected))))] [_ (tc-expr e)])) (define (tc/let-values namess exprs body form [expected #f]) From c8828d0638d6d6ccc1e437ae79e5b82a9937b6ce Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 18:18:34 +0000 Subject: [PATCH 142/156] Fix keyword argument handling - sort of hackish. svn: r14924 --- collects/typed-scheme/typecheck/tc-app.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index aa98361614..244c3848fe 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -83,7 +83,7 @@ (loop kws-rest (cdr actuals) form-rest)] [else ;; otherwise, ignore this formal param, and continue (loop actual-kws actuals form-rest)])])) - (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function (list (make-arr* dom rng #:rest rest)))) (map tc-expr (syntax->list pos-args)) expected)] [_ (int-err "case-lambda w/ keywords not supported")])) (define (type->list t) @@ -590,7 +590,8 @@ ;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? (define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) (match* (ftype0 argtys) - [((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f '()) + ;; we check that all kw args are optional + [((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f (list (Keyword: _ _ #f) ...)) (list (tc-result1: t-a phi-a o-a) ...)) (when check? (cond [(and (not rest) (not (= (length dom) (length t-a)))) From 5b7249eea551979eac88b199b270f5800cdad42a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 19:04:22 +0000 Subject: [PATCH 143/156] Add test of andmap. svn: r14928 --- collects/tests/typed-scheme/succeed/dot-intro.ss | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/tests/typed-scheme/succeed/dot-intro.ss b/collects/tests/typed-scheme/succeed/dot-intro.ss index 50c87e353b..1d0dd5337b 100644 --- a/collects/tests/typed-scheme/succeed/dot-intro.ss +++ b/collects/tests/typed-scheme/succeed/dot-intro.ss @@ -8,6 +8,10 @@ (plambda: (a ...) ([x : Number] . [y : a ... a]) (ormap null? (map list y)))) +(define y* + (plambda: (a ...) ([x : Number] . [y : a ... a]) + (andmap null? (map list y)))) + (plambda: (a ...) ([x : Number] . [y : Number ... a]) y) From e772687a583966b882912904b9a2cfe365e1bb17 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 19:08:12 +0000 Subject: [PATCH 144/156] Add unit tests for andmap of ..., Bot return to MV context svn: r14929 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.ss | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 1afd30efe4..848b2f8778 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -719,6 +719,11 @@ [tc-e (apply values (list 1 2 3)) #:ret (ret (list -Integer -Integer -Integer))] [tc-e (ann (if #t 3 "foo") Integer) -Integer] + + [tc-e/t (plambda: (a ...) ([x : Number] . [y : a ... a]) + (andmap null? (map list y))) + (-polydots (a) ((list -Number) (a a) . ->... . -Boolean))] + [tc-e (ann (error 'foo) (values Number Number)) #:ret (ret (list -Number -Number))] #;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20))] From 7e6c1be6b0886bcd73e308930f313341eaa73add Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 19:09:19 +0000 Subject: [PATCH 145/156] Handle return of Bottom to context which expectes multiple values. Check values length before using for/and. Add back ormap/andmap special case for ... args. svn: r14930 --- collects/typed-scheme/typecheck/tc-app.ss | 14 ++++++++++++++ collects/typed-scheme/typecheck/tc-expr-unit.ss | 6 +++++- 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 244c3848fe..459ff0b67d 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -436,6 +436,20 @@ (check-do-make-object #'cl #'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 ...))] + ;; ormap/andmap of ... argument + [(#%plain-app or/andmap:id f arg) + #:when (or (free-identifier=? #'or/andmap #'ormap) + (free-identifier=? #'or/andmap #'andmap)) + #:when (with-handlers ([exn:fail? (lambda _ #f)]) + (tc/dots #'arg) + #t) + (let-values ([(ty bound) (tc/dots #'arg)]) + (parameterize ([current-tvars (extend-env (list bound) + (list (make-DottedBoth (make-F bound))) + (current-tvars))]) + (match-let* ([ft (tc-expr #'f)] + [(tc-result1: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) + (ret (Un (-val #f) t)))))] ;; special case for `delay' [(#%plain-app mp1 diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 7050b5e918..576f21cd0d 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -133,8 +133,12 @@ ;; (Type Type -> Type)) (define (check-below tr1 expected) (match* (tr1 expected) + [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _) + expected] [((tc-results: t1) (tc-results: t2)) - (unless (andmap subtype t1 t2) + (unless (= (length t1) (length t2)) + (tc-error/expr "0.5 Expected ~a values, but got ~a" (length t2) (length t1))) + (unless (for/and ([t t1] [s t2]) (subtype t s)) (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) expected] [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound)) From 7237ad6046a636b4ce0f5f1354fc0ff9237e416c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 19:26:06 +0000 Subject: [PATCH 146/156] Fix construction of predicate type for `declare-refinement'. svn: r14933 --- collects/typed-scheme/typecheck/tc-toplevel.ss | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 555b7bb836..24f16702d7 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -44,11 +44,11 @@ ;; FIXME - this sucks and should die [(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values))) (match (lookup-type/lexical #'pred) - [(and t (Function: (list (arr: (list dom) rng #f #f '())))) - (register-type #'pred - (make-pred-ty (list dom) - rng - (make-Refinement dom #'pred (syntax-local-certifier)))) + [(and t (Function: (list (arr: (list dom) (Values: (list (Result: rng _ _))) #f #f '())))) + (let ([new-t (make-pred-ty (list dom) + rng + (make-Refinement dom #'pred (syntax-local-certifier)))]) + (register-type #'pred new-t)) (list)] [t (tc-error "cannot declare refinement for non-predicate ~a" t)])] From 23a735ee2ff321b69746f2cdacb01fbc0c874b5e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 19:43:31 +0000 Subject: [PATCH 147/156] Add contract for make-pred-ty svn: r14934 --- collects/typed-scheme/types/abbrev.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 4178ea1a49..d95a254bbe 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -250,7 +250,9 @@ (make-LNotTypeFilter t p i)) -(define make-pred-ty +(d/c make-pred-ty + (case-> (c:-> Type/c Type/c) + (c:-> (listof Type/c) Type/c Type/c Type/c)) (case-lambda [(in out t) (->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))] From 2ee1d2b5962343cd86e520879e88b7e092cf3bb7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 20:07:36 +0000 Subject: [PATCH 148/156] Untyped top-level variables are not an internal error. Handle latent filter of LBot in values->tc-results when there are no formals. Use check-below properly in tc/mono-lambda/type svn: r14935 --- .../typed-scheme/typecheck/tc-lambda-unit.ss | 2 +- .../typecheck/tc-metafunctions.ss | 24 ++++++++++++++----- collects/typed-scheme/types/utils.ss | 2 +- 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 3fb1baae4e..aaceea3d68 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -209,7 +209,7 @@ (define (tc/mono-lambda/type formals bodies expected) (define t (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))) (if expected - (check-below t expected) + (and (check-below (ret t true-filter) expected) t) t)) ;; tc/plambda syntax syntax-list syntax-list type -> Poly diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 1a1d17c22a..bda76ab6c1 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -149,9 +149,15 @@ [(ValuesDots: (list (Result: ts lfs los) ...) dty dbound) (ret ts (for/list ([lf lfs]) - (merge-filter-sets - (for/list ([x formals] [i (in-naturals)]) - (apply-filter (split-lfilters lf i) Univ (make-Path null x))))) + (or + (and (null? formals) + (match lf + [(LFilterSet: lf+ lf-) + (combine (if (memq (make-LBot) lf+) (list (make-Bot)) (list)) + (if (memq (make-LBot) lf-) (list (make-Bot)) (list)))])) + (merge-filter-sets + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x)))))) (for/list ([lo los]) (or (for/or ([x formals] [i (in-naturals)]) @@ -163,9 +169,15 @@ [(Values: (list (Result: ts lfs los) ...)) (ret ts (for/list ([lf lfs]) - (merge-filter-sets - (for/list ([x formals] [i (in-naturals)]) - (apply-filter (split-lfilters lf i) Univ (make-Path null x))))) + (or + (and (null? formals) + (match lf + [(LFilterSet: lf+ lf-) + (combine (if (memq (make-LBot) lf+) (list (make-Bot)) (list)) + (if (memq (make-LBot) lf-) (list (make-Bot)) (list)))])) + (merge-filter-sets + (for/list ([x formals] [i (in-naturals)]) + (apply-filter (split-lfilters lf i) Univ (make-Path null x)))))) (for/list ([lo los]) (or (for/or ([x formals] [i (in-naturals)]) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 2a768e0fb0..6f4504c392 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -290,7 +290,7 @@ (define (lookup-fail e) (match (identifier-binding e) ['lexical (int-err "untyped lexical variable ~a" (syntax-e e))] - [#f (int-err "untyped top-level variable ~a" (syntax-e e))] + [#f (tc-error/expr "untyped top-level identifier ~a" (syntax-e e))] [(list _ _ nominal-source-mod nominal-source-id _ _ _) (let-values ([(x y) (module-path-index-split nominal-source-mod)]) (cond [(and (not x) (not y)) From e92a8dd2f546b2e429e6776b064de119c2593852 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 20:23:15 +0000 Subject: [PATCH 149/156] Avoid spurious quoting. Use display instead of printf. svn: r14936 --- collects/typed-scheme/typed-scheme.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 5646b76a53..3679a8f4b9 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -135,11 +135,11 @@ [(tc-results: t) (format "- : ~a\n" type)] [x (int-err "bad type result: ~a" x)])]) - (if #'ty-str + (if ty-str #`(let ([type '#,ty-str]) (begin0 #,body2 - (printf type))) + (display type))) body2))]))])) From 0feb99f6bc08fdff518cf9587438ab4e46493166 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 21:19:46 +0000 Subject: [PATCH 150/156] Use tc-result1: instead of tc-result: in object handling. Use tc-results->values instead of bogus version. svn: r14937 --- collects/typed-scheme/typecheck/check-subforms-unit.ss | 5 ++--- collects/typed-scheme/typecheck/tc-expr-unit.ss | 8 ++++---- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss index 3ab084dc2e..f31aa592f0 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -3,7 +3,7 @@ (require (except-in "../utils/utils.ss" extend)) (require syntax/kerncase scheme/match - "signatures.ss" + "signatures.ss" "tc-metafunctions.ss" (types utils convenience union subtype) (utils tc-utils) (rep type-rep)) @@ -61,8 +61,7 @@ [stx ;; this is a hander function (syntax-property form 'typechecker:exn-handler) - (tc-expr/check form (match expected - [(tc-result1: e) (ret (-> (Un) e))]))] + (tc-expr/check form (ret (-> (Un) (tc-results->values expected))))] [stx ;; this is the body of the with-handlers (syntax-property form 'typechecker:exn-body) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 576f21cd0d..d1bd665cd9 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -355,17 +355,17 @@ (define (tc/send rcvr method args [expected #f]) (match (tc-expr rcvr) - [(tc-result: (Instance: (and c (Class: _ _ methods)))) + [(tc-result1: (Instance: (and c (Class: _ _ methods)))) (match (tc-expr method) - [(tc-result: (Value: (? symbol? s))) + [(tc-result1: (Value: (? symbol? s))) (let* ([ftype (cond [(assq s methods) => cadr] [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)]) (if expected (begin (check-below ret-ty expected) (ret expected)) ret-ty))] - [(tc-result: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])] - [(tc-result: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)])) + [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])] + [(tc-result1: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)])) (define (single-value form [expected #f]) (define t (if expected (tc-expr/check form expected) (tc-expr form))) From 7d239a4dfaa5d44e2bdbb8ebc31b72bbd3f87b61 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 21:41:12 +0000 Subject: [PATCH 151/156] Instances can have any Type as their class. Fix some handling of tc-results as pertains to classes. Bottom is an ok Class. svn: r14938 --- collects/typed-scheme/rep/type-rep.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 5 +++-- collects/typed-scheme/typecheck/tc-expr-unit.ss | 2 +- collects/typed-scheme/typecheck/tc-let-unit.ss | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 1ad80fd394..1365b5cd18 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -298,7 +298,7 @@ (map list mname (map type-rec-id mty)))])]) ;; cls : Class -(dt Instance ([cls Class?]) [#:key 'instance]) +(dt Instance ([cls Type/c]) [#:key 'instance]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 459ff0b67d..341f2ae4d6 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -101,6 +101,7 @@ (let loop ([t (tc-expr cl)]) (match t [(tc-result1: (? Mu? t*)) (loop (ret (unfold t*)))] + [(tc-result1: (Union: '())) (ret (Un))] [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) (unless (= (length pos-tys) (length (syntax->list pos-args))) @@ -109,7 +110,7 @@ ;; use for, since they might be different lengths in error case (for ([pa (in-syntax pos-args)] [pt (in-list pos-tys)]) - (tc-expr/check pa pt)) + (tc-expr/check pa (ret pt))) (for ([n names] #:when (not (memq n tnames))) (tc-error/delayed @@ -124,7 +125,7 @@ [else #f])]) (if s ;; this argument was present - (tc-expr/check s tfty) + (tc-expr/check s (ret tfty)) ;; this argument wasn't provided, and was optional #f))]) tnflds) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index d1bd665cd9..e42ad5068d 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -362,7 +362,7 @@ [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)]) (if expected - (begin (check-below ret-ty expected) (ret expected)) + (begin (check-below ret-ty expected) expected) ret-ty))] [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])] [(tc-result1: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)])) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 2faed2c6b9..32d7e217a2 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -84,7 +84,7 @@ (loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))] [else ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names) - (do-check (lambda (stx e t) (tc-expr/check/t e t)) + (do-check (lambda (stx e t) (tc-expr/check e t)) names (map (lambda (l) (map get-type l)) names) form exprs body clauses expected)])))) ;; this is so match can provide us with a syntax property to From a0cac4bbe5a436e5cdfa6e1b6369ee5c6ca08db6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 21:41:55 +0000 Subject: [PATCH 152/156] turn typechecking back on. svn: r14939 --- collects/drscheme/private/auto-language.ss | 6 +++--- collects/drscheme/private/insert-large-letters.ss | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss index 3417770099..f0bf4a4f4a 100644 --- a/collects/drscheme/private/auto-language.ss +++ b/collects/drscheme/private/auto-language.ss @@ -1,7 +1,7 @@ -#lang typed-scheme/no-check +#lang typed-scheme -(require framework/framework ;typed/framework/framework - mred ;typed/mred/mred +(require typed/framework/framework + typed/mred/mred scheme/class) (provide pick-new-language looks-like-module?) diff --git a/collects/drscheme/private/insert-large-letters.ss b/collects/drscheme/private/insert-large-letters.ss index 37493b4973..ea55ecfbfb 100644 --- a/collects/drscheme/private/insert-large-letters.ss +++ b/collects/drscheme/private/insert-large-letters.ss @@ -1,7 +1,7 @@ -#lang typed-scheme/no-check +#lang typed-scheme -(require #;typed/ mred/mred - #;typed/ framework/framework +(require typed/mred/mred + typed/framework/framework scheme/class string-constants/string-constant) From 2a55bec3352dff0b9d29ba72d5df61bb0a16b94f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 22:05:56 +0000 Subject: [PATCH 153/156] remove obselete code svn: r14941 --- .../typed-scheme/typecheck/tc-app-unit.ss | 834 ------------------ collects/typed-scheme/typecheck/tc-if-unit.ss | 192 ---- .../typed-scheme/typecheck/tc-new-app-unit.ss | 18 - 3 files changed, 1044 deletions(-) delete mode 100644 collects/typed-scheme/typecheck/tc-app-unit.ss delete mode 100644 collects/typed-scheme/typecheck/tc-if-unit.ss delete mode 100644 collects/typed-scheme/typecheck/tc-new-app-unit.ss diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss deleted file mode 100644 index e0a64c4c64..0000000000 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ /dev/null @@ -1,834 +0,0 @@ -#lang scheme/unit - -(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer])) -(require "signatures.ss" - stxclass - (for-syntax stxclass) - (rep type-rep effect-rep) - (utils tc-utils) - (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type - type-annotation) - (r:infer infer) - (env type-environments) - (only-in srfi/1 alist-delete) - (only-in scheme/private/class-internal make-object do-make-object) - mzlib/trace mzlib/pretty syntax/kerncase scheme/match - (prefix-in c: scheme/contract) - (for-syntax scheme/base) - (for-template - (only-in '#%kernel [apply k:apply]) - "internal-forms.ss" scheme/base - (only-in scheme/private/class-internal make-object do-make-object))) -(require (r:infer constraint-structs)) - -(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) -(export tc-app^) - -;; comparators that inform the type system -(define (comparator? i) - (or (free-identifier=? i #'eq?) - (free-identifier=? i #'equal?) - (free-identifier=? i #'eqv?) - (free-identifier=? i #'=) - (free-identifier=? i #'string=?))) - -;; typecheck eq? applications -;; identifier identifier expression expression expression -;; identifier expr expr expr expr -> tc-result -(define (tc/eq comparator v1 v2) - (define (e? i) (free-identifier=? i comparator)) - (define (do id val) - (define-syntax alt (syntax-rules () [(_ nm pred ...) - (and (e? #'nm) (or (pred val) ...))])) - (if (or (alt symbol=? symbol?) - (alt string=? string?) - (alt = number?) - (alt eq? boolean? keyword? symbol?) - (alt eqv? boolean? keyword? symbol? number?) - (alt equal? (lambda (x) #t))) - (values (list (make-Restrict-Effect (-val val) id)) - (list (make-Remove-Effect (-val val) id))) - (values (list) (list)))) - (match (list (tc-expr v1) (tc-expr v2)) - [(list (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2))) (tc-result: (Value: val))) - (do id1 val)] - [(list (tc-result: (Value: val)) (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2)))) - (do id1 val)] - [_ (values (list) (list))])) - - -;; typecheck an application: -;; arg-types: the types of the actual parameters -;; arg-effs: the effects of the arguments -;; dom-types: the types of the function's fixed arguments -;; rest-type: the type of the functions's rest parameter, or #f -;; latent-eff: the latent effect of the function -;; arg-stxs: the syntax for each actual parameter, for error reporting -;; [Type] [Type] Maybe[Type] [Syntax] -> (values Listof[Effect] Listof[Effect]) -(define (tc-args arg-types arg-thn-effs arg-els-effs dom-types rest-type latent-thn-eff latent-els-eff arg-stxs) - (define (var-true-effect-v e) (match e - [(Var-True-Effect: v) v])) - (define (var-false-effect-v e) (match e - [(Var-False-Effect: v) v])) - ;; special case for predicates: - (if (and (not (null? latent-thn-eff)) - (not (null? latent-els-eff)) - (not rest-type) - ;(printf "got to =~n") - (= (length arg-types) (length dom-types) 1) - ;(printf "got to var preds~n") - (= (length (car arg-thn-effs)) (length (car arg-els-effs)) 1) - (Var-True-Effect? (caar arg-thn-effs)) ;; thn-effs is a list for each arg - (Var-False-Effect? (caar arg-els-effs)) ;; same with els-effs - (free-identifier=? (var-true-effect-v (caar arg-thn-effs)) - (var-false-effect-v (caar arg-els-effs))) - (subtype (car arg-types) (car dom-types))) - ;; then this was a predicate application, so we construct the appropriate type effect - (values (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-thn-eff) - (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-els-eff)) - ;; otherwise, we just ignore the effects. - (let loop ([args arg-types] [doms dom-types] [stxs arg-stxs] [arg-count 1]) - (cond - [(and (null? args) (null? doms)) (values null null)] ;; here, we just return the empty effect - [(null? args) - (tc-error/delayed - "Insufficient arguments to function application, expected ~a, got ~a" - (length dom-types) (length arg-types)) - (values null null)] - [(and (null? doms) rest-type) - (if (subtype (car args) rest-type) - (loop (cdr args) doms (cdr stxs) (add1 arg-count)) - (begin - (tc-error/delayed #:stx (car stxs) - "Rest argument had wrong type, expected: ~a and got: ~a" - rest-type (car args)) - (values null null)))] - [(null? doms) - (tc-error/delayed "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types)) - (values null null)] - [(subtype (car args) (car doms)) - (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))] - [else - (tc-error/delayed - #:stx (car stxs) - "Wrong function argument type, expected ~a, got ~a for argument ~a" - (car doms) (car args) arg-count) - (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))])))) - - -;(trace tc-args) - -(define (stringify-domain dom rst drst [rng #f]) - (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] - [rng-string (if rng (format " -> ~a" rng) "")]) - (cond [drst - (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] - [rst - (format "~a~a *~a" doms-string rst rng-string)] - [else (string-append (stringify dom) rng-string)]))) - -(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) - (define arguments-str - (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f))) - (cond - [(null? doms) - (int-err "How could doms be null: ~a ~a" ty)] - [(= 1 (length doms)) - (format "Domain: ~a~nArguments: ~a~n~a" - (stringify-domain (car doms) (car rests) (car drests)) - arguments-str - (if expected - (format "Result type: ~a~nExpected result: ~a~n" - (car rngs) expected) - ""))] - [else - (format "~a: ~a~nArguments: ~a~n~a" - (if expected "Types" "Domains") - (stringify (if expected - (map stringify-domain doms rests drests rngs) - (map stringify-domain doms rests drests)) - "~n\t") - arguments-str - (if expected - (format "Expected result: ~a~n" expected) - ""))])) - -(define (do-apply-log subst fun arg) - (match* (fun arg) - [('star 'list) (printf/log "Polymorphic apply called with uniform rest arg, list argument\n")] - [('star 'dots) (printf/log "Polymorphic apply called with uniform rest arg, dotted argument\n")] - [('dots 'dots) (printf/log "Polymorphic apply called with non-uniform rest arg, dotted argument\n")]) - (log-result subst)) - -(define (tc/apply f args) - (define f-ty (tc-expr f)) - ;; produces the first n-1 elements of the list, and the last element - (define (split l) - (let loop ([l l] [acc '()]) - (if (null? (cdr l)) - (values (reverse acc) (car l)) - (loop (cdr l) (cons (car l) acc))))) - (define-values (fixed-args tail) (split (syntax->list args))) - - (match f-ty - [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) - (when (null? doms) - (tc-error/expr #:return (ret (Un)) - "empty case-lambda given as argument to apply")) - (let ([arg-tys (map tc-expr/t fixed-args)]) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))] - [(and (car rests*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values #f #f))]) - (tc/dots tail))]) - (and tail-ty - (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty)) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) - (printf/log "Non-poly apply, ... arg\n") - (ret (car rngs*))] - [(and (car rests*) - (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)]) - (tc-expr/t tail))]) - (and tail-ty - (subtype (apply -lst* arg-tys #:tail tail-ty) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) - - (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) - "Simple arithmetic non-poly apply\n" - "Simple non-poly apply\n")) - (ret (car rngs*))] - [(and (car drests*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values #f #f))]) - (tc/dots tail))]) - (and tail-ty - (eq? (cdr (car drests*)) tail-bound) - (subtypes arg-tys (car doms*)) - (subtype tail-ty (car (car drests*)))))) - (printf/log "Non-poly apply, ... arg\n") - (ret (car rngs*))] - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] - [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - #;(for-each (lambda (x) (unless (not (Poly? x)) - (tc-error "Polymorphic argument of type ~a to polymorphic function in apply not allowed" x))) - (cons tail-ty arg-tys)) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] - ;; the actual work, when we have a * function and a list final argument - [(and (car rests*) - (not tail-bound) - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons tail-ty arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] - ;; actual work, when we have a * function and ... final arg - [(and (car rests*) - tail-bound - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons (make-Listof tail-ty) arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg - [(and (car drests*) - tail-bound - (eq? tail-bound (cdr (car drests*))) - (= (length (car doms*)) - (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) (ret (subst-all substitution (car rngs*))))] - ;; if nothing matches, around the loop again - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: '()))) - (tc-error/expr #:return (ret (Un)) - "Function has no cases")] - [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] - [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] - ;; the actual work, when we have a * function and a list final argument - [(and (car rests*) - (not tail-bound) - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons tail-ty arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) - (do-apply-log substitution 'star 'list) - (ret (subst-all substitution (car rngs*))))] - ;; actual work, when we have a * function and ... final arg - [(and (car rests*) - tail-bound - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars - (cons (make-Listof tail-ty) arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*) - (fv (car rngs*)))) - => (lambda (substitution) - (do-apply-log substitution 'star 'dots) - (ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg, same bound on ... - [(and (car drests*) - tail-bound - (eq? tail-bound (cdr (car drests*))) - (= (length (car doms*)) - (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) - (do-apply-log substitution 'dots 'dots) - (ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg, different bound on ... - [(and (car drests*) - tail-bound - (not (eq? tail-bound (cdr (car drests*)))) - (= (length (car doms*)) - (length arg-tys)) - (parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*))) - (list (make-DottedBoth (make-F tail-bound)) - (make-DottedBoth (make-F (cdr (car drests*))))) - (current-tvars))]) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))) - => (lambda (substitution) - (define drest-bound (cdr (car drests*))) - (do-apply-log substitution 'dots 'dots) - (ret (substitute-dotted (cadr (assq drest-bound substitution)) - tail-bound - drest-bound - (subst-all (alist-delete drest-bound substitution eq?) - (car rngs*)))))] - ;; ... function, (List A B C etc) arg - [(and (car drests*) - (not tail-bound) - (eq? (cdr (car drests*)) dotted-var) - (= (length (car doms*)) - (length arg-tys)) - (untuple tail-ty) - (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) - (car (car drests*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) - (define drest-bound (cdr (car drests*))) - (do-apply-log substitution 'dots 'dots) - (ret (subst-all substitution (car rngs*))))] - ;; if nothing matches, around the loop again - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (PolyDots: vars (Function: '()))) - (tc-error/expr #:return (ret (Un)) - "Function has no cases")] - [(tc-result: f-ty) (tc-error/expr #:return (ret (Un)) - "Type of argument to apply is not a function type: ~n~a" f-ty)])) - - - -(define (log-result subst) - (define (dmap-length d) - (match d - [(struct dcon (fixed rest)) (length fixed)] - [(struct dcon-exact (fixed rest)) (length fixed)])) - (define (dmap-rest? d) - (match d - [(struct dcon (fixed rest)) rest] - [(struct dcon-exact (fixed rest)) rest])) - (if (list? subst) - (for ([s subst]) - (match s - [(list v (list imgs ...) starred) - (printf/log "Instantiated ... variable ~a with ~a types\n" v (length imgs))] - [_ (void)])) - (for* ([(cmap dmap) (in-pairs (cset-maps subst))] - [(k v) (dmap-map dmap)]) - (printf/log "Instantiated ... variable ~a with ~a types~a\n" k (dmap-length v) - (if (dmap-rest? v) - " and a starred type" - ""))))) - -(define-syntax (handle-clauses stx) - (syntax-parse stx - [(_ (lsts ... rngs) f-stx pred infer t argtypes expected) - (with-syntax ([(vars ... rng) (generate-temporaries #'(lsts ... rngs))]) - (syntax/loc stx - (or (for/or ([vars lsts] ... [rng rngs] - #:when (pred vars ... rng)) - (let ([substitution (infer vars ... rng)]) - (and substitution - (log-result substitution) - (ret (or expected - (subst-all substitution rng)))))) - (poly-fail t argtypes #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) - -(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) - (match t - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) - (let ([fcn-string (if name - (format "function ~a" (syntax->datum name)) - "function")]) - (if (and (andmap null? msg-doms) - (null? argtypes)) - (tc-error/expr #:return (ret (Un)) - (string-append - "Could not infer types for applying polymorphic " - fcn-string - "\n")) - (tc-error/expr #:return (ret (Un)) - (string-append - "Polymorphic " fcn-string " could not be applied to arguments:~n" - (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) - (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) - (string-append "Type Variables: " (stringify msg-vars) "\n") - "")))))])) - - -(define (tc/funapp f-stx args-stx ftype0 argtys expected) - (match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys]) - (let outer-loop ([ftype ftype0] - [argtypes argtypes] - [arg-thn-effs arg-thn-effs] - [arg-els-effs arg-els-effs] - [args args-stx]) - (match ftype - ;; procedural structs - [(tc-result: (and sty (Struct: _ _ _ (? Type? proc-ty) _ _ _)) thn-eff els-eff) - (outer-loop (ret proc-ty thn-eff els-eff) - (cons (tc-result-t ftype0) argtypes) - (cons (list) arg-thn-effs) - (cons (list) arg-els-effs) - #`(#,(syntax/loc f-stx dummy) #,@args))] - ;; mu types, etc - [(tc-result: (? needs-resolving? t) thn-eff els-eff) - (outer-loop (ret (resolve-once t) thn-eff els-eff) argtypes arg-thn-effs arg-els-effs args)] - ;; parameters - [(tc-result: (Param: in out)) - (match argtypes - [(list) (ret out)] - [(list t) - (if (subtype t in) - (ret -Void) - (tc-error/expr #:return (ret (Un)) - "Wrong argument to parameter - expected ~a and got ~a" in t))] - [_ (tc-error/expr #:return (ret (Un)) - "Wrong number of arguments to parameter - expected 0 or 1, got ~a" - (length argtypes))])] - ;; single clause functions - ;; FIXME - error on non-optional keywords - [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) - thn-eff els-eff) - (let-values ([(thn-eff els-eff) - (tc-args argtypes arg-thn-effs arg-els-effs dom rest - latent-thn-effs latent-els-effs - (syntax->list args))]) - (ret rng thn-eff els-eff))] - ;; non-polymorphic case-lambda functions - [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) - thn-eff els-eff) - (let loop ([doms* doms] [rngs rngs] [rests* rests]) - (cond [(null? doms*) - (tc-error/expr - #:return (ret (Un)) - (string-append "No function domains matched in function application:\n" - (domain-mismatches t doms rests drests rngs argtypes #f #f)))] - [(subtypes/varargs argtypes (car doms*) (car rests*)) - (when (car rests*) - (printf/log "Simple varargs function application (~a)\n" (syntax->datum f-stx))) - (ret (car rngs))] - [else (loop (cdr doms*) (cdr rngs) (cdr rests*))]))] - ;; simple polymorphic functions, no rest arguments - [(tc-result: (and t - (or (Poly: vars - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) - (PolyDots: (list vars ...) - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) - (handle-clauses (doms rngs) f-stx - (lambda (dom _) (= (length dom) (length argtypes))) - (lambda (dom rng) (infer vars argtypes dom rng (fv rng) expected)) - t argtypes expected)] - ;; polymorphic varargs - [(tc-result: (and t - (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) - ;; we want to infer the dotted-var here as well, and we don't use these separately - ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) - (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) - (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) - (handle-clauses (doms rests rngs) f-stx - (lambda (dom rest rng) (<= (length dom) (length argtypes))) - (lambda (dom rest rng) (infer/vararg vars argtypes dom rest rng (fv rng) expected)) - t argtypes expected)] - ;; polymorphic ... type - [(tc-result: (and t (PolyDots: - (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) - (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) - (handle-clauses (doms dtys dbounds rngs) f-stx - (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) - (eq? dotted-var dbound))) - (lambda (dom dty dbound rng) - (infer/dots fixed-vars dotted-var argtypes dom dty rng (fv rng) #:expected expected)) - t argtypes expected)] - ;; Union of function types works if we can apply all of them - [(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2) - (match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop - (ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)]) - (ret (apply Un ts)))] - ;; error type is a perfectly good fcn type - [(tc-result: (Error:)) (ret (make-Error))] - [(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) - -;(trace tc/funapp) - - - -(define (tc/app form) (tc/app/internal form #f)) - -(define (tc/app/check form expected) - (define t (tc/app/internal form expected)) - (check-below t expected) - (ret expected)) - -(define-syntax-class lv-clause - #:transparent - (pattern [(v:id ...) e:expr])) - -(define-syntax-class lv-clauses - #:transparent - (pattern (cl:lv-clause ...) - #:with (e ...) #'(cl.e ...) - #:with (vs ...) #'((cl.v ...) ...))) - -(define-syntax-class core-expr - #:literals (reverse letrec-syntaxes+values let-values #%plain-app - if letrec-values begin #%plain-lambda set! case-lambda - begin0 with-continuation-mark) - #:transparent - (pattern (let-values cls:lv-clauses body) - #:with (expr ...) #'(cls.e ... body)) - (pattern (letrec-values cls:lv-clauses body) - #:with (expr ...) #'(cls.e ... body)) - (pattern (letrec-syntaxes+values _ cls:lv-clauses body) - #:with (expr ...) #'(cls.e ... body)) - (pattern (#%plain-app expr ...)) - (pattern (if expr ...)) - (pattern (with-continuation-mark expr ...)) - (pattern (begin expr ...)) - (pattern (begin0 expr ...)) - (pattern (#%plain-lambda _ e) - #:with (expr ...) #'(e)) - (pattern (case-lambda [_ expr] ...)) - (pattern (set! _ e) - #:with (expr ...) #'(e)) - (pattern _ - #:with (expr ...) #'())) - -;; expr id -> type or #f -;; if there is a binding in stx of the form: -;; (let ([x (reverse name)]) e) -;; where x has a type annotation, return that annotation, otherwise #f -(define (find-annotation stx name) - (define (find s) (find-annotation s name)) - (define (match? b) - (syntax-parse b - #:literals (#%plain-app reverse) - [c:lv-clause - #:with (#%plain-app reverse n:id) #'c.e - #:with (v) #'(c.v ...) - #:when (free-identifier=? name #'n) - (type-annotation #'v)] - [_ #f])) - (syntax-parse stx - #:literals (let-values) - [(let-values cls:lv-clauses body) - (or (ormap match? (syntax->list #'cls)) - (find #'body))] - [e:core-expr - (ormap find (syntax->list #'(e.expr ...)))])) - - -(define (check-do-make-object cl pos-args names named-args) - (let* ([names (map syntax-e (syntax->list names))] - [name-assoc (map list names (syntax->list named-args))]) - (let loop ([t (tc-expr cl)]) - (match t - [(tc-result: (? Mu? t)) (loop (ret (unfold t)))] - [(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) - (unless (= (length pos-tys) - (length (syntax->list pos-args))) - (tc-error/delayed "expected ~a positional arguments, but got ~a" - (length pos-tys) (length (syntax->list pos-args)))) - ;; use for, since they might be different lengths in error case - (for ([pa (in-syntax pos-args)] - [pt (in-list pos-tys)]) - (tc-expr/check pa pt)) - (for ([n names] - #:when (not (memq n tnames))) - (tc-error/delayed - "unknown named argument ~a for class~nlegal named arguments are ~a" - n (stringify tnames))) - (for-each (match-lambda - [(list tname tfty opt?) - (let ([s (cond [(assq tname name-assoc) => cadr] - [(not opt?) - (tc-error/delayed "value not provided for named init arg ~a" tname) - #f] - [else #f])]) - (if s - ;; this argument was present - (tc-expr/check s tfty) - ;; this argument wasn't provided, and was optional - #f))]) - tnflds) - (ret (make-Instance c))] - [(tc-result: t) - (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) - -(define (tc-keywords form arities kws kw-args pos-args expected) - (match arities - [(list (arr: dom rng rest #f ktys _ _)) - ;; assumes that everything is in sorted order - (let loop ([actual-kws kws] - [actuals (map tc-expr/t (syntax->list kw-args))] - [formals ktys]) - (match* (actual-kws formals) - [('() '()) - (void)] - [(_ '()) - (tc-error/expr #:return (ret (Un)) - "Unexpected keyword argument ~a" (car actual-kws))] - [('() (cons fst rst)) - (match fst - [(Keyword: k _ #t) - (tc-error/expr #:return (ret (Un)) - "Missing keyword argument ~a" k)] - [_ (loop actual-kws actuals rst)])] - [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) - (cond [(eq? k k*) ;; we have a match - (unless (subtype (car actuals) t) - (tc-error/delayed - "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" - t (car actuals) k)) - (loop kws-rest (cdr actuals) form-rest)] - [req? ;; this keyword argument was required - (tc-error/delayed "Missing keyword argument ~a" k*) - (loop kws-rest (cdr actuals) form-rest)] - [else ;; otherwise, ignore this formal param, and continue - (loop actual-kws actuals form-rest)])])) - (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] - [_ (int-err "case-lambda w/ keywords not supported")])) - - -(define (type->list t) - (match t - [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] - [(Value: '()) null] - [_ (int-err "bad value in type->list: ~a" t)])) - -;; id: identifier -;; sym: a symbol -;; mod: a quoted require spec like 'scheme/base -;; is id the name sym defined in mod? -(define (id-from? id sym mod) - (and (eq? (syntax-e id) sym) - (eq? (module-path-index-resolve (syntax-source-module id)) - ((current-module-name-resolver) mod #f #f #f)))) - -(define (tc/app/internal form expected) - (kernel-syntax-case* form #f - (values apply k:apply not list list* call-with-values do-make-object make-object cons - andmap ormap) ;; the special-cased functions - ;; special case for delay - [(#%plain-app - mp1 - (#%plain-lambda () - (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) - (and (id-from? #'mp1 'make-promise 'scheme/promise) - (id-from? #'mp2 'make-promise 'scheme/promise)) - (ret (-Promise (tc-expr/t #'e)))] - ;; special cases for classes - [(#%plain-app make-object cl . args) - (check-do-make-object #'cl #'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 ...))] - [(#%plain-app do-make-object . args) - (int-err "bad do-make-object : ~a" (syntax->datum #'args))] - ;; call-with-values - [(#%plain-app call-with-values prod con) - (match-let* ([(tc-result: prod-t) (tc-expr #'prod)]) - (define (values-ty->list t) - (match t - [(Values: ts) ts] - [_ (list t)])) - (match prod-t - [(Function: (list (arr: (list) vals _ #f '() _ _))) - (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] - [_ (tc-error/expr #:return (ret (Un)) - "First argument to call with values must be a function that can accept no arguments, got: ~a" - prod-t)]))] - ;; special cases for `values' - ;; special case the single-argument version to preserve the effects - [(#%plain-app values arg) (tc-expr #'arg)] - [(#%plain-app values . args) - (let ([tys (map tc-expr/t (syntax->list #'args))]) - (ret (-values tys)))] - ;; special case for `list' - [(#%plain-app list . args) - (let ([tys (map tc-expr/t (syntax->list #'args))]) - (ret (apply -lst* tys)))] - ;; special case for `list*' - [(#%plain-app list* . args) - (match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))] - [tys (reverse tys-r)]) - (ret (foldr make-Pair last tys)))] - ;; in eq? cases, call tc/eq - [(#%plain-app eq? v1 v2) - (and (identifier? #'eq?) (comparator? #'eq?)) - (begin - ;; make sure the whole expression is type correct - (tc/funapp #'eq? #'(v1 v2) (tc-expr #'eq?) (map tc-expr (syntax->list #'(v1 v2))) expected) - ;; check thn and els with the eq? info - (let-values ([(thn-eff els-eff) (tc/eq #'eq? #'v1 #'v2)]) - (ret B thn-eff els-eff)))] - ;; special case for `not' - [(#%plain-app not arg) - (match (tc-expr #'arg) - ;; if arg was a predicate application, we swap the effects - [(tc-result: t thn-eff els-eff) - (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] - [(#%plain-app k:apply . args) - (tc/app/internal #'(#%plain-app apply . args) expected)] - ;; special-er case for (apply values (list x y z)) - [(#%plain-app apply values e) - (cond [(with-handlers ([exn:fail? (lambda _ #f)]) - (untuple (tc-expr/t #'e))) - => (lambda (t) (ret (-values t)))] - [else (tc/apply #'values #'(e))])] - ;; special case for `apply' - [(#%plain-app apply f . args) (tc/apply #'f #'args)] - ;; special case for keywords - [(#%plain-app - (#%plain-app kpe kws num fn) - kw-list - (#%plain-app list . kw-arg-list) - . pos-args) - (eq? (syntax-e #'kpe) 'keyword-procedure-extract) - (match (tc-expr #'fn) - [(tc-result: (Function: arities)) - (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] - [(tc-result: t) (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" t)])] - ;; even more special case for match - [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) - (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) - (let-loop-check form #'lp #'actuals #'args #'body expected)] - ;; or/andmap of ... argument - [(#%plain-app or/andmap f arg) - (and - (identifier? #'or/andmap) - (or (free-identifier=? #'or/andmap #'ormap) - (free-identifier=? #'or/andmap #'andmap)) - (with-handlers ([exn:fail? (lambda _ #f)]) - (tc/dots #'arg) - #t)) - (let-values ([(ty bound) (tc/dots #'arg)]) - (parameterize ([current-tvars (extend-env (list bound) - (list (make-DottedBoth (make-F bound))) - (current-tvars))]) - (match-let* ([ft (tc-expr #'f)] - [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) - (ret (Un (-val #f) t)))))] - ;; infer for ((lambda - [(#%plain-app (#%plain-lambda (x ...) . body) args ...) - (= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) - (tc/let-values/check #'((x) ...) #'(args ...) #'body - #'(let-values ([(x) args] ...) . body) - expected)] - ;; default case - [(#%plain-app f args ...) - (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) - -(define (let-loop-check form lp actuals args body expected) - (kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?) - [((val acc ...) - ((if (#%plain-app null? val*) thn els)) - (actual actuals ...)) - (and (free-identifier=? #'val #'val*) - (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a)) - (syntax->list #'(acc ...)))) - (let* ([ts1 (generalize (tc-expr/t #'actual))] - [ann-ts (for/list ([a (in-syntax #'(acc ...))] - [ac (in-syntax #'(actuals ...))]) - (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) - (generalize (tc-expr/t ac))))] - [ts (cons ts1 ann-ts)]) - ;; check that the actual arguments are ok here - (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) - ;; then check that the function typechecks with the inferred types - (tc/rec-lambda/check form args body lp ts expected) - (ret expected))] - ;; special case when argument needs inference - [_ - (let ([ts (for/list ([ac (syntax->list actuals)] - [f (syntax->list args)]) - (or - (type-annotation f #:infer #t) - (generalize (tc-expr/t ac))))]) - (tc/rec-lambda/check form args body lp ts expected) - (ret expected))])) - -(define (matches? stx) - (let loop ([stx stx] [ress null] [acc*s null]) - (syntax-case stx (#%plain-app reverse) - [([(res) (#%plain-app reverse acc*)] . more) - (loop #'more (cons #'res ress) (cons #'acc* acc*s))] - [rest - (syntax->list #'rest) - (begin - ;(printf "ress: ~a~n" (map syntax-e ress)) - (list (reverse ress) (reverse acc*s) #'rest))] - [_ #f]))) - -;(trace tc/app/internal) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss deleted file mode 100644 index 3d077cdcde..0000000000 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ /dev/null @@ -1,192 +0,0 @@ -#lang scheme/unit - -(require (rename-in "../utils/utils.ss" [infer r:infer])) -(require "signatures.ss" - (rep type-rep filter-rep object-rep) - (rename-in (types convenience subtype union utils comparison remove-intersect) - [remove *remove]) - (env lexical-env) - (r:infer infer) - (utils tc-utils mutated-vars) - syntax/kerncase - mzlib/trace - mzlib/plt-match) - -;; if typechecking -(import tc-expr^) -(export tc-if^) - - - -;; combinators for typechecking in the context of effects -;; t/f tells us whether this is the true or the false branch of an if -;; neccessary for handling true/false effects -;; Boolean Expr listof[Effect] option[type] -> TC-Result -(define (tc-expr/eff t/f expr effs expected) - ;; this flag represents whether the refinement proves that this expression cannot be executed - (let ([flag (box #f)]) - ;; this does the operation on the old type - ;; type-op : (Type Type -> Type) Type -> _ Type -> Type - (define ((type-op f t) _ old) - (let ([new-t (f old t)]) - ;; if this operation produces an uninhabitable type, then this expression can't be executed - (when (type-equal? new-t (Un)) - (set-box! flag #t)) - ;; have to return something here, so that we can continue typechecking - new-t)) - ;; loop : listof[effect] -> tc-result - (let loop ([effs effs]) - ;; convenience macro for checking the rest of the list - (define-syntax check-rest - (syntax-rules () - [(check-rest f v) - (with-update-type/lexical f v (loop (cdr effs)))] - [(check-rest f t v) - (check-rest (type-op f t) v)])) - (if (null? effs) - ;; base case - (let* ([reachable? (not (unbox flag))]) - (unless reachable? - (warn-unreachable expr)) - (cond - ;; if flag is true, then we don't want to verify that this branch has the appropriate type - ;; in particular, it might be (void) - [(and expected reachable?) - (tc-expr/check expr expected)] - ;; this code is reachable, but we have no expected type - [reachable? - (tc-expr expr)] - ;; otherwise, this code is unreachable - ;; and the resulting type should be the empty type - [(check-unreachable-code?) - (tc-expr/check expr Univ) - (ret (Un))] - [else - (ret (Un))])) - ;; recursive case - (match (car effs) - ;; these effects have no consequence for the typechecking - [(True-Effect:) - (or t/f (set-box! flag #t)) - (loop (cdr effs))] - [(False-Effect:) - (and t/f (set-box! flag #t)) - (loop (cdr effs))] - ;; restrict v to have a type that's a subtype of t - [(Restrict-Effect: t v) - (check-rest restrict t v)] - ;; remove t from the type of v - [(Remove-Effect: t v) (check-rest *remove t v)] - ;; just replace the type of v with (-val #f) - [(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)] - ;; v cannot have type (-val #f) - [(Var-True-Effect: v) - (check-rest *remove (-val #f) v)]))))) - -;; the main function -(define (tc/if-twoarm tst thn els) - ;; check in the context of the effects, and return - (match-let* ([(tc-result: tst-ty tst-thn-eff tst-els-eff) (tc-expr tst)] - [(tc-result: thn-ty thn-thn-eff thn-els-eff) (tc-expr/eff #t thn tst-thn-eff #f)] - [(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff #f)]) - (match* (els-ty thn-thn-eff thn-els-eff els-thn-eff els-els-eff) - ;; this is the case for `or' - ;; the then branch has to be #t - ;; the else branch has to be a simple predicate - ;; FIXME - can something simpler be done by using demorgan's law? - ;; note that demorgan's law doesn't hold for scheme `and' and `or' because they can produce arbitrary values - ;; FIXME - mzscheme's or macro doesn't match this! - [(_ (list (True-Effect:)) (list (True-Effect:)) (list (Restrict-Effect: t v)) (list (Remove-Effect: t v*))) - (=> unmatch) - (match (list tst-thn-eff tst-els-eff) - ;; check that the test was also a simple predicate - [(list (list (Restrict-Effect: s u)) (list (Remove-Effect: s u*))) - (if (and - ;; check that all the predicates are for the for the same identifier - (free-identifier=? u u*) - (free-identifier=? v v*) - (free-identifier=? v u)) - ;; this is just a very simple or - (ret (Un (-val #t) els-ty) - ;; the then and else effects are just the union of the two types - (list (make-Restrict-Effect (Un s t) v)) - (list (make-Remove-Effect (Un s t) v))) - ;; otherwise, something complicated is happening and we bail - (unmatch))] - ;; similarly, bail here - [_ (unmatch)])] - ;; this is the case for `and' - [(_ _ _ (list (False-Effect:)) (list (False-Effect:))) - (ret (Un (-val #f) thn-ty) - ;; we change variable effects to type effects in the test, - ;; because only the boolean result of the test is used - ;; whereas, the actual value of the then branch is returned, not just the boolean result - (append (map var->type-eff tst-thn-eff) thn-thn-eff) - ;; no else effects for and, because any branch could have been false - (list))] - ;; if the else branch can never happen, just use the effect of the then branch - [((Union: (list)) _ _ _ _) - (ret thn-ty thn-thn-eff thn-els-eff)] - ;; otherwise this expression has no effects - [(_ _ _ _ _) - (ret (Un thn-ty els-ty))]))) - -;; checking version -(define (tc/if-twoarm/check tst thn els expected) - ;; check in the context of the effects, and return - (match-let* ([(tc-result: tst-ty tst-thn-eff tst-els-eff) (tc-expr tst)] - [(tc-result: thn-ty thn-thn-eff thn-els-eff) (tc-expr/eff #t thn tst-thn-eff expected)] - [(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff expected)]) - (match* (els-ty thn-thn-eff thn-els-eff els-thn-eff els-els-eff) - ;; this is the case for `or' - ;; the then branch has to be #t - ;; the else branch has to be a simple predicate - ;; FIXME - can something simpler be done by using demorgan's law? - ;; note that demorgan's law doesn't hold for scheme `and' and `or' because they can produce arbitrary values - ;; FIXME - mzscheme's or macro doesn't match this! - [(_ (list (True-Effect:)) (list (True-Effect:)) (list (Restrict-Effect: t v)) (list (Remove-Effect: t v*))) - (=> unmatch) - (match (list tst-thn-eff tst-els-eff) - ;; check that the test was also a simple predicate - [(list (list (Restrict-Effect: s u)) (list (Remove-Effect: s u*))) - (if (and - ;; check that all the predicates are for the for the same identifier - (free-identifier=? u u*) - (free-identifier=? v v*) - (free-identifier=? v u)) - ;; this is just a very simple or - (let ([t (Un (-val #t) els-ty)]) - (check-below t expected) - (ret t - ;; the then and else effects are just the union of the two types - (list (make-Restrict-Effect (Un s t) v)) - (list (make-Remove-Effect (Un s t) v)))) - ;; otherwise, something complicated is happening and we bail - (unmatch))] - ;; similarly, bail here - [_ (unmatch)])] - ;; this is the case for `and' - [(_ _ _ (list (False-Effect:)) (list (False-Effect:))) - (let ([t (Un thn-ty (-val #f))]) - (check-below t expected) - (ret t - ;; we change variable effects to type effects in the test, - ;; because only the boolean result of the test is used - ;; whereas, the actual value of the then branch is returned, not just the boolean result - (append (map var->type-eff tst-thn-eff) thn-thn-eff) - ;; no else effects for and, because any branch could have been false - (list)))] - ;; if the else branch can never happen, just use the effect of the then branch - [((Union: (list)) _ _ _ _) - (ret thn-ty - ;; we change variable effects to type effects in the test, - ;; because only the boolean result of the test is used - ;; whereas, the actual value of the then branch is returned, not just the boolean result - thn-thn-eff - ;; no else effects for and, because any branch could have been false - thn-els-eff)] - ;; otherwise this expression has no effects - [(_ _ _ _ _) - (let ([t (Un thn-ty els-ty)]) - (check-below t expected) - (ret t))]))) diff --git a/collects/typed-scheme/typecheck/tc-new-app-unit.ss b/collects/typed-scheme/typecheck/tc-new-app-unit.ss deleted file mode 100644 index a29568b275..0000000000 --- a/collects/typed-scheme/typecheck/tc-new-app-unit.ss +++ /dev/null @@ -1,18 +0,0 @@ -#lang scheme/unit - -(require "signatures.ss" "../utils/utils.ss") -(require (utils tc-utils)) - -(import tc-expr^ tc-lambda^ tc-dots^) -(export tc-app^) - -(define (tc/app . args) - (int-err "tc/app NYI")) - -(define (tc/app/check . args) - (int-err "tc/app/check NYI")) - -(define (tc/funapp . args) - (int-err "tc/funapp NYI")) - - From 844cbc678210650cf8c0f7982f1cc4179b46d20b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 22:06:48 +0000 Subject: [PATCH 154/156] move new-if to if. svn: r14942 --- collects/typed-scheme/typecheck/{tc-new-if.ss => tc-if.ss} | 0 collects/typed-scheme/typecheck/typechecker.ss | 4 ++-- 2 files changed, 2 insertions(+), 2 deletions(-) rename collects/typed-scheme/typecheck/{tc-new-if.ss => tc-if.ss} (100%) diff --git a/collects/typed-scheme/typecheck/tc-new-if.ss b/collects/typed-scheme/typecheck/tc-if.ss similarity index 100% rename from collects/typed-scheme/typecheck/tc-new-if.ss rename to collects/typed-scheme/typecheck/tc-if.ss diff --git a/collects/typed-scheme/typecheck/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss index 3a1e2b3173..4c186cd5a2 100644 --- a/collects/typed-scheme/typecheck/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -7,11 +7,11 @@ provide-signature-elements define-values/invoke-unit/infer link) "signatures.ss" "tc-toplevel.ss" - "tc-new-if.ss" "tc-lambda-unit.ss" "tc-app.ss" + "tc-if.ss" "tc-lambda-unit.ss" "tc-app.ss" "tc-let-unit.ss" "tc-dots-unit.ss" "tc-expr-unit.ss" "check-subforms-unit.ss") (provide-signature-elements typechecker^ tc-expr^) (define-values/invoke-unit/infer - (link tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)) + (link tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)) From c27dccb9d8a5e475bc4b592995c183e1d946cd2b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 22 May 2009 22:30:24 +0000 Subject: [PATCH 155/156] Improve error messages and printing. Turn off contracts. svn: r14947 --- .../typed-scheme/typecheck/tc-app-helper.ss | 17 +++++++++++------ collects/typed-scheme/typecheck/tc-expr-unit.ss | 14 +++++++------- collects/typed-scheme/typed-scheme.ss | 4 +++- collects/typed-scheme/types/printer.ss | 12 ++++++++---- collects/typed-scheme/utils/utils.ss | 2 +- 5 files changed, 30 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss index 4ea2ff3071..170c7ee2bc 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.ss +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -5,14 +5,19 @@ (provide (all-defined-out)) +(define (make-printable t) + (match t + [(tc-result1: t) t] + [_ t])) + (define (stringify-domain dom rst drst [rng #f]) - (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] + (let ([doms-string (if (null? dom) "" (string-append (stringify (map make-printable dom)) " "))] [rng-string (if rng (format " -> ~a" rng) "")]) (cond [drst (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] [rst (format "~a~a *~a" doms-string rst rng-string)] - [else (string-append (stringify dom) rng-string)]))) + [else (string-append (stringify (map make-printable dom)) rng-string)]))) (define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) (define arguments-str @@ -26,18 +31,18 @@ arguments-str (if expected (format "Result type: ~a~nExpected result: ~a~n" - (car rngs) expected) + (car rngs) (make-printable expected)) ""))] [else (format "~a: ~a~nArguments: ~a~n~a" (if expected "Types" "Domains") (stringify (if expected - (map stringify-domain doms rests drests rngs) - (map stringify-domain doms rests drests)) + (map stringify-domain (map make-printable doms) rests drests rngs) + (map stringify-domain (map make-printable doms) rests drests)) "~n\t") arguments-str (if expected - (format "Expected result: ~a~n" expected) + (format "Expected result: ~a~n" (make-printable expected)) ""))])) (define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index e42ad5068d..3fac723045 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -137,30 +137,30 @@ expected] [((tc-results: t1) (tc-results: t2)) (unless (= (length t1) (length t2)) - (tc-error/expr "0.5 Expected ~a values, but got ~a" (length t2) (length t1))) + (tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1))) (unless (for/and ([t t1] [s t2]) (subtype t s)) - (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) expected] [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound)) (unless (andmap subtype t1 t2) - (tc-error/expr "1.5 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) expected] [((tc-result1: t1 f o) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr "1 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) (ret t2 f o)] [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:))) (unless (subtype t1 t2) - (tc-error/expr "3 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) t1] [((? Type? t1) (tc-result1: t2 f o)) (if (subtype t1 t2) (tc-error/expr "Expected result with filter ~a and object ~a, got ~a" f o t1) - (tc-error/expr "4 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) t1] [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) - (tc-error/expr "5 Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected])) (define (tc-expr/check/type form expected) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 3679a8f4b9..323d7713e9 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -132,8 +132,10 @@ body2] [_ (let ([ty-str (match type [(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f] + [(tc-result1: t) + (format "- : ~a\n" t)] [(tc-results: t) - (format "- : ~a\n" type)] + (format "- : ~a\n" (cons 'Values t))] [x (int-err "bad type result: ~a" x)])]) (if ty-str #`(let ([type '#,ty-str]) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 9eeca9b249..55aefcd2fa 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -90,14 +90,17 @@ (when drest (fp "~a ... ~a " (car drest) (cdr drest))) (match rng - #| [(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:)))) (fp "-> ~a" t)] + [(Values: (list (Result: t + (LFilterSet: (list (LTypeFilter: ft '() 0)) + (list (LNotTypeFilter: ft '() 0))) + (LEmpty:)))) + (fp "-> ~a : ~a" t ft)] [(Values: (list (Result: t fs (LEmpty:)))) (fp "-> ~a : ~a" t fs)] [(Values: (list (Result: t lf lo))) (fp "-> ~a : ~a ~a" t lf lo)] -|# [_ (fp "-> ~a" rng)]) (fp ")")])) @@ -116,7 +119,7 @@ ;; names are just the printed as the original syntax [(Name: stx) (fp "~a" (syntax-e stx))] [(App: rator rands stx) - (fp "~a" (list* '@ rator rands))] + (fp "~a" (list* rator rands))] ;; special cases for lists [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (fp "(Listof ~a)" elem-ty)] @@ -153,7 +156,7 @@ [(Pair: l r) (fp "(Pair ~a ~a)" l r)] [(F: nm) (fp "~a" nm)] ;; FIXME - ;[(Values: (list v)) (fp "~a" v)] + [(Values: (list v)) (fp "~a" v)] [(Values: (list v ...)) (fp "~a" (cons 'values v))] [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))] [(Param: in out) @@ -195,6 +198,7 @@ [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] [(Refinement: parent p? _) (fp "(Refinement ~a ~a)" parent (syntax-e p?))] + [(Error:) (fp "Error")] [else (fp "Unknown Type: ~a" (struct->vector c))] )) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 79c0b38517..4baf94b36d 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -273,7 +273,7 @@ at least theoretically. (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) -(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) (define-syntax p/c From c1eb25e47fe682861017fad901e23e0e9f626045 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 23 May 2009 23:00:23 +0000 Subject: [PATCH 156/156] move additional tests to test dir svn: r14963 --- collects/{typed-scheme => tests/typed-scheme/succeed}/test.ss | 0 collects/{typed-scheme => tests/typed-scheme/succeed}/test2.ss | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename collects/{typed-scheme => tests/typed-scheme/succeed}/test.ss (100%) rename collects/{typed-scheme => tests/typed-scheme/succeed}/test2.ss (100%) diff --git a/collects/typed-scheme/test.ss b/collects/tests/typed-scheme/succeed/test.ss similarity index 100% rename from collects/typed-scheme/test.ss rename to collects/tests/typed-scheme/succeed/test.ss diff --git a/collects/typed-scheme/test2.ss b/collects/tests/typed-scheme/succeed/test2.ss similarity index 100% rename from collects/typed-scheme/test2.ss rename to collects/tests/typed-scheme/succeed/test2.ss