From d8b8ac1f8495068cfdae3e9e6efa27901c938e39 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 30 May 2008 18:56:49 +0000 Subject: [PATCH] Fix provide w/ structs. svn: r10055 original commit: f783e05cd81c5e143159324d260f5c3014c8177c --- collects/typed-scheme/private/base-env.ss | 2 +- collects/typed-scheme/private/subtype.ss | 8 ++++---- collects/typed-scheme/private/type-effect-convenience.ss | 2 +- collects/typed-scheme/private/type-effect-printer.ss | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 64655ac1..a210f85d 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -366,7 +366,7 @@ [current-error-port (-Param -Output-Port -Output-Port)] [current-input-port (-Param -Input-Port -Input-Port)] [round (N . -> . N)] - [seconds->date (N . -> . (make-Struct 'date #f (list N N N N N N N N B N) #f))] + [seconds->date (N . -> . (make-Struct 'date #f (list N N N N N N N N B N) #f #f #'date?))] [current-seconds (-> N)] [sqrt (-> N N)] [path->string (-> -Path -String)] diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index e2e59623..655c9a9d 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -214,12 +214,12 @@ [(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)) + [(list (Struct: nm _ flds #f _ _) (Struct: nm _ flds* #f _ _)) (subtypes* A0 flds flds*)] - [(list (Struct: nm _ flds proc) (Struct: nm _ flds* proc*)) + [(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) + [(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 @@ -261,7 +261,7 @@ (subtype* A0 t other) (fail! s t)))] ;; Promises are covariant - [(list (Struct: 'Promise _ (list t) _) (Struct: 'Promise _ (list t*) _)) (subtype* A0 t t*)] + [(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)] ;; single values shouldn't actually happen, but they're just like the type diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 9b7e4b97..000c8325 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -72,7 +72,7 @@ [(dom rng rest eff1 eff2) (make-arr dom rng rest eff1 eff2)])) (define (make-promise-ty t) - (make-Struct (string->uninterned-symbol "Promise") #f (list t) #f)) + (make-Struct (string->uninterned-symbol "Promise") #f (list t) #f #f #'promise?)) (define N (make-Base 'Number)) (define -Integer (make-Base 'Integer)) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 51681919..cf5314c5 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -84,8 +84,8 @@ (fp "~a" (cons 'List (tuple-elems t)))] [(Base: n) (fp "~a" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] - [(Struct: 'Promise par (list fld) proc) (fp "(Promise ~a)" fld)] - [(Struct: nm par flds proc) + [(Struct: 'Promise par (list fld) proc _ _) (fp "(Promise ~a)" fld)] + [(Struct: nm par flds proc _ _) (fp "#(struct:~a ~a" nm flds) (when proc (fp " ~a" proc))