diff --git a/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt b/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt index d93e2b96e..3b8d378fb 100644 --- a/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt +++ b/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt @@ -169,7 +169,7 @@ #:with ty #'t)) (define-splicing-syntax-class optional-standalone-annotation (pattern (~optional a:standalone-annotation) - #:attr ty (if (attribute a) #'a.ty #f))) + #:attr ty (and (attribute a) #'a.ty))) (define-syntax-class type-variables #:attributes ((vars 1)) @@ -330,10 +330,8 @@ (define-values (all-mand-tys all-opt-tys) (cond [kw-property - (define-values (mand-kw-set opt-kw-set) - (values - (list->set (lambda-kws-mand kw-property)) - (list->set (lambda-kws-opt kw-property)))) + (define mand-kw-set (list->set (lambda-kws-mand kw-property))) + (define opt-kw-set (list->set (lambda-kws-opt kw-property))) (define-values (mand-tys^ opt-kw^) (partition (part-pred opt-kw-set) diff --git a/typed-racket-lib/typed-racket/base-env/base-structs.rkt b/typed-racket-lib/typed-racket/base-env/base-structs.rkt index 4ac4cd298..d9deff1c8 100644 --- a/typed-racket-lib/typed-racket/base-env/base-structs.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-structs.rkt @@ -11,7 +11,11 @@ (require (for-template racket/base (prefix-in k: '#%kernel))) -(provide initialize-structs -Date -Srcloc -Date -Arity-At-Least -Exn) +(provide initialize-structs + -Date + -Srcloc + -Arity-At-Least + -Exn) (define-syntax define-hierarchy (syntax-rules (define-hierarchy) diff --git a/typed-racket-lib/typed-racket/base-env/unit-prims.rkt b/typed-racket-lib/typed-racket/base-env/unit-prims.rkt index f647bc194..8f2f7f2bb 100644 --- a/typed-racket-lib/typed-racket/base-env/unit-prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/unit-prims.rkt @@ -133,12 +133,8 @@ ;; in the signature, this is needed to typecheck define-values/invoke-unit forms (define-for-syntax (imports/members sig-id) (define-values (_1 imp-mem _2 _3) (signature-members sig-id sig-id)) - #`(#,sig-id #,@(map (lambda (id) - (local-expand - id - (syntax-local-context) - (kernel-form-identifier-list))) - imp-mem))) + #`(#,sig-id #,@(for/list ([id (in-list imp-mem)]) + (local-expand id (syntax-local-context) (kernel-form-identifier-list))))) ;; Given a list of signature specs ;; Processes each signature spec to determine the variables exported diff --git a/typed-racket-lib/typed-racket/env/global-env.rkt b/typed-racket-lib/typed-racket/env/global-env.rkt index 116c15a03..6c026e7d5 100644 --- a/typed-racket-lib/typed-racket/env/global-env.rkt +++ b/typed-racket-lib/typed-racket/env/global-env.rkt @@ -74,10 +74,10 @@ #:when (attribute type))) (define (maybe-finish-register-type id) - (let ([v (free-id-table-ref the-mapping id)]) - (if (box? v) - (register-type id (unbox v)) - #f))) + (define v (free-id-table-ref the-mapping id)) + (if (box? v) + (register-type id (unbox v)) + #f)) (define (unregister-type id) (free-id-table-remove! the-mapping id)) @@ -91,13 +91,15 @@ the-mapping (lambda (id e) (when (box? e) - (let ([bnd (identifier-binding id)]) - (tc-error/delayed #:stx id - "Declaration for `~a' provided, but `~a' ~a" - (syntax-e id) (syntax-e id) - (cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen - [(not bnd) "has no definition"] - [else "is defined in another module"]))))))) + (define bnd (identifier-binding id)) + (tc-error/delayed #:stx id + "Declaration for `~a' provided, but `~a' ~a" + (syntax-e id) + (syntax-e id) + (cond + [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen + [(not bnd) "has no definition"] + [else "is defined in another module"])))))) ;; map over the-mapping, producing a list ;; (id type -> T) -> listof[T] diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt index e5de247d6..62ff03c6b 100644 --- a/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -329,11 +329,10 @@ [(Instance: ty) `(make-Instance ,(type->sexp ty))] [(Signature: name extends mapping) (define (serialize-mapping m) - (map (lambda (id/ty) - (define id (car id/ty)) - (define ty (force (cdr id/ty))) - `(cons (quote-syntax ,id) ,(type->sexp ty))) - m)) + (for/list ([id/ty (in-list m)]) + (define id (car id/ty)) + (define ty (force (cdr id/ty))) + `(cons (quote-syntax ,id) ,(type->sexp ty)))) (define serialized-extends (and extends `(quote-syntax ,extends))) `(make-Signature (quote-syntax ,name) ,serialized-extends @@ -435,11 +434,10 @@ `(make-PrefabPE (quote ,key) ,idx)])) (define (bound-in-this-module id) - (let ([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))) + (define binding (identifier-binding id)) + (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/env/type-alias-env.rkt b/typed-racket-lib/typed-racket/env/type-alias-env.rkt index de5b4c3e9..1996a739d 100644 --- a/typed-racket-lib/typed-racket/env/type-alias-env.rkt +++ b/typed-racket-lib/typed-racket/env/type-alias-env.rkt @@ -80,10 +80,10 @@ (match v [(struct unresolved (stx _ persistent?)) (set-unresolved-in-process! v #t) - (let ([t (parse-type stx)]) - (when persistent? - (mapping-put! id (make-resolved t))) - t)] + (define t (parse-type stx)) + (when persistent? + (mapping-put! id (make-resolved t))) + t] [(struct resolved (t)) t])) diff --git a/typed-racket-lib/typed-racket/infer/constraints.rkt b/typed-racket-lib/typed-racket/infer/constraints.rkt index adf1aab67..2e38c1d5a 100644 --- a/typed-racket-lib/typed-racket/infer/constraints.rkt +++ b/typed-racket-lib/typed-racket/infer/constraints.rkt @@ -25,12 +25,10 @@ ;; add the constraints S <: var <: T to every map in cs (define (insert cs var S T) - (match cs - [(struct cset (maps)) - (make-cset (for/list ([map-entry (in-list maps)]) - (match-define (cons map dmap) map-entry) - (cons (hash-set map var (make-c S T)) - dmap)))])) + (match-define (struct cset (maps)) cs) + (make-cset (for/list ([map-entry (in-list maps)]) + (match-define (cons map dmap) map-entry) + (cons (hash-set map var (make-c S T)) dmap)))) ;; meet: Type Type -> Type ;; intersect the given types, producing the greatest lower bound @@ -86,8 +84,8 @@ ;; produces a cset of all of the maps in all of the given csets ;; FIXME: should this call `remove-duplicates`? (define (cset-join l) - (let ([mapss (map cset-maps l)]) - (make-cset (apply stream-append mapss)))) + (define mapss (map cset-maps l)) + (make-cset (apply stream-append mapss))) (define (stream-remove-duplicates st) (define seen (mutable-set)) diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt index d683e26ab..66597968f 100644 --- a/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -65,34 +65,28 @@ [indices (listof symbol?)]) #:transparent) (define (context-add-vars ctx vars) - (match ctx - [(context V X Y) - (context V (append vars X) Y)])) + (match-define (context V X Y) ctx) + (context V (append vars X) Y)) (define (context-add-var ctx var) - (match ctx - [(context V X Y) - (context V (cons var X) Y)])) + (match-define (context V X Y) ctx) + (context V (cons var X) Y)) (define (context-add ctx #:bounds [bounds empty] #:vars [vars empty] #:indices [indices empty]) - (match ctx - [(context V X Y) - (context (append bounds V) (append vars X) (append indices Y))])) + (match-define (context V X Y) ctx) + (context (append bounds V) (append vars X) (append indices Y))) (define (inferable-index? ctx bound) - (match ctx - [(context _ _ Y) - (memq bound Y)])) + (match-define (context _ _ Y) ctx) + (memq bound Y)) (define ((inferable-var? ctx) var) - (match ctx - [(context _ X _) - (memq var X)])) + (match-define (context _ X _) ctx) + (memq var X)) (define (empty-cset/context ctx) - (match ctx - [(context _ X Y) - (empty-cset X Y)])) + (match-define (context _ X Y) ctx) + (empty-cset X Y)) @@ -766,9 +760,8 @@ (list values -Nat))) (define type (for/or ([pred-type (in-list possibilities)]) - (match pred-type - [(list pred? type) - (and (pred? n) type)]))) + (match-define (list pred? type) pred-type) + (and (pred? n) type))) (cgen/seq context (seq (list type) -null-end) ts*)] ;; numeric? == #true [((Base-bits: #t _) (SequenceSeq: ts*)) @@ -915,16 +908,12 @@ ;; c : Constaint ;; variance : Variance (define (constraint->type v variance) - (match v - [(c S T) - (match variance - [(? variance:const?) S] - [(? variance:co?) S] - [(? variance:contra?) T] - [(? variance:inv?) (let ([gS (generalize S)]) - (if (subtype gS T) - gS - S))])])) + (match-define (c S T) v) + (match variance + [(? variance:const?) S] + [(? variance:co?) S] + [(? variance:contra?) T] + [(? variance:inv?) (let ([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 @@ -934,47 +923,40 @@ (hash-union (for/hash ([v (in-list Y)] #:unless (hash-has-key? S v)) - (let ([var (hash-ref idx-hash v variance:const)]) - (values v - (match var - [(? variance:const?) (i-subst null)] - [(? variance:co?) (i-subst null)] - [(? variance:contra?) (i-subst/starred null Univ)] - ;; TODO figure out if there is a better subst here - [(? variance:inv?) (i-subst null)])))) + (define var (hash-ref idx-hash v variance:const)) + (values v + (match var + [(? variance:const?) (i-subst null)] + [(? variance:co?) (i-subst null)] + [(? variance:contra?) (i-subst/starred null Univ)] + ;; TODO figure out if there is a better subst here + [(? variance:inv?) (i-subst null)]))) S)) (define (build-subst m) - (match m - [(cons cmap (dmap dm)) - (let* ([subst (hash-union - (for/hash ([(k dc) (in-hash dm)]) - (define (c->t c) (constraint->type c (hash-ref idx-hash k variance:const))) - (values - k - (match dc - [(dcon fixed #f) - (i-subst (map c->t fixed))] - [(or (dcon fixed rest) (dcon-exact fixed rest)) - (i-subst/starred - (map c->t fixed) - (c->t rest))] - [(dcon-dotted fixed dc dbound) - (i-subst/dotted - (map c->t fixed) - (c->t dc) - dbound)]))) - (for/hash ([(k v) (in-hash cmap)]) - (values k (t-subst (constraint->type v (hash-ref var-hash k variance:const))))))] - [subst (for/fold ([subst subst]) ([v (in-list X)]) - (let ([entry (hash-ref subst v #f)]) - ;; Make sure we got a subst entry for a type var - ;; (i.e. just a type to substitute) - ;; If we don't have one, there are no constraints on this variable - (if (and entry (t-subst? entry)) - subst - (hash-set subst v (t-subst Univ)))))]) - ;; verify that we got all the important variables - (extend-idxs subst))])) + (match-define (cons cmap (dmap dm)) m) + (let* ([subst (hash-union + (for/hash ([(k dc) (in-hash dm)]) + (define (c->t c) + (constraint->type c (hash-ref idx-hash k variance:const))) + (values k + (match dc + [(dcon fixed #f) (i-subst (map c->t fixed))] + [(or (dcon fixed rest) (dcon-exact fixed rest)) + (i-subst/starred (map c->t fixed) (c->t rest))] + [(dcon-dotted fixed dc dbound) + (i-subst/dotted (map c->t fixed) (c->t dc) dbound)]))) + (for/hash ([(k v) (in-hash cmap)]) + (values k (t-subst (constraint->type v (hash-ref var-hash k variance:const))))))] + [subst (for/fold ([subst subst]) ([v (in-list X)]) + (define entry (hash-ref subst v #f)) + ;; Make sure we got a subst entry for a type var + ;; (i.e. just a type to substitute) + ;; If we don't have one, there are no constraints on this variable + (if (and entry (t-subst? entry)) + subst + (hash-set subst v (t-subst Univ))))]) + ;; verify that we got all the important variables + (extend-idxs subst))) (if multiple-substitutions? (for/list ([md (in-stream (cset-maps C))]) (build-subst md)) diff --git a/typed-racket-lib/typed-racket/infer/intersect.rkt b/typed-racket-lib/typed-racket/infer/intersect.rkt index 9326ff136..3754f3a73 100644 --- a/typed-racket-lib/typed-racket/infer/intersect.rkt +++ b/typed-racket-lib/typed-racket/infer/intersect.rkt @@ -116,20 +116,16 @@ (nbits-intersect nbits1 nbits2))] [((BaseUnion: bbits nbits) (Base-bits: numeric? bits)) - (cond [numeric? (if (nbits-overlap? nbits bits) - t2 - -Bottom)] - [else (if (bbits-overlap? bbits bits) - t2 - -Bottom)])] + (cond + [numeric? (if (nbits-overlap? nbits bits) t2 -Bottom)] + [(bbits-overlap? bbits bits) t2] + [else -Bottom])] [((Base-bits: numeric? bits) (BaseUnion: bbits nbits)) - (cond [numeric? (if (nbits-overlap? nbits bits) - t1 - -Bottom)] - [else (if (bbits-overlap? bbits bits) - t1 - -Bottom)])] + (cond + [numeric? (if (nbits-overlap? nbits bits) t1 -Bottom)] + [(bbits-overlap? bbits bits) t1] + [else -Bottom])] [((BaseUnion-bases: bases1) t2) (apply Un (for/list ([b (in-list bases1)]) (rec b t2 obj)))] @@ -161,52 +157,58 @@ ;; If the back pointer is never used, we don't create a μ-type, we just ;; return the result (define (resolvable-intersect initial-t1 initial-t2 seen obj additive?) - (let ([t1 (if (resolvable? initial-t1) - (resolve-once initial-t1) - initial-t1)]) - (cond - [(assoc (cons initial-t1 initial-t2) seen) - ;; we've seen these types before! -- use the stored symbol - ;; as a back pointer with an 'F' type (i.e. a type variable) - => (match-lambda - [(cons _ record) - ;; record that we did indeed use the back - ;; pointer by set!-ing the flag - (set-mcdr! record #t) - (make-F (mcar record))])] - ;; if t1 is not a fully defined type, do the simple thing - [(not t1) (if additive? - (-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 t1 + (if (resolvable? initial-t1) + (resolve-once initial-t1) + initial-t1)) + (cond + [(assoc (cons initial-t1 initial-t2) seen) + ;; we've seen these types before! -- use the stored symbol + ;; as a back pointer with an 'F' type (i.e. a type variable) + => + (match-lambda + [(cons _ record) + ;; record that we did indeed use the back + ;; pointer by set!-ing the flag + (set-mcdr! record #t) + (make-F (mcar record))])] + ;; if t1 is not a fully defined type, do the simple thing + [(not t1) + (if additive? + (-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 - ;; 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/infer/promote-demote.rkt b/typed-racket-lib/typed-racket/infer/promote-demote.rkt index 21a321c2f..04af72941 100644 --- a/typed-racket-lib/typed-racket/infer/promote-demote.rkt +++ b/typed-racket-lib/typed-racket/infer/promote-demote.rkt @@ -14,7 +14,7 @@ [var-demote (c:-> Type? (c:listof symbol?) Type?)]) (define (V-in? V . ts) - (for/or ([e (in-list (append* (map fv ts)))]) + (for/or ([e (in-list (append-map fv ts))]) (memq e V))) ;; get-propset : SomeValues -> PropSet @@ -39,26 +39,12 @@ ;; arr? -> (or/c #f arr?) ;; Returns the changed arr or #f if there is no arr above it (define (arr-change arr) - (match arr - [(Arrow: dom rst kws rng rng-T+) - (cond - [(apply V-in? V (get-propsets rng)) - #f] - [(and (RestDots? rst) - (memq (RestDots-nm rst) V)) - (make-Arrow - (map contra dom) - (contra (RestDots-ty rst)) - (map contra kws) - (co rng) - rng-T+)] - [else - (make-Arrow - (map contra dom) - (and rst (contra rst)) - (map contra kws) - (co rng) - rng-T+)])])) + (match-define (Arrow: dom rst kws rng rng-T+) arr) + (cond + [(apply V-in? V (get-propsets rng)) #f] + [(and (RestDots? rst) (memq (RestDots-nm rst) V)) + (make-Arrow (map contra dom) (contra (RestDots-ty rst)) (map contra kws) (co rng) rng-T+)] + [else (make-Arrow (map contra dom) (and rst (contra rst)) (map contra kws) (co rng) rng-T+)])) (define (change-elems ts) (for/list ([t (in-list ts)]) (if (V-in? V t) diff --git a/typed-racket-lib/typed-racket/utils/any-wrap.rkt b/typed-racket-lib/typed-racket/utils/any-wrap.rkt index 65f793f26..f8ff873e0 100644 --- a/typed-racket-lib/typed-racket/utils/any-wrap.rkt +++ b/typed-racket-lib/typed-racket/utils/any-wrap.rkt @@ -83,29 +83,28 @@ (define-values (sym init auto ref set! imms par skip?) (parameterize ([current-inspector inspector]) (struct-type-info struct-type))) - (define-values (fun/chap-list _) + (define fun/chap-list (for/fold ([res null] - [imms imms]) - ([n (in-range (+ init auto))]) + [imms imms] + #:result res) + ([n (in-range (+ init auto))]) (if (and (pair? imms) (= (car imms) n)) ;; field is immutable - (values - (list* (make-struct-field-accessor ref n) - (lambda (s v) (with-contract-continuation-mark - blame+neg-party - (any-wrap/traverse v neg-party seen))) - res) - (cdr imms)) + (values (list* (make-struct-field-accessor ref n) + (lambda (s v) + (with-contract-continuation-mark blame+neg-party + (any-wrap/traverse v neg-party seen))) + res) + (cdr imms)) ;; field is mutable - (values - (list* (make-struct-field-accessor ref n) - (lambda (s v) (with-contract-continuation-mark - blame+neg-party - (any-wrap/traverse v neg-party seen))) - (make-struct-field-mutator set! n) - (lambda (s v) (fail neg-party s)) - res) - imms)))) + (values (list* (make-struct-field-accessor ref n) + (lambda (s v) + (with-contract-continuation-mark blame+neg-party + (any-wrap/traverse v neg-party seen))) + (make-struct-field-mutator set! n) + (lambda (s v) (fail neg-party s)) + res) + imms)))) (cond [par (append fun/chap-list (extract-functions par))] [else fun/chap-list])) diff --git a/typed-racket-lib/typed-racket/utils/disarm.rkt b/typed-racket-lib/typed-racket/utils/disarm.rkt index 3d9ffcd20..42c11a05f 100644 --- a/typed-racket-lib/typed-racket/utils/disarm.rkt +++ b/typed-racket-lib/typed-racket/utils/disarm.rkt @@ -9,17 +9,16 @@ (let loop ([v stx]) (cond [(syntax? v) - (let* ([stx (syntax-disarm v orig-insp)] + (let* ([stx v] [r (loop (syntax-e stx))]) (if (eq? r (syntax-e stx)) stx (datum->syntax stx r stx stx)))] - [(pair? v) (let ([a (loop (car v))] - [d (loop (cdr v))]) - (if (and (eq? a (car v)) - (eq? d (cdr v))) - v - (cons a d)))] + [(pair? v) (define a (loop (car v))) + (define d (loop (cdr v))) + (if (and (eq? a (car v)) (eq? d (cdr v))) + v + (cons a d))] [else v]))) (define orig-insp (variable-reference->module-declaration-inspector diff --git a/typed-racket-lib/typed-racket/utils/opaque-object.rkt b/typed-racket-lib/typed-racket/utils/opaque-object.rkt index 5263c1004..7f1f78825 100644 --- a/typed-racket-lib/typed-racket/utils/opaque-object.rkt +++ b/typed-racket-lib/typed-racket/utils/opaque-object.rkt @@ -53,7 +53,7 @@ (define guard/c (dynamic-object/c methods method-ctcs fields field-ctcs)) (define guard/c-proj ((contract-late-neg-projection guard/c) blame)) (λ (obj neg-party) - (when (not (object? obj)) + (unless (object? obj) (raise-blame-error blame #:missing-party neg-party obj "expected an object got ~a" obj)) (define actual-fields (field-names obj)) (define actual-methods diff --git a/typed-racket-lib/typed-racket/utils/plambda-utils.rkt b/typed-racket-lib/typed-racket/utils/plambda-utils.rkt index 3d382d9a0..7271aa3ae 100644 --- a/typed-racket-lib/typed-racket/utils/plambda-utils.rkt +++ b/typed-racket-lib/typed-racket/utils/plambda-utils.rkt @@ -28,22 +28,19 @@ (filter pair? (map rest tvarss))) (define (get-poly-tvarss form) - (let ([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)]))] - [scoped-tvarss - (for/list ((tvarss (in-list (lookup-scoped-tvar-layer form)))) - (for/list ((tvar (in-list tvarss))) - (match tvar - [(list (list v ...) dotted-v) - (list (map syntax-e v) (syntax-e dotted-v))] - [(list v ...) (map syntax-e v)])))]) - (if plambda-tvars - (cons plambda-tvars scoped-tvarss) - scoped-tvarss))) + (define p (plambda-prop form)) + (define plambda-tvars + (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)]) + (match tvar + [(list (list v ...) dotted-v) (list (map syntax-e v) (syntax-e dotted-v))] + [(list v ...) (map syntax-e v)])))) + (if plambda-tvars + (cons plambda-tvars scoped-tvarss) + scoped-tvarss)) diff --git a/typed-racket-lib/typed-racket/utils/prefab.rkt b/typed-racket-lib/typed-racket/utils/prefab.rkt index 00f356524..7014ef7ac 100644 --- a/typed-racket-lib/typed-racket/utils/prefab.rkt +++ b/typed-racket-lib/typed-racket/utils/prefab.rkt @@ -60,7 +60,7 @@ [(list (? number? n) (? vector? mut)) `(,base-sym ,n (0 #f) ,mut)] [(list (and auto (list auto-n _)) (? vector? mut)) - `(,base-sym ,(- remaining-length auto-n) ,auto ,mut)] + (list base-sym (- remaining-length auto-n) auto mut)] [(list (? number? n)) `(,base-sym ,n (0 #f) #())] [(list (and auto (list auto-n _))) diff --git a/typed-racket-lib/typed-racket/utils/shallow-contract.rkt b/typed-racket-lib/typed-racket/utils/shallow-contract.rkt index 25b486069..d93a7c964 100644 --- a/typed-racket-lib/typed-racket/utils/shallow-contract.rkt +++ b/typed-racket-lib/typed-racket/utils/shallow-contract.rkt @@ -46,23 +46,19 @@ (else ;#(keyword any/c real?)) diff --git a/typed-racket-lib/typed-racket/utils/struct-info.rkt b/typed-racket-lib/typed-racket/utils/struct-info.rkt index ec16b6ad2..ba9ca8fef 100644 --- a/typed-racket-lib/typed-racket/utils/struct-info.rkt +++ b/typed-racket-lib/typed-racket/utils/struct-info.rkt @@ -108,9 +108,7 @@ ;; the function returns the corresponding structure's type name (define/cond-contract (maybe-struct-info-wrapper-type ins) (c:-> c:any/c (c:or/c #f identifier?)) - (if (struct-info-wrapper? ins) - (struct-info-wrapper-type ins) - #f)) + (and (struct-info-wrapper? ins) (struct-info-wrapper-type ins))) ;; create a *-wrapper instance based on sname-is-constr? (define/cond-contract (make-struct-info-wrapper* id info type [sname-is-constr? #t]) diff --git a/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/typed-racket-lib/typed-racket/utils/tc-utils.rkt index cbd84cf51..d6a67c5f3 100644 --- a/typed-racket-lib/typed-racket/utils/tc-utils.rkt +++ b/typed-racket-lib/typed-racket/utils/tc-utils.rkt @@ -77,20 +77,19 @@ don't depend on any other portion of the system (define warn-unreachable? (make-parameter #t)) (define (warn-unreachable e) - (let ([l (current-logger)] - [stx (locate-stx e)]) - (when (and (warn-unreachable?) - (log-level? l 'warning) - (and (syntax-transforming?) - #;(syntax-original? (syntax-local-introduce e))) - #;(and (orig-module-stx) - (eq? (debugf syntax-source-module e) - (debugf syntax-source-module (orig-module-stx)))) - #;(syntax-source-module stx)) - (log-message l 'warning - (format "Typed Racket has detected unreachable code: ~.s" - (locate-stx e)) - e)))) + (define l (current-logger)) + (locate-stx e) + (when (and (warn-unreachable?) + (log-level? l 'warning) + (and (syntax-transforming?) #;(syntax-original? (syntax-local-introduce e))) + #;(and (orig-module-stx) + (eq? (debugf syntax-source-module e) + (debugf syntax-source-module (orig-module-stx)))) + #;(syntax-source-module stx)) + (log-message l + 'warning + (format "Typed Racket has detected unreachable code: ~.s" (locate-stx e)) + e))) (define locate-stx ;; this hash handles using `locate-stx` even when orig/expand change @@ -106,9 +105,9 @@ don't depend on any other portion of the system [else stx])))) (define (raise-typecheck-error msg stxs) - (if (null? (cdr stxs)) - (raise-syntax-error (string->symbol "Type Checker") msg (car stxs)) - (raise-syntax-error (string->symbol "Type Checker") msg #f #f stxs))) + (when (null? (cdr stxs)) + (raise-syntax-error (string->symbol "Type Checker") msg (car stxs))) + (raise-syntax-error (string->symbol "Type Checker") msg #f #f stxs)) (define delayed-errors null) @@ -137,18 +136,17 @@ don't depend on any other portion of the system (reset-errors!) (log-type-error (err-msg f) (err-stx f)) (raise-typecheck-error (err-msg f) (err-stx f))] - [else (let ([stxs - (for/list ([e (in-list l)]) - (with-handlers ([exn:fail:syntax? - (λ (e) ((error-display-handler) (exn-message e) e))]) - (log-type-error (err-msg e) (err-stx e)) - (raise-typecheck-error (err-msg e) (err-stx e))) - (err-stx e))]) - (reset-errors!) - (unless (null? stxs) - (raise-typecheck-error (format "Summary: ~a errors encountered" - (length stxs)) - (apply append stxs))))])) + [else (define stxs + (for/list ([e (in-list l)]) + (with-handlers ([exn:fail:syntax? (λ (e) + ((error-display-handler) (exn-message e) e))]) + (log-type-error (err-msg e) (err-stx e)) + (raise-typecheck-error (err-msg e) (err-stx e))) + (err-stx e))) + (reset-errors!) + (unless (null? stxs) + (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) + (apply append stxs)))])) ;; Returns #t if there's a type error recorded at the same position as ;; the given syntax object. Does not return a useful result if the @@ -197,17 +195,13 @@ don't depend on any other portion of the system (define delay-errors? (make-parameter #f)) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) - (let ([stx (locate-stx stx*)]) - (unless (syntax? stx) - (int-err "erroneous syntax was not a syntax object: ~a\n (error message: ~a)" - stx - msg)) - (current-type-error? #t) - (if (delay-errors?) - (set! delayed-errors (cons (make-err (apply format msg rest) - (list stx)) - delayed-errors)) - (raise-typecheck-error (apply format msg rest) (list stx))))) + (define stx (locate-stx stx*)) + (unless (syntax? stx) + (int-err "erroneous syntax was not a syntax object: ~a\n (error message: ~a)" stx msg)) + (current-type-error? #t) + (if (delay-errors?) + (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors)) + (raise-typecheck-error (apply format msg rest) (list stx)))) ;; Produce a type error using modern Racket error syntax. ;; Avoid using format directives in the `msg`, `more`, and `field` @@ -246,22 +240,25 @@ don't depend on any other portion of the system ;; produce a type error, using the current syntax (define (tc-error msg . rest) - (let* ([ostx (current-orig-stx)] - [ostxs (if (list? ostx) ostx (list ostx))] - [stxs (map locate-stx ostxs)]) - (current-type-error? #t) - ;; If this isn't original syntax, then we can get some pretty bogus error - ;; messages. Note that this is from a macro expansion, so that introduced - ;; vars and such don't confuse the user. - (cond - [(or (not (orig-module-stx)) - (for/and ([s (in-list ostxs)] #:when s) - (eq? (syntax-source s) (syntax-source (orig-module-stx))))) - (raise-typecheck-error (apply format msg rest) stxs)] - [else (raise-typecheck-error - (apply format (string-append "Error in macro expansion -- " msg) - rest) - stxs)]))) + (define ostx (current-orig-stx)) + (define ostxs + (if (list? ostx) + ostx + (list ostx))) + (define stxs (map locate-stx ostxs)) + (current-type-error? #t) + ;; If this isn't original syntax, then we can get some pretty bogus error + ;; messages. Note that this is from a macro expansion, so that introduced + ;; vars and such don't confuse the user. + (cond + [(or (not (orig-module-stx)) + (for/and ([s (in-list ostxs)] + #:when s) + (eq? (syntax-source s) (syntax-source (orig-module-stx))))) + (raise-typecheck-error (apply format msg rest) stxs)] + [else + (raise-typecheck-error (apply format (string-append "Error in macro expansion -- " msg) rest) + stxs)])) ;; produce a type error, given a particular syntax (define (tc-error/stx stx msg . rest) diff --git a/typed-racket-lib/typed-racket/utils/utils.rkt b/typed-racket-lib/typed-racket/utils/utils.rkt index 6bb2bd48a..4b76d76d2 100644 --- a/typed-racket-lib/typed-racket/utils/utils.rkt +++ b/typed-racket-lib/typed-racket/utils/utils.rkt @@ -180,7 +180,7 @@ at least theoretically. (begin (define (name . args) . body) (provide name)))])) -(define-simple-macro (define/cond-contract/provide (name:id . args) c . body) +(define-syntax-parse-rule (define/cond-contract/provide (name:id . args) c . body) (begin (define (name . args) . body) (provide/cond-contract [name c]))) @@ -377,10 +377,9 @@ at least theoretically. ;; quick in-list/rest and in-list-cycle sanity checks (module+ test - (unless (equal? (for/list ([_ (in-range 0)] - [val (in-list/rest (list 1 2) #f)]) - val) - (list)) + (unless (null? (for/list ([_ (in-range 0)] + [val (in-list/rest (list 1 2) #f)]) + val)) (error 'in-list/rest "broken!")) (unless (equal? (for/list ([_ (in-range 2)] [val (in-list/rest (list 1 2) #f)]) @@ -446,20 +445,20 @@ at least theoretically. (cond [(null? entries) (list (cons key val))] [else - (let ([entry (car entries)]) - (if (equal? (car entry) key) - (cons (cons key val) (cdr entries)) - (cons entry (loop (cdr entries)))))]))) + (define entry (car entries)) + (if (equal? (car entry) key) + (cons (cons key val) (cdr entries)) + (cons entry (loop (cdr entries))))]))) (define (assoc-remove d key) (let loop ([xd d]) (cond [(null? xd) null] [else - (let ([a (car xd)]) - (if (equal? (car a) key) - (cdr xd) - (cons a (loop (cdr xd)))))]))) + (define a (car xd)) + (if (equal? (car a) key) + (cdr xd) + (cons a (loop (cdr xd))))]))) (define (in-assoc-proc l) (in-parallel (map car l) (map cdr l)))