diff --git a/typed-racket-lib/typed-racket/env/global-env.rkt b/typed-racket-lib/typed-racket/env/global-env.rkt index 6c026e7d5..059469d67 100644 --- a/typed-racket-lib/typed-racket/env/global-env.rkt +++ b/typed-racket-lib/typed-racket/env/global-env.rkt @@ -75,9 +75,7 @@ (define (maybe-finish-register-type id) (define v (free-id-table-ref the-mapping id)) - (if (box? v) - (register-type id (unbox v)) - #f)) + (and (box? v) (register-type id (unbox v)))) (define (unregister-type id) (free-id-table-remove! the-mapping id)) diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt index 3cdecf0ba..4b0614fe1 100644 --- a/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -437,10 +437,9 @@ (define (bound-in-this-module id) (define binding (identifier-binding id)) - (if (and (list? binding) (module-path-index? (car binding))) - (let-values ([(mp base) (module-path-index-split (car binding))]) - (not mp)) - #f)) + (and (and (list? binding) (module-path-index? (car binding))) + (let-values ([(mp base) (module-path-index-split (car binding))]) + (not mp)))) (define (make-init-code map f) (define (bound-f id v) diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt index a306c052d..14f85e32f 100644 --- a/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -915,7 +915,8 @@ [(? variance:const?) S] [(? variance:co?) S] [(? variance:contra?) T] - [(? variance:inv?) (let ([gS (generalize S)]) (if (subtype gS T) gS S))])) + [(? variance:inv?) (define gS (generalize S)) + (if (subtype gS T) gS S)])) ;; Since we don't add entries to the empty cset for index variables (since there is no ;; widest constraint, due to dcon-exacts), we must add substitutions here if no constraint diff --git a/typed-racket-lib/typed-racket/infer/intersect.rkt b/typed-racket-lib/typed-racket/infer/intersect.rkt index 3754f3a73..579730a0e 100644 --- a/typed-racket-lib/typed-racket/infer/intersect.rkt +++ b/typed-racket-lib/typed-racket/infer/intersect.rkt @@ -178,37 +178,38 @@ (-unsafe-intersect initial-t1 initial-t2) initial-t1)] [else - (let ([t2 (if (resolvable? initial-t2) - (resolve-once initial-t2) - initial-t2)]) - (cond - ;; if t2 is not a fully defined type, do the simple thing - [(not t2) - (if additive? - (-unsafe-intersect t1 initial-t2) - t1)] - [else - ;; we've never seen these types together before! let's gensym a symbol - ;; so that if we do encounter them again, we can create a μ type. - (define name (gensym 'rec)) - ;; the 'record' contains the back pointer symbol we may or may not use in - ;; the car, and a flag for whether or not we actually used the back pointer - ;; in the cdr. - (define record (mcons name #f)) - (define seen* - (list* (cons (cons initial-t1 initial-t2) record) - (cons (cons initial-t2 initial-t1) record) - seen)) - (define t - (cond - [additive? (internal-intersect t1 t2 seen* obj)] - [else (internal-restrict t1 t2 seen* obj)])) + (define t2 + (if (resolvable? initial-t2) + (resolve-once initial-t2) + initial-t2)) + (cond + ;; if t2 is not a fully defined type, do the simple thing + [(not t2) + (if additive? + (-unsafe-intersect t1 initial-t2) + t1)] + [else + ;; we've never seen these types together before! let's gensym a symbol + ;; so that if we do encounter them again, we can create a μ type. + (define name (gensym 'rec)) + ;; the 'record' contains the back pointer symbol we may or may not use in + ;; the car, and a flag for whether or not we actually used the back pointer + ;; in the cdr. + (define record (mcons name #f)) + (define seen* + (list* (cons (cons initial-t1 initial-t2) record) + (cons (cons initial-t2 initial-t1) record) + seen)) + (define t (cond - ;; check if we used the backpointer, if so, - ;; make a recursive type using that name - [(mcdr record) (make-Mu name t)] - ;; otherwise just return the result - [else t])]))])) + [additive? (internal-intersect t1 t2 seen* obj)] + [else (internal-restrict t1 t2 seen* obj)])) + (cond + ;; check if we used the backpointer, if so, + ;; make a recursive type using that name + [(mcdr record) (make-Mu name t)] + ;; otherwise just return the result + [else t])])])) ;; intersect diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 460c7b383..ba7f2a9e8 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -901,8 +901,8 @@ [sc* (remove-duplicates sc*)] [sc* (remove-overlap sc* (list - (cons vector?/sc (list mutable-vector?/sc immutable-vector?/sc)) - (cons hash?/sc (list mutable-hash?/sc weak-hash?/sc immutable-hash?/sc))))]) + (list vector?/sc mutable-vector?/sc immutable-vector?/sc) + (list hash?/sc mutable-hash?/sc weak-hash?/sc immutable-hash?/sc)))]) (apply shallow-or/sc sc*))] [t (t->sc t bound-all-vars)])] [(Intersection: ts raw-prop) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt index 8ea8181bf..b55e2e4bd 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt @@ -61,10 +61,9 @@ (list invoke/scs ...))) v) (define (sig-spec->syntax sig-spec) - (match sig-spec - [(signature-spec name members scs) - (define member-stx (map (lambda (id sc) #`(#,id #,(f sc))) members scs)) - #`(#,name #,@member-stx)])) + (match-define (signature-spec name members scs) sig-spec) + (define member-stx (map (lambda (id sc) #`(#,id #,(f sc))) members scs)) + #`(#,name #,@member-stx)) (define (invokes->contract lst) (cond diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 8b81d8e48..11b22d64e 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -689,29 +689,17 @@ name-key-or-list)) (hash-ref parse-info name-key-or-list))) (for/list ([m names]) (dict-ref local-table m))) - (define-values (localized-method-names - localized-field-pairs - localized-private-field-pairs - localized-inherit-field-pairs - localized-inherit-names - localized-private-methods - localized-override-names - localized-pubment-names - localized-augment-names - localized-inner-names - localized-init-names) - (values - (localize local-method-table 'method-internals) - (localize local-field-table 'field-internals) - (localize local-private-field-table 'private-fields) - (localize local-inherit-field-table 'inherit-field-internals) - (localize local-inherit-table 'inherit-internals) - (localize local-private-table 'private-names) - (localize local-super-table 'override-internals) - (localize local-augment-table 'pubment-internals) - (localize local-augment-table 'augment-internals) - (localize local-inner-table '(pubment-internals augment-internals)) - (localize local-init-table 'only-init-internals))) + (define localized-method-names (localize local-method-table 'method-internals)) + (define localized-field-pairs (localize local-field-table 'field-internals)) + (define localized-private-field-pairs (localize local-private-field-table 'private-fields)) + (define localized-inherit-field-pairs (localize local-inherit-field-table 'inherit-field-internals)) + (define localized-inherit-names (localize local-inherit-table 'inherit-internals)) + (define localized-private-methods (localize local-private-table 'private-names)) + (define localized-override-names (localize local-super-table 'override-internals)) + (define localized-pubment-names (localize local-augment-table 'pubment-internals)) + (define localized-augment-names (localize local-augment-table 'augment-internals)) + (define localized-inner-names (localize local-inner-table '(pubment-internals augment-internals))) + (define localized-init-names (localize local-init-table 'only-init-internals)) (define localized-field-get-names (map car localized-field-pairs)) (define localized-field-set-names (map cadr localized-field-pairs)) (define localized-private-field-get-names (map car localized-private-field-pairs)) diff --git a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt index 947eab7c7..5e18b7e81 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt @@ -175,7 +175,8 @@ ;; this map is used to determine the actual signatures corresponding to the ;; given signature tags of the init-depends (define tag-map (make-immutable-free-id-table (map cons import-tags import-sigs))) - (define lookup-temp (λ (temp) (free-id-table-ref export-temp-internal-map temp #f))) + (define (lookup-temp temp) + (free-id-table-ref export-temp-internal-map temp #f)) (values (for/list ([sig-id (in-list import-sigs)] [sig-internal-ids (in-list import-internal-ids)]) diff --git a/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt b/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt index 2a6f18883..6446860f3 100644 --- a/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt +++ b/typed-racket-lib/typed-racket/typecheck/integer-refinements.rkt @@ -71,143 +71,127 @@ #:attr obj (if (Object? o) o -empty-obj))) ;; < <= >= = -(define (numeric-comparison-function prop-constructor) - (λ (args-stx result) - (syntax-parse args-stx - [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) - (define p (prop-constructor (attribute e1.obj) (attribute e2.obj))) - (add-p/not-p result p)] - [((~var e1 (w/type -Int)) (~var e2 (w/type -Int)) (~var e3 (w/type -Int))) - #:when (or (and (Object? (attribute e1.obj)) (Object? (attribute e2.obj))) - (and (Object? (attribute e2.obj)) (Object? (attribute e3.obj)))) - (define p (-and (prop-constructor (attribute e1.obj) (attribute e2.obj)) - (prop-constructor (attribute e2.obj) (attribute e3.obj)))) - (add-p/not-p result p)] - [_ result]))) +(define ((numeric-comparison-function prop-constructor) args-stx result) + (syntax-parse args-stx + [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) + (define p (prop-constructor (attribute e1.obj) (attribute e2.obj))) + (add-p/not-p result p)] + [((~var e1 (w/type -Int)) (~var e2 (w/type -Int)) (~var e3 (w/type -Int))) + #:when (or (and (Object? (attribute e1.obj)) (Object? (attribute e2.obj))) + (and (Object? (attribute e2.obj)) (Object? (attribute e3.obj)))) + (define p + (-and (prop-constructor (attribute e1.obj) (attribute e2.obj)) + (prop-constructor (attribute e2.obj) (attribute e3.obj)))) + (add-p/not-p result p)] + [_ result])) ;; +/- -(define (plus/minus plus?) - (λ (args-stx result) - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse args-stx - ;; +/- (2 args) - [((~var e1 (w/obj+type -Int)) - (~var e2 (w/obj+type -Int))) - (define (sign o) (if plus? o (scale-obj -1 o))) - (define l (-lexp (attribute e1.obj) (sign (attribute e2.obj)))) - (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) - ps - l)] - ;; +/- (3 args) - [((~var e1 (w/obj+type -Int)) - (~var e2 (w/obj+type -Int)) - (~var e3 (w/obj+type -Int))) - (define (sign o) (if plus? o (scale-obj -1 o))) - (define l (-lexp (attribute e1.obj) (sign (attribute e2.obj)) (sign (attribute e3.obj)))) - (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) - ps - l)] - [_ result])] - [_ result]))) +(define ((plus/minus plus?) args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + ;; +/- (2 args) + [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) + (define (sign o) + (if plus? + o + (scale-obj -1 o))) + (define l (-lexp (attribute e1.obj) (sign (attribute e2.obj)))) + (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) ps l)] + ;; +/- (3 args) + [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int)) (~var e3 (w/obj+type -Int))) + (define (sign o) + (if plus? + o + (scale-obj -1 o))) + (define l (-lexp (attribute e1.obj) (sign (attribute e2.obj)) (sign (attribute e3.obj)))) + (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) ps l)] + [_ result])] + [_ result])) ;; equal?/eqv?/eq? ;; if only one side is a supported type, we can learn integer equality for ;; a result of `#t`, whereas if both sides are of the supported type, ;; we learn on both `#t` and `#f` answers -(define (equality-function supported-type) - (λ (args-stx result) - (syntax-parse args-stx - [((~var e1 (w/obj+type supported-type)) (~var e2 (w/obj+type supported-type))) - (define p (-eq (attribute e1.obj) (attribute e2.obj))) - (add-p/not-p result p)] - [((~var e1 (w/obj+type supported-type)) (~var e2 (w/obj+type Univ))) - (define p (-eq (attribute e1.obj) (attribute e2.obj))) - (add-to-pos-side result p)] - [((~var e1 (w/obj+type Univ)) (~var e2 (w/obj+type supported-type))) - (define p (-eq (attribute e1.obj) (attribute e2.obj))) - (add-to-pos-side result p)] - [_ result]))) +(define ((equality-function supported-type) args-stx result) + (syntax-parse args-stx + [((~var e1 (w/obj+type supported-type)) (~var e2 (w/obj+type supported-type))) + (define p (-eq (attribute e1.obj) (attribute e2.obj))) + (add-p/not-p result p)] + [((~var e1 (w/obj+type supported-type)) (~var e2 (w/obj+type Univ))) + (define p (-eq (attribute e1.obj) (attribute e2.obj))) + (add-to-pos-side result p)] + [((~var e1 (w/obj+type Univ)) (~var e2 (w/obj+type supported-type))) + (define p (-eq (attribute e1.obj) (attribute e2.obj))) + (add-to-pos-side result p)] + [_ result])) ;; * -(define product-function - (λ (args-stx result) - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse args-stx - [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) - (define product-obj (-obj* (attribute e1.obj) (attribute e2.obj))) - (cond - [(Object? product-obj) - (ret (-refine/fresh x ret-t (-eq (-lexp x) product-obj)) - ps - product-obj)] - [else result])] - [_ result])] - [_ result]))) +(define (product-function args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var e1 (w/obj+type -Int)) (~var e2 (w/obj+type -Int))) + (define product-obj (-obj* (attribute e1.obj) (attribute e2.obj))) + (cond + [(Object? product-obj) + (ret (-refine/fresh x ret-t (-eq (-lexp x) product-obj)) ps product-obj)] + [else result])] + [_ result])] + [_ result])) ;; make-vector -(define make-vector-function - (λ (args-stx result) - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse args-stx - [((~var size (w/obj+type -Int)) . _) - (ret (-refine/fresh v ret-t (-eq (-lexp (-vec-len-of (-id-path v))) - (attribute size.obj))) - ps - orig-obj)] - [_ result])] - [_ result]))) +(define (make-vector-function args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var size (w/obj+type -Int)) . _) + (ret (-refine/fresh v ret-t (-eq (-lexp (-vec-len-of (-id-path v))) (attribute size.obj))) + ps + orig-obj)] + [_ result])] + [_ result])) ;; modulo -(define modulo-function - (λ (args-stx result) - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse args-stx - [((~var e1 (w/type -Int)) (~var e2 (w/obj+type -Nat))) - (ret (-refine/fresh x ret-t (-lt (-lexp x) (attribute e2.obj))) - ps - orig-obj)] - [_ result])] - [_ result]))) +(define (modulo-function args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var e1 (w/type -Int)) (~var e2 (w/obj+type -Nat))) + (ret (-refine/fresh x ret-t (-lt (-lexp x) (attribute e2.obj))) ps orig-obj)] + [_ result])] + [_ result])) ;; random -(define random-function - (λ (args-stx result) - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse args-stx - ;; random (1 arg) - [((~var e1 (w/obj+type -Nat))) - (ret (-refine/fresh x ret-t (-lt (-lexp x) (attribute e1.obj))) - ps - orig-obj)] - ;; random (2 arg) - [((~var e1 (w/type -Int)) (~var e2 (w/type -Int))) - #:when (or (Object? (attribute e1.obj)) - (Object? (attribute e2.obj))) - (ret (-refine/fresh x ret-t (-and (-leq (attribute e1.obj) (-lexp x)) - (-lt (-lexp x) (attribute e2.obj)))) - ps - orig-obj)] - [_ result])] - [_ result]))) +(define (random-function args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + ;; random (1 arg) + [((~var e1 (w/obj+type -Nat))) + (ret (-refine/fresh x ret-t (-lt (-lexp x) (attribute e1.obj))) ps orig-obj)] + ;; random (2 arg) + [((~var e1 (w/type -Int)) (~var e2 (w/type -Int))) + #:when (or (Object? (attribute e1.obj)) (Object? (attribute e2.obj))) + (ret (-refine/fresh x + ret-t + (-and (-leq (attribute e1.obj) (-lexp x)) + (-lt (-lexp x) (attribute e2.obj)))) + ps + orig-obj)] + [_ result])] + [_ result])) ;; add1 / sub1 -(define (add/sub-1-function add?) - (λ (args-stx result) - (match result - [(tc-result1: ret-t ps orig-obj) - (syntax-parse args-stx - [((~var e1 (w/obj+type -Int))) - (define l ((if add? -lexp-add1 -lexp-sub1) (attribute e1.obj))) - (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) - ps - l)] - [_ result])] - [_ result]))) +(define ((add/sub-1-function add?) args-stx result) + (match result + [(tc-result1: ret-t ps orig-obj) + (syntax-parse args-stx + [((~var e1 (w/obj+type -Int))) + (define l ((if add? -lexp-add1 -lexp-sub1) (attribute e1.obj))) + (ret (-refine/fresh x ret-t (-eq (-lexp x) l)) ps l)] + [_ result])] + [_ result])) (define linear-integer-function-table (make-immutable-free-id-table diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt index 77e6ea206..396d5f569 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt @@ -328,23 +328,31 @@ msg-rngs) ...)) _)) - (let ([fcn-string (name->function-str name)]) - (if (and (andmap null? msg-doms) - (null? argtypes)) - (tc-error/expr (string-append - "Could not infer types for applying polymorphic " + (define fcn-string (name->function-str name)) + (if (and (andmap null? msg-doms) (null? argtypes)) + (tc-error/expr + (string-append "Could not infer types for applying polymorphic " fcn-string "\n")) + (domain-mismatches + f-stx + args-stx + t + msg-doms + msg-rests + msg-rngs + argtypes + #f + #f + #:expected expected + #:msg-thunk + (lambda (dom) + (string-append "Polymorphic " fcn-string - "\n")) - (domain-mismatches f-stx args-stx t msg-doms msg-rests - msg-rngs argtypes #f #f #:expected expected - #:msg-thunk (lambda (dom) - (string-append - "Polymorphic " fcn-string " could not be applied to arguments:\n" - dom - (if (not (subset? (apply set-union (seteq) (map fv/list msg-doms)) - (list->seteq msg-vars))) - (string-append "Type Variables: " (stringify msg-vars) "\n") - ""))))))] + " could not be applied to arguments:\n" + dom + (if (not (subset? (apply set-union (seteq) (map fv/list msg-doms)) + (list->seteq msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + "")))))] [(Poly-names: msg-vars (DepFun: raw-domain _ raw-rng)) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 336eaeb09..8ee907112 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -143,8 +143,8 @@ (dynamic-wind (λ () (save-errors!)) (λ () - (let ([result (tc-expr/check form expected)]) - (and (not (current-type-error?)) result))) + (define result (tc-expr/check form expected)) + (and (not (current-type-error?)) result)) (λ () (restore-errors!)))))) (define (tc-expr/check/t? form expected) @@ -194,7 +194,7 @@ [t:assert-typecheck-failure (cond [(tc-expr/check? #'t.body expected) - (tc-error/expr #:stx #'t.body (format "Expected a type check error!"))] + (tc-error/expr #:stx #'t.body "Expected a type check error!")] [else (fix-results expected)])] ;; data @@ -317,9 +317,11 @@ (attribute opt.value)) (opt-convert fun-type required-pos optional-pos optional-supplied?)] [_ #f])) - (if conv-type - (begin (tc-expr/check/type #'fun conv-type) (fix-results expected)) - (tc-expr/check form #f))] + (cond + [conv-type + (tc-expr/check/type #'fun conv-type) + (fix-results expected)] + [else (tc-expr/check form #f)])] [(~and _:kw-lambda^ (let-values ([(f) fun]) (let-values _ diff --git a/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt b/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt index 728a718dc..c2fad8704 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt @@ -184,11 +184,11 @@ (define value->HT (case-lambda [(check-element h tycon expected-kt expected-vt) - (let* ([kts (hash-map h (lambda (x y) (check-element x expected-kt)))] - [vts (hash-map h (lambda (x y) (check-element y expected-vt)))] - [kt (apply Un kts)] - [vt (apply Un vts)]) - (tycon (check-below kt expected-kt) (check-below vt expected-vt)))] + (define kts (hash-map h (lambda (x y) (check-element x expected-kt)))) + (define vts (hash-map h (lambda (x y) (check-element y expected-vt)))) + (define kt (apply Un kts)) + (define vt (apply Un vts)) + (tycon (check-below kt expected-kt) (check-below vt expected-vt))] [(check-element h tycon) (define kt (generalize (apply Un (map check-element (hash-keys h))))) (define vt (generalize (apply Un (map check-element (hash-values h))))) diff --git a/typed-racket-lib/typed-racket/utils/plambda-utils.rkt b/typed-racket-lib/typed-racket/utils/plambda-utils.rkt index 1682dd42e..7271aa3ae 100644 --- a/typed-racket-lib/typed-racket/utils/plambda-utils.rkt +++ b/typed-racket-lib/typed-racket/utils/plambda-utils.rkt @@ -28,12 +28,12 @@ (filter pair? (map rest tvarss))) (define (get-poly-tvarss form) + (define p (plambda-prop form)) (define plambda-tvars - (let ([p (plambda-prop form)]) - (match (and p (map syntax-e (syntax->list p))) - [#f #f] - [(list var ... dvar '...) (list (list var dvar))] - [(list id ...) (list id)]))) + (match (and p (map syntax-e (syntax->list p))) + [#f #f] + [(list var ... dvar '...) (list (list var dvar))] + [(list id ...) (list id)])) (define scoped-tvarss (for/list ([tvarss (in-list (lookup-scoped-tvar-layer form))]) (for/list ([tvar (in-list tvarss)]) diff --git a/typed-racket-lib/typed-racket/utils/shallow-contract.rkt b/typed-racket-lib/typed-racket/utils/shallow-contract.rkt index f343d9011..d93a7c964 100644 --- a/typed-racket-lib/typed-racket/utils/shallow-contract.rkt +++ b/typed-racket-lib/typed-racket/utils/shallow-contract.rkt @@ -48,19 +48,17 @@ (define ((shallow-and/c . pred*) x) (let loop ([p?* pred*]) - (if (null? p?*) - #true - (if ((car p?*) x) - (loop (cdr p?*)) - #false)))) + (cond + [(null? p?*) #true] + [((car p?*) x) (loop (cdr p?*))] + [else #false]))) (define ((shallow-or/c . pred*) x) (let loop ([p?* pred*]) - (if (null? p?*) - #false - (if ((car p?*) x) - #true - (loop (cdr p?*)))))) + (cond + [(null? p?*) #false] + [((car p?*) x) #true] + [else (loop (cdr p?*))]))) (define (shallow-shape-check val pred ty-str ctx) (if (pred val) diff --git a/typed-racket-test/main.rkt b/typed-racket-test/main.rkt index aff981068..ed47d35a2 100644 --- a/typed-racket-test/main.rkt +++ b/typed-racket-test/main.rkt @@ -266,20 +266,37 @@ (run-unit-test-suite (or (places) 1)) 0)) - (if (and (nightly?) (eq? 'cgc (system-type 'gc))) - (printf "Skipping Typed Racket tests.\n") - (let ([to-run (cond [(single) (list (single))] - [else - (append (if (int?) (list (int-tests (excl))) '()) - (if (gui?) (list (gui-tests)) '()) - (if (external?) (list (external-tests)) '()) - (if (opt?) (list (optimization-tests)) '()) - (if (missed-opt?) (list (missed-optimization-tests)) '()) - (if (bench?) (list (compile-benchmarks)) '()) - (if (math?) (list (compile-math)) '()))])]) - (unless (and (= unit-test-retcode 0) (= 0 ((exec) to-run))) - (eprintf "Typed Racket Tests did not pass.\n") - (exit 1))))) + (cond + [(and (nightly?) (eq? 'cgc (system-type 'gc))) (printf "Skipping Typed Racket tests.\n")] + [else + (define to-run + (cond + [(single) (list (single))] + [else + (append (if (int?) + (list (int-tests (excl))) + '()) + (if (gui?) + (list (gui-tests)) + '()) + (if (external?) + (list (external-tests)) + '()) + (if (opt?) + (list (optimization-tests)) + '()) + (if (missed-opt?) + (list (missed-optimization-tests)) + '()) + (if (bench?) + (list (compile-benchmarks)) + '()) + (if (math?) + (list (compile-math)) + '()))])) + (unless (and (= unit-test-retcode 0) (= 0 ((exec) to-run))) + (eprintf "Typed Racket Tests did not pass.\n") + (exit 1))])) ;; nightly tests in `run.rkt` for drdr chart continuity (module test racket/base) diff --git a/typed-racket-test/optimizer/reset-port.rkt b/typed-racket-test/optimizer/reset-port.rkt index 913fb5678..a0859be36 100644 --- a/typed-racket-test/optimizer/reset-port.rkt +++ b/typed-racket-test/optimizer/reset-port.rkt @@ -5,7 +5,7 @@ (provide read-syntax) (define (read-syntax name port) - (read-line port) + (read-line port 'any) (when (port-counts-lines? port) (set-port-next-location! port 1 0 1)) (make-special-comment 'typed-racket/optimizer/reset-port)) diff --git a/typed-racket-test/optimizer/run.rkt b/typed-racket-test/optimizer/run.rkt index 4795a01b9..d49ed2900 100644 --- a/typed-racket-test/optimizer/run.rkt +++ b/typed-racket-test/optimizer/run.rkt @@ -11,7 +11,7 @@ (define (get-expected-results file) (with-input-from-file file #:mode 'text (lambda () ; from the test file - (read-line) ; skip the #;#; + (read-line (current-input-port) 'any) ; skip the #;#; (values (for/list ((l (in-lines (open-input-string (read))))) l) (read))))) diff --git a/typed-racket-test/optimizer/transform.rkt b/typed-racket-test/optimizer/transform.rkt index dced57d72..935f675d4 100644 --- a/typed-racket-test/optimizer/transform.rkt +++ b/typed-racket-test/optimizer/transform.rkt @@ -21,7 +21,7 @@ (define source-code (call-with-input-file* (build-path dir file) (lambda (in) - (read-line in) ; drop the #;#; + (read-line in 'any) ; drop the #;#; (read in) ; drop the old expected tr log (read in) ; drop the old expected output (port->string in)))) @@ -32,13 +32,12 @@ (for ((entry new-tr-log)) (write-stringln entry)) (write-stringln "END") - (if (regexp-match "\n" new-output) - (begin - (write-stringln "#<string p)))] - [submodule-test `(submod ,root-module test)] - [module-path (if (module-declared? submodule-test #t) - submodule-test - root-module)]) - (dynamic-require module-path #f)))) + (define root-module + `(file ,(if (string? p) + p + (path->string p)))) + (define submodule-test `(submod ,root-module test)) + (define module-path (if (module-declared? submodule-test #t) submodule-test root-module)) + (dynamic-require module-path #f))) (define (start-worker get-ch name) diff --git a/typed-racket-test/send-places.rkt b/typed-racket-test/send-places.rkt index 4e2b2545d..fc0b5641b 100644 --- a/typed-racket-test/send-places.rkt +++ b/typed-racket-test/send-places.rkt @@ -50,9 +50,9 @@ (define-values (res-ch res-ch*) (place-channel)) (place-channel-put enq-ch (vector 'log name dir res-ch*)) (define res (place-channel-get res-ch)) - (if (s-exn? res) - (raise (deserialize-exn res)) - res)] + (when (s-exn? res) + (raise (deserialize-exn res))) + res] [else (generate-log/place name dir)]))) @@ -61,8 +61,8 @@ (define-values (res-ch res-ch*) (place-channel)) (place-channel-put enq-ch (vector 'compile file res-ch*)) (define res (place-channel-get res-ch)) - (if (s-exn? res) - (raise (deserialize-exn res)) - res)] + (when (s-exn? res) + (raise (deserialize-exn res))) + res] [else (compile-path/place file)]))