From a9e8324a388e9cb3835965614fb403d91b4f679a Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 15 Dec 2013 09:45:22 -0800 Subject: [PATCH] Replace init argument with direct calls to do-standard-inits. --- .../typed-racket/base-env/top-interaction.rkt | 16 +++++++--------- .../typed-racket-lib/typed-racket/core.rkt | 16 ++++++++++------ .../typed-racket/private/with-types.rkt | 11 ++++++----- .../typed-racket-lib/typed-racket/tc-setup.rkt | 7 +++++-- .../typed-racket/typed-racket.rkt | 2 +- .../unit-tests/special-env-typecheck-tests.rkt | 2 +- 6 files changed, 30 insertions(+), 24 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt index 704b268f57..97dded8df1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/top-interaction.rkt @@ -50,7 +50,7 @@ (provide :type-impl :print-type-impl :query-type/args-impl :query-type/result-impl) - (define (:type-impl stx init) + (define (:type-impl stx) (syntax-parse stx [(_ (~optional (~and #:verbose verbose-kw)) ty:expr) (parameterize ([current-print-type-fuel @@ -61,7 +61,6 @@ [current-type-names (if (attribute verbose-kw) '() (current-type-names))] [current-print-unexpanded (box '())]) - (init) (define type (format "~a" (parse-type #'ty))) (define unexpanded (remove-duplicates (unbox (current-print-unexpanded)))) @@ -75,10 +74,10 @@ ;; TODO what should be done with stx ;; Prints the _entire_ type. May be quite large. - (define (:print-type-impl stx init) + (define (:print-type-impl stx) (syntax-parse stx [(_ e) - (tc-setup stx #'e 'top-level init tc-toplevel-form + (tc-setup stx #'e 'top-level tc-toplevel-form (lambda (expanded before type) #`(display #,(parameterize ([print-multi-line-case-> #t]) @@ -90,7 +89,7 @@ (raise-syntax-error #f "must be applied to exactly one argument" #'form)])) ;; given a function and input types, display the result type - (define (:query-type/args-impl stx init) + (define (:query-type/args-impl stx) (syntax-parse stx [(_ op arg-type ...) (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) @@ -99,7 +98,7 @@ #`(lambda #,(stx-map type-label-property #'(dummy-arg ...) #'(arg-type ...)) (op dummy-arg ...)) - 'top-level init tc-toplevel-form + 'top-level tc-toplevel-form (lambda (expanded before type) #`(display #,(format "~a\n" @@ -109,12 +108,11 @@ (raise-syntax-error #f "must be applied to at least one argument" #'form)])) ;; given a function and a desired return type, fill in the blanks - (define (:query-type/result-impl stx init) + (define (:query-type/result-impl stx) (syntax-parse stx [(_ op desired-type) - (init) (let ([expected (parse-type #'desired-type)]) - (tc-setup stx #'op 'top-level init tc-toplevel-form + (tc-setup stx #'op 'top-level tc-toplevel-form (lambda (expanded before type) (match type [(tc-result1: (and t (Function: _)) f o) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index 9c16e09b04..405ed62348 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -11,11 +11,12 @@ (rep type-rep) (for-template (base-env top-interaction)) (utils utils tc-utils arm) + "standard-inits.rkt" "tc-setup.rkt") (provide mb-core ti-core wt-core) -(define (mb-core stx init) +(define (mb-core stx) (syntax-parse stx [(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility (~and #:no-optimize (~bind [opt? #'#f])))) @@ -24,7 +25,7 @@ (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?)) (and (attribute opt?) (syntax-e (attribute opt?))))]) (tc-setup - stx pmb-form 'module-begin init tc-module + stx pmb-form 'module-begin tc-module (λ (new-mod before-code after-code) (with-syntax* (;; pmb = #%plain-module-begin @@ -47,18 +48,21 @@ (define did-I-suggest-:print-type-already? #f) (define :print-type-message " ... [Use (:print-type ) to see more.]") -(define (ti-core stx init) +(define (ti-core stx ) (current-type-names (init-current-type-names)) (syntax-parse stx #:literal-sets (kernel-literals) [(_ . (module . rest)) #'(module . rest)] [(_ . (~and form ((~var command (static interactive-command? #f)) . _))) - ((interactive-command-procedure (attribute command.value)) #'form init)] + (do-standard-inits) + ((interactive-command-procedure (attribute command.value)) #'form)] [(_ . form) - (init) + ;; TODO(endobson): Remove the call to do-standard-inits when it is no longer necessary + ;; Cast at the top-level still needs this for some reason + (do-standard-inits) (tc-setup - stx #'form 'top-level void tc-toplevel-form + stx #'form 'top-level tc-toplevel-form (λ (body2 before type) (with-syntax* ([(optimized-body . _) (maybe-optimize #`(#,body2))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt index 7df49b583e..3db30f7a76 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt @@ -8,6 +8,7 @@ (prefix-in c: (combine-in racket/contract/region racket/contract/base))) "../base-env/extra-procs.rkt" (except-in "../base-env/prims.rkt" with-handlers λ lambda define) "../tc-setup.rkt" + "../standard-inits.rkt" syntax/parse racket/match unstable/sequence "../base-env/base-types-extra.rkt" (path-up "env/type-name-env.rkt" @@ -23,14 +24,14 @@ (provide wt-core) -(define (with-type-helper stx init body fvids fvtys exids extys resty expr? ctx) +(define (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) (define old-context (unbox typed-context?)) (unless (not old-context) (tc-error/stx stx "with-type cannot be used in a typed module.")) (define (no-contract t [stx stx]) (type->contract-fail t stx)) (set-box! typed-context? #t) - (init) + (do-standard-inits) (define fv-types (for/list ([t (in-syntax fvtys)]) (parse-type t))) (define fv-cnts (for/list ([t (in-list fv-types)] @@ -113,7 +114,7 @@ ([ex-id ex-cnt] ...) (define-values (ex-id ...) body))))))) -(define (wt-core stx init) +(define (wt-core stx) (define-syntax-class typed-id #:description "[id type]" [pattern (id ty)]) @@ -135,7 +136,7 @@ [pattern (~seq #:result ty:expr)]) (syntax-parse stx [(_ :typed-ids fv:free-vars . body) - (with-type-helper stx init #'body #'(fv.id ...) #'(fv.ty ...) #'(id ...) #'(ty ...) #f #f (syntax-local-context))] + (with-type-helper stx #'body #'(fv.id ...) #'(fv.ty ...) #'(id ...) #'(ty ...) #f #f (syntax-local-context))] [(_ :result-ty fv:free-vars . body) - (with-type-helper stx init #'body #'(fv.id ...) #'(fv.ty ...) #'() #'() #'ty #t (syntax-local-context))])) + (with-type-helper stx #'body #'(fv.id ...) #'(fv.ty ...) #'() #'() #'ty #t (syntax-local-context))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt index 47b9364e39..75dc6af337 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt @@ -5,6 +5,7 @@ racket/pretty racket/promise racket/lazy-require (env type-name-env type-alias-env mvar-env) (utils tc-utils disarm mutated-vars) + "standard-inits.rkt" (for-syntax racket/base) (for-template racket/base)) (lazy-require [typed-racket/optimizer/optimizer (optimize-top)]) @@ -38,7 +39,7 @@ (define-logger online-check-syntax) -(define (tc-setup orig-stx stx expand-ctxt init checker f) +(define (tc-setup orig-stx stx expand-ctxt checker f) (set-box! typed-context? #t) ;(start-timing (syntax-property stx 'enclosing-module-name)) (with-handlers @@ -64,7 +65,9 @@ 'info "TR's expanded syntax objects; this message is ignored" (cdr exprs)))) - (init) + ;; We do standard inits here because it is costly (~250 msec), and we want + ;; expansion errors to happen with out paying that cost + (do-standard-inits) (do-time "Initialized Envs") (find-mutated-vars fully-expanded-stx mvar-env) (parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt index e2161b8c01..36a9554780 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt @@ -24,7 +24,7 @@ (define-syntax (name stx) (do-time (format "Calling ~a driver" 'name)) (do-time (format "Loaded core ~a" 'sym)) - (begin0 (sym stx do-standard-inits) + (begin0 (sym stx) (do-time "Finished, returning to Racket"))) ...)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt index 0618e0802e..2ae1384b29 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt @@ -19,7 +19,7 @@ (utils tc-utils) (typecheck typechecker)) typed-racket/base-env/prims typed-racket/base-env/base-types - (only-in typed-racket/typed-racket do-standard-inits)) + (for-syntax typed-racket/standard-inits)) (begin-for-syntax (do-standard-inits))