From c893502857d2484540e8ba7bde72e101d23fb22c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Sep 2011 16:12:44 -0400 Subject: [PATCH] Forge identifiers instead of dumpster-diving. --- .../base-env/base-special-env.rkt | 142 ++++++------------ 1 file changed, 43 insertions(+), 99 deletions(-) diff --git a/collects/typed-racket/base-env/base-special-env.rkt b/collects/typed-racket/base-env/base-special-env.rkt index cc2e1e30c8..9b3e034fea 100644 --- a/collects/typed-racket/base-env/base-special-env.rkt +++ b/collects/typed-racket/base-env/base-special-env.rkt @@ -7,7 +7,7 @@ string-constants/string-constant racket/private/kw racket/file racket/port syntax/parse racket/path (for-template (only-in racket/private/kw kw-expander-proc kw-expander-impl) - racket/base racket/promise racket/file racket/port racket/path string-constants/string-constant) + racket/base racket/file racket/port racket/path) (utils tc-utils) (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) @@ -20,36 +20,39 @@ [(_ initialize-env [id-expr ty] ... #:middle [id-expr* ty*] ...) #`(begin (define initial-env (make-env [id-expr (λ () ty)] ... )) - (do-time "finished local-expand types") + (do-time "finished special types") (define initial-env* (make-env [id-expr* (λ () ty*)] ...)) (define (initialize-env) (initialize-type-env initial-env) (initialize-type-env initial-env*)) (provide initialize-env))])) +(define (make-template-identifier what where) + (let ([name (module-path-index-resolve (module-path-index-join where #f))]) + (parameterize ([current-namespace (make-empty-namespace)]) + (namespace-attach-module (current-namespace) ''#%kernel) + (parameterize ([current-module-declare-name name]) + (eval `(,#'module any '#%kernel + (#%provide ,what) + (define-values (,what) #f)))) + (namespace-require `(for-template ,name)) + (namespace-syntax-introduce (datum->syntax #f what))))) + + (define-initial-env initialize-special ;; make-promise - [(syntax-parse (local-expand #'(delay 3) 'expression null) - #:context #'make-promise - [(_ mp . _) #'mp]) + [(make-template-identifier 'delay 'racket/private/promise) (-poly (a) (-> (-> a) (-Promise a)))] ;; language - [(syntax-parse (local-expand #'(this-language) 'expression null) - #:context #'language - [lang #'lang]) + [(make-template-identifier 'language 'string-constants/string-constant) -Symbol] ;; qq-append - [(syntax-parse (local-expand #'`(,@'() 1) 'expression null) - #:context #'qq-append - [(_ qqa . _) #'qqa]) - (-poly (a b) - (cl->* - (-> (-lst a) (-val '()) (-lst a)) - (-> (-lst a) (-lst b) (-lst (*Un a b)))))] + [(make-template-identifier 'qq-append 'racket/private/qq-and-or) + (-poly (a b) + (cl->* + (-> (-lst a) (-val '()) (-lst a)) + (-> (-lst a) (-lst b) (-lst (*Un a b)))))] ;; make-sequence - [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) - #:context #'make-sequence - #:literals (let-values quote) - [(let-values ([_ (m-s '(_) '())]) . _) #'m-s]) + [(make-template-identifier 'make-sequence 'racket/private/for) (-poly (a b) (let ([seq-vals (lambda (a) @@ -64,9 +67,7 @@ (-> Univ (-seq a) (seq-vals (list a))) (-> Univ (-seq a b) (seq-vals (list a b))))))] ;; in-range - [(syntax-parse (local-expand #'(in-range 1) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-range 'racket/private/for) (cl->* (-PosFixnum -Fixnum [-Nat] . ->opt . (-seq -PosFixnum)) (-NonNegFixnum [-Fixnum -Nat] . ->opt . (-seq -NonNegFixnum)) (-Fixnum [-Fixnum -Int] . ->opt . (-seq -Fixnum)) @@ -74,118 +75,61 @@ (-Nat [-Int -Nat] . ->opt . (-seq -Nat)) (-Int [-Int -Int] . ->opt . (-seq -Int)))] ;; in-naturals - [(syntax-parse (local-expand #'(in-naturals) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-naturals 'racket/private/for) (cl->* (-> -PosInt (-seq -PosInt)) (-> -Int (-seq -Nat)))] ;; in-list - [(syntax-parse (local-expand #'(in-list '(1 2 3)) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-list 'racket/private/for) (-poly (a) (-> (-lst a) (-seq a)))] ;; in-vector - [(syntax-parse (local-expand #'(in-vector (vector 1 2 3)) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-vector 'racket/private/for) (-poly (a) (->opt (-vec a) [-Int (-opt -Int) -Int] (-seq a)))] ;; in-string - [(syntax-parse (local-expand #'(in-string "abc") 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-string 'racket/private/for) (->opt -String [-Int (-opt -Int) -Int] (-seq -Char))] ;; in-bytes - [(syntax-parse (local-expand #'(in-bytes #"abc") 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-bytes 'racket/private/for) (->opt -Bytes [-Int (-opt -Int) -Int] (-seq -Byte))] ;; in-hash and friends - [(syntax-parse (local-expand #'(in-hash #hash((1 . 2))) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-hash 'racket/private/for) (-poly (a b) (-> (-HT a b) (-seq a b)))] - [(syntax-parse (local-expand #'(in-hash-keys #hash((1 . 2))) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-hash-keys 'racket/private/for) (-poly (a b) (-> (-HT a b) (-seq a)))] - [(syntax-parse (local-expand #'(in-hash-values #hash((1 . 2))) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-hash-values 'racket/private/for) (-poly (a b) (-> (-HT a b) (-seq b)))] ;; in-port - [(syntax-parse (local-expand #'(in-port) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-port 'racket/private/for) (->opt [(-> -Input-Port Univ) -Input-Port] (-seq Univ))] ;; in-input-port-bytes - [(syntax-parse (local-expand #'(in-input-port-bytes (open-input-bytes #"abc")) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-input-port-bytes 'racket/private/for) (-> -Input-Port (-seq -Byte))] ;; in-input-port-chars - [(syntax-parse (local-expand #'(in-input-port-chars (open-input-string "abc")) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-input-port-chars 'racket/private/for) (-> -Input-Port (-seq -Char))] ;; in-lines - [(syntax-parse (local-expand #'(in-lines) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-lines 'racket/private/for) (->opt [-Input-Port -Symbol] (-seq -String))] ;; in-bytes-lines - [(syntax-parse (local-expand #'(in-bytes-lines) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-bytes-lines 'racket/private/for) (->opt [-Input-Port -Symbol] (-seq -Bytes))] ;; check-in-bytes-lines - [(syntax-parse (local-expand #'(for ([i (in-bytes-lines 0)]) i) - 'expression #f) - #:literals (let-values let) - [(let-values ((_ (let _ (c . _) . _)) - . _) - . _) - #'c]) + [(make-template-identifier 'check-in-bytes-lines 'racket/private/for) (-> Univ Univ Univ)] ;; check-in-lines - [(syntax-parse (local-expand #'(for ([i (in-lines 0)]) i) - 'expression #f) - #:literals (let-values #%app let) - [(let-values ((_ (let _ (c . _) . _)) - . _) - . _) - #'c]) + [(make-template-identifier 'check-in-lines 'racket/private/for) (-> Univ Univ Univ)] ;; check-in-port - [(syntax-parse (local-expand #'(for ([i (in-port 0)]) i) - 'expression #f) - #:literals (let-values #%app let) - [(let-values ((_ (let _ (c . _) . _)) - . _) - . _) - #'c]) + [(make-template-identifier 'check-in-port 'racket/private/for) (-> Univ Univ Univ)] ;; from the expansion of `with-syntax' - [(syntax-parse (local-expand #'(with-syntax ([x 1]) #'(x)) 'expression null) - #:literals (let-values #%plain-app #%plain-lambda if letrec-syntaxes+values) - [(let-values _ - (let-values _ - (let-values _ - (if _ - (let-values _ (letrec-syntaxes+values _ _ (#%plain-app (#%plain-lambda _ (#%plain-app apply-pattern-substitute _ _ _)) _))) - _)))) - #'apply-pattern-substitute]) + [(make-template-identifier 'apply-pattern-substitute 'racket/private/stxcase) (->* (list (-Syntax Univ) Univ) Univ Any-Syntax)] - - [(syntax-parse (local-expand #'(with-syntax ([x 1]) #'(x)) 'expression null) - #:literals (let-values #%plain-app #%plain-lambda if letrec-syntaxes+values) - [(let-values _ (let-values _ - (let-values _ (if _ _ (let-values _ - (if _ (let-values _ (letrec-syntaxes+values _ _ (#%plain-app with-syntax-fail _))) _)))))) - #'with-syntax-fail]) + ;; same + [(make-template-identifier 'with-syntax-fail 'racket/private/with-stx) (-> (-Syntax Univ) (Un))] - [(local-expand #'make-temporary-file 'expression #f) + [(make-template-identifier 'make-temporary-file/proc 'racket/file) (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] ;; below here: keyword-argument functions from the base environment