diff --git a/typed-racket-lib/typed-racket/core.rkt b/typed-racket-lib/typed-racket/core.rkt index 4e3758ad2..bd5ef1496 100644 --- a/typed-racket-lib/typed-racket/core.rkt +++ b/typed-racket-lib/typed-racket/core.rkt @@ -48,10 +48,12 @@ (and (attribute opt?) (syntax-e (attribute opt?))))] [with-refinements? (and (or (attribute refinement-reasoning?) (with-refinements?)) - (when (not (eq? te-mode deep)) + (unless (eq? te-mode deep) (raise-arguments-error - (string->symbol (format "typed/racket/~a" (keyword->string (syntax-e te-attr)))) - "#:with-refinements unsupported")))]) + (string->symbol (format "typed/racket/~a" + (keyword->string + (syntax-e te-attr)))) + "#:with-refinements unsupported")))]) (tc-module/full te-mode stx pmb-form (λ (new-mod pre-before-code pre-after-code) (define ctc-cache (make-hash)) diff --git a/typed-racket-lib/typed-racket/tc-setup.rkt b/typed-racket-lib/typed-racket/tc-setup.rkt index 197f2ea2d..6f2b123f1 100644 --- a/typed-racket-lib/typed-racket/tc-setup.rkt +++ b/typed-racket-lib/typed-racket/tc-setup.rkt @@ -36,15 +36,15 @@ ;; types are enforced (not no-check etc.), ;; PLT_TR_NO_OPTIMIZE is not set, and the ;; current code inspector has sufficient privileges - (if (and (optimize?) - (memq (current-type-enforcement-mode) (list deep shallow)) - (not (getenv "PLT_TR_NO_OPTIMIZE")) - (authorized-code-inspector?)) - (begin - (do-time "Starting optimizer") - (begin0 (stx-map optimize-top body) - (do-time "Optimized"))) - body)) + (cond + [(and (optimize?) + (memq (current-type-enforcement-mode) (list deep shallow)) + (not (getenv "PLT_TR_NO_OPTIMIZE")) + (authorized-code-inspector?)) + (do-time "Starting optimizer") + (begin0 (stx-map optimize-top body) + (do-time "Optimized"))] + [else body])) (define (maybe-shallow-rewrite body-stx ctc-cache) (case (current-type-enforcement-mode) 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 b1d016b23..8b81d8e48 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -213,7 +213,7 @@ opt:opt-lambda^) ;; it's only an interesting opt-lambda expansion if the number ;; of optional arguments is greater than zero - #:when (> (cadr (attribute opt.value)) 0) + #:when (positive? (cadr (attribute opt.value))) #:do [(register/method #'meth-name)] #:with props-core (let* ([prop-val (attribute opt.value)] @@ -290,12 +290,10 @@ [(tc-result1: type) (resolve type)] [_ #f])) (match expected-type - [(? Class? class-type) - (ret (parse-and-check form class-type))] + [(? Class? class-type) (ret (parse-and-check form class-type))] [(Poly-names: ns body-type) - (match (check-class form (ret body-type)) - [(tc-result1: t f o) - (ret (make-Poly ns t) f o)])] + (match-define (tc-result1: t f o) (check-class form (ret body-type))) + (ret (make-Poly ns t) f o)] [_ (ret (parse-and-check form #f))])) ;; Syntax Option -> Type @@ -714,18 +712,12 @@ (localize local-augment-table 'augment-internals) (localize local-inner-table '(pubment-internals augment-internals)) (localize local-init-table 'only-init-internals))) - (define-values (localized-field-get-names - localized-field-set-names - localized-private-field-get-names - localized-private-field-set-names - localized-inherit-field-get-names - localized-inherit-field-set-names) - (values (map car localized-field-pairs) - (map cadr localized-field-pairs) - (map car localized-private-field-pairs) - (map cadr localized-private-field-pairs) - (map car localized-inherit-field-pairs) - (map cadr localized-inherit-field-pairs))) + (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)) + (define localized-private-field-set-names (map cadr localized-private-field-pairs)) + (define localized-inherit-field-get-names (map car localized-inherit-field-pairs)) + (define localized-inherit-field-set-names (map cadr localized-inherit-field-pairs)) ;; construct the types for method accessors (define (make-method-types method-names type-map @@ -1317,14 +1309,14 @@ ;; Check that by-name inits are valid for the superclass (define (check-by-name init-stxs super-inits) (match-define (super-init-stxs _ by-name) init-stxs) - (for ([(name _) (in-dict by-name)]) - (unless (dict-ref super-inits name #f) - (tc-error/fields - "invalid `super-new' or `super-instantiate'" - #:more "init argument not accepted by superclass" - "init name" name - #:stx #`#,name - #:delayed? #t)))) + (for ([(name _) (in-dict by-name)] + #:unless (dict-ref super-inits name #f)) + (tc-error/fields "invalid `super-new' or `super-instantiate'" + #:more "init argument not accepted by superclass" + "init name" + name + #:stx #`#,name + #:delayed? #t))) ;; check-super-new : super-init-stxs Dict Type -> Void ;; Check if the super-new call is well-typed @@ -1332,10 +1324,10 @@ (match-define (super-init-stxs provided-pos-args provided-inits) super-new) (define pos-init-diff (- (length provided-pos-args) (length super-inits))) - (cond [(and (> pos-init-diff 0) (not init-rest)) + (cond [(and (positive? pos-init-diff) (not init-rest)) ;; errror case that's caught above, do nothing (void)] - [(> pos-init-diff 0) + [(positive? pos-init-diff) (define-values (pos-args for-init-rest) (split-at provided-pos-args (length super-inits))) (for ([pos-arg pos-args] @@ -1361,12 +1353,9 @@ ;; the pubment types as default augment types if an augment type ;; was not already provided (define (setup-pubment-defaults pubment-names annotations augment-annotations) - (for ([name pubment-names]) - (when (and (not (hash-has-key? augment-annotations name)) - (hash-has-key? annotations name)) - (hash-set! augment-annotations - name - (dict-ref annotations name))))) + (for ([name pubment-names] + #:when (and (not (hash-has-key? augment-annotations name)) (hash-has-key? annotations name))) + (hash-set! augment-annotations name (dict-ref annotations name)))) ;; infer-self-type : Dict RowVar Class Dict Dict ;; Set Dict @@ -1430,13 +1419,12 @@ [(Class: _ inits fields publics augments init-rest) (values inits fields publics augments init-rest)] [_ (values #f #f #f #f #f)])) - (define-values (inits fields publics pubments overrides init-rest-name) - (values (hash-ref parse-info 'init-internals) - (hash-ref parse-info 'field-internals) - (hash-ref parse-info 'public-internals) - (hash-ref parse-info 'pubment-internals) - (hash-ref parse-info 'override-internals) - (hash-ref parse-info 'init-rest-name))) + (define inits (hash-ref parse-info 'init-internals)) + (define fields (hash-ref parse-info 'field-internals)) + (define publics (hash-ref parse-info 'public-internals)) + (define pubments (hash-ref parse-info 'pubment-internals)) + (define overrides (hash-ref parse-info 'override-internals)) + (define init-rest-name (hash-ref parse-info 'init-rest-name)) (define init-types (make-inits inits super-inits expected-inits)) (define field-types (make-type-dict fields super-fields expected-fields Univ)) 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 4dd83fe35..77e6ea206 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt @@ -379,25 +379,34 @@ msg-vars (Fun: (list (Arrow: msg-doms msg-rests kws msg-rngs) ...)) _)) - (let ([fcn-string (if name - (format "function with keywords ~a" (syntax->datum name)) - "function with keywords")]) - (if (and (andmap null? msg-doms) - (null? argtypes)) - (tc-error/expr (string-append - "Could not infer types for applying polymorphic " + (define fcn-string + (if name + (format "function with keywords ~a" (syntax->datum name)) + "function with keywords")) + (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") + "")))))])) ;; name->function-str : (Option Identifier) -> String ;; Produce a function name string for error messages diff --git a/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt b/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt index e440fab57..ff780b7ca 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt @@ -42,17 +42,17 @@ [else (define-values (props atoms^) (combine-props ps (env-props env))) - (define atoms (if atoms^ + (define atoms (and atoms^ ;; fix the order of paths to the same object. ;; move objects with fewer path elements forward. - (sort atoms^ (lambda (x y) - (match* (x y) - [((TypeProp: (Path: pes1 (? identifier? var1)) _) - (TypeProp: (Path: pes2 (? identifier? var2)) _)) - #:when (equal? var1 var2) - (and (< (length pes1) (length pes2)))] - [(_ _) #f]))) - atoms^)) + (sort atoms^ + (lambda (x y) + (match* (x y) + [((TypeProp: (Path: pes1 (? identifier? var1)) _) + (TypeProp: (Path: pes2 (? identifier? var2)) _)) + #:when (equal? var1 var2) + (and (< (length pes1) (length pes2)))] + [(_ _) #f]))))) (cond [props (let loop ([todo atoms] @@ -82,35 +82,36 @@ (env-set-obj-type Γ obj new-t*))]))) (match p [(TypeProp: (and obj (Path: pes (? identifier? x))) pt) - (let ([t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))]) - (define new-t (update t pt #t pes)) - (cond - [(Bottom? new-t) #f] - [(equal? t new-t) - (cond - [(ormap uninterpreted-PE? pes) - (update-obj-pos-type new Γ obj pt)] - [else (loop ps (cons p atoms) negs new Γ)])] - [else - ;; it's a new type! check if there are any logical propositions that can - ;; be extracted from new-t - (define-values (new-t* new-props) (extract-props (-id-path x) new-t)) - (cond - ;; if the path contains an uninterpreted path element, - ;; we need to update the object's type in addition to - ;; the identifier's type - [(ormap uninterpreted-PE? pes) - (update-obj-pos-type (append new-props new) - (env-set-id-type Γ x new-t*) - obj - pt)] - [(path-type pes new-t*) => (lambda (pt) - (loop ps - (cons (-is-type obj pt) atoms) - negs - (append new-props new) - (env-set-id-type Γ x new-t*)))] - [else #f])]))] + (define t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))) + (define new-t (update t pt #t pes)) + (cond + [(Bottom? new-t) #f] + [(equal? t new-t) + (cond + [(ormap uninterpreted-PE? pes) (update-obj-pos-type new Γ obj pt)] + [else (loop ps (cons p atoms) negs new Γ)])] + [else + ;; it's a new type! check if there are any logical propositions that can + ;; be extracted from new-t + (define-values (new-t* new-props) (extract-props (-id-path x) new-t)) + (cond + ;; if the path contains an uninterpreted path element, + ;; we need to update the object's type in addition to + ;; the identifier's type + [(ormap uninterpreted-PE? pes) + (update-obj-pos-type (append new-props new) + (env-set-id-type Γ x new-t*) + obj + pt)] + [(path-type pes new-t*) + => + (lambda (pt) + (loop ps + (cons (-is-type obj pt) atoms) + negs + (append new-props new) + (env-set-id-type Γ x new-t*)))] + [else #f])])] [(TypeProp: obj pt) (update-obj-pos-type new Γ obj pt)] ;; process negative info _after_ positive info so we don't miss anything! @@ -145,33 +146,32 @@ (env-set-obj-type Γ obj new-t*))]))) (match p [(NotTypeProp: (and obj (Path: pes (? identifier? x))) pt) - (let ([t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))]) - (define new-t (update t pt #f pes)) - (cond - [(Bottom? new-t) #f] - [(equal? t new-t) - (cond - [(ormap uninterpreted-PE? pes) - (update-obj-neg-type new Γ obj pt)] - [else (loop negs (cons p atoms) new Γ)])] - [else - ;; it's a new type! check if there are any logical propositions that can - ;; be extracted from new-t - (define-values (new-t* new-props) (extract-props (-id-path x) new-t)) - (cond - ;; if the path contains an uninterpreted path element, - ;; we need to update the object's type in addition to - ;; the identifier's type - [(ormap uninterpreted-PE? pes) - (update-obj-neg-type (append new-props new) - (env-set-id-type Γ x new-t*) - obj - pt)] - [else - (loop negs - (cons p atoms) - (append new-props new) - (env-set-id-type Γ x new-t*))])]))] + (define t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))) + (define new-t (update t pt #f pes)) + (cond + [(Bottom? new-t) #f] + [(equal? t new-t) + (cond + [(ormap uninterpreted-PE? pes) (update-obj-neg-type new Γ obj pt)] + [else (loop negs (cons p atoms) new Γ)])] + [else + ;; it's a new type! check if there are any logical propositions that can + ;; be extracted from new-t + (define-values (new-t* new-props) (extract-props (-id-path x) new-t)) + (cond + ;; if the path contains an uninterpreted path element, + ;; we need to update the object's type in addition to + ;; the identifier's type + [(ormap uninterpreted-PE? pes) + (update-obj-neg-type (append new-props new) + (env-set-id-type Γ x new-t*) + obj + pt)] + [else + (loop negs + (cons p atoms) + (append new-props new) + (env-set-id-type Γ x new-t*))])])] [(NotTypeProp: obj pt) (update-obj-neg-type new Γ obj pt)])] [_ diff --git a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 89ef796d4..013763f7c 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -256,12 +256,12 @@ non-bindings expected #:before-check-body - (λ () (begin (for ([expr (in-list remaining-exprs)] - [results (in-list given-rhs-types)]) - (match results - [(list (tc-result: ts fs os) ...) - (tc-expr/check expr (ret ts fs os))])) - (check-thunk))))]))))) + (λ () + (for ([expr (in-list remaining-exprs)] + [results (in-list given-rhs-types)]) + (match-define (list (tc-result: ts fs os) ...) results) + (tc-expr/check expr (ret ts fs os))) + (check-thunk)))]))))) ;; An lr-clause is a ;; (lr-clause (Listof Identifier) Syntax) @@ -284,8 +284,8 @@ (if (null? names) (values (cons clause non-binding) other-clauses) (values non-binding (cons clause other-clauses))))) - (define-values (non-binding other-clauses) - (values (reverse *non-binding) (reverse *other-clauses))) + (define non-binding (reverse *non-binding)) + (define other-clauses (reverse *other-clauses)) ;; Set up vertices for Tarjan's algorithm, where each letrec-values ;; clause is a vertex but mapped in the table for each of the clause names diff --git a/typed-racket-lib/typed-racket/typed-reader.rkt b/typed-racket-lib/typed-racket/typed-reader.rkt index 7cb6e9340..a9f157bcc 100644 --- a/typed-racket-lib/typed-racket/typed-reader.rkt +++ b/typed-racket-lib/typed-racket/typed-reader.rkt @@ -8,73 +8,82 @@ (define (skip-whitespace port) ;; Skips whitespace characters, sensitive to the current ;; readtable's definition of whitespace - (let ([ch (peek-char port)]) - (unless (eof-object? ch) - ;; Consult current readtable: - (let-values ([(like-ch/sym proc dispatch-proc) - (readtable-mapping (current-readtable) ch)]) - ;; If like-ch/sym is whitespace, then ch is whitespace - (when (and (char? like-ch/sym) - (char-whitespace? like-ch/sym)) - (read-char port) - (skip-whitespace port)))))) + (define ch (peek-char port)) + (unless (eof-object? ch) + ;; Consult current readtable: + (define-values (like-ch/sym proc dispatch-proc) (readtable-mapping (current-readtable) ch)) + ;; If like-ch/sym is whitespace, then ch is whitespace + (when (and (char? like-ch/sym) (char-whitespace? like-ch/sym)) + (read-char port) + (skip-whitespace port)))) (define (skip-comments read-one port src) ;; Recursive read, but skip comments and detect EOF (let loop () - (let ([v (read-one)]) - (cond - [(special-comment? v) (loop)] - [(eof-object? v) - (let-values ([(l c p) (port-next-location port)]) - (raise-read-eof-error "unexpected EOF in type annotation" src l c p 1))] - [else v])))) + (define v (read-one)) + (cond + [(special-comment? v) (loop)] + [(eof-object? v) + (define-values (l c p) (port-next-location port)) + (raise-read-eof-error "unexpected EOF in type annotation" src l c p 1)] + [else v]))) (define (parse port read-one src) (skip-whitespace port) - (let ([name (read-one)]) - (begin0 - (begin (skip-whitespace port) - (let ([next (read-one)]) - (case (syntax-e next) - ;; type annotation - [(:) (skip-whitespace port) - (type-label-property name (syntax->datum (read-one)))] - [(::) (skip-whitespace port) - (datum->syntax name `(ann ,name : ,(read-one)))] - [(@) (let ([elems (let loop ([es '()]) - (skip-whitespace port) - (if (equal? #\} (peek-char port)) - (reverse es) - (loop (cons (read-one) es))))]) - (datum->syntax name `(inst ,name : ,@elems)))] - ;; arbitrary property annotation - [(PROP) (skip-whitespace port) - (let* ([prop-name (syntax-e (read-one))]) - (skip-whitespace port) - (syntax-property name prop-name (read-one)))] - ;; otherwise error - [else - (let-values ([(l c p) (port-next-location port)]) - (raise-read-error (format "typed expression ~a must be followed by :, ::, or @" - (syntax->datum name)) src l c p 1))]))) - (skip-whitespace port) - (let ([c (read-char port)]) - (unless (equal? #\} c) - (let-values ([(l c p) (port-next-location port)]) - (raise-read-error (format "typed expression ~a not properly terminated" (syntax->datum name)) src l c p 1))))))) + (define name (read-one)) + (begin0 (begin + (skip-whitespace port) + (let ([next (read-one)]) + (case (syntax-e next) + ;; type annotation + [(:) + (skip-whitespace port) + (type-label-property name (syntax->datum (read-one)))] + [(::) + (skip-whitespace port) + (datum->syntax name `(ann ,name : ,(read-one)))] + [(@) + (let ([elems (let loop ([es '()]) + (skip-whitespace port) + (if (equal? #\} (peek-char port)) + (reverse es) + (loop (cons (read-one) es))))]) + (datum->syntax name `(inst ,name : ,@elems)))] + ;; arbitrary property annotation + [(PROP) + (skip-whitespace port) + (let* ([prop-name (syntax-e (read-one))]) + (skip-whitespace port) + (syntax-property name prop-name (read-one)))] + ;; otherwise error + [else + (let-values ([(l c p) (port-next-location port)]) + (raise-read-error (format "typed expression ~a must be followed by :, ::, or @" + (syntax->datum name)) + src + l + c + p + 1))]))) + (skip-whitespace port) + (let ([c (read-char port)]) + (unless (equal? #\} c) + (let-values ([(l c p) (port-next-location port)]) + (raise-read-error (format "typed expression ~a not properly terminated" + (syntax->datum name)) + src + l + c + p + 1)))))) (define parse-id-type - (case-lambda - [(ch port src line col pos) - ;; `read-syntax' mode - (datum->syntax - #f - (parse port - (lambda () (read-syntax src port )) - src) - (let-values ([(l c p) (port-next-location port)]) - (list src line col pos (and pos (- p pos)))))])) + (λ (ch port src line col pos) + ;; `read-syntax' mode + (datum->syntax #f + (parse port (lambda () (read-syntax src port)) src) + (let-values ([(l c p) (port-next-location port)]) + (list src line col pos (and pos (- p pos))))))) (define (readtable) ; don't install the reader macro if a dispatch macro on the open brace has already been installed 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))) 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 "#<