suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Forge identifiers instead of dumpster-diving.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-09-02 16:12:44 -04:00
parent 3cc51f20ac
commit c893502857
1 changed files with 43 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
collects/typed-racket/base-env/base-special-env.rkt
View File

@ -7,7 +7,7 @@
string-constants/string-constant string-constants/string-constant
racket/private/kw racket/file racket/port syntax/parse racket/path racket/private/kw racket/file racket/port syntax/parse racket/path
(for-template (only-in racket/private/kw kw-expander-proc kw-expander-impl) (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) (utils tc-utils)
(env init-envs) (env init-envs)
(except-in (rep filter-rep object-rep type-rep) make-arr) (except-in (rep filter-rep object-rep type-rep) make-arr)
@ -20,36 +20,39 @@
[(_ initialize-env [id-expr ty] ... #:middle [id-expr* ty*] ...) [(_ initialize-env [id-expr ty] ... #:middle [id-expr* ty*] ...)
#`(begin #`(begin
(define initial-env (make-env [id-expr (λ () ty)] ... )) (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 initial-env* (make-env [id-expr* (λ () ty*)] ...))
(define (initialize-env) (initialize-type-env initial-env) (initialize-type-env initial-env*)) (define (initialize-env) (initialize-type-env initial-env) (initialize-type-env initial-env*))
(provide initialize-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 (define-initial-env initialize-special
;; make-promise ;; make-promise
[(syntax-parse (local-expand #'(delay 3) 'expression null) [(make-template-identifier 'delay 'racket/private/promise)
#:context #'make-promise
[(_ mp . _) #'mp])
(-poly (a) (-> (-> a) (-Promise a)))] (-poly (a) (-> (-> a) (-Promise a)))]
;; language ;; language
[(syntax-parse (local-expand #'(this-language) 'expression null) [(make-template-identifier 'language 'string-constants/string-constant)
#:context #'language
[lang #'lang])
-Symbol] -Symbol]
;; qq-append ;; qq-append
[(syntax-parse (local-expand #'`(,@'() 1) 'expression null) [(make-template-identifier 'qq-append 'racket/private/qq-and-or)
#:context #'qq-append (-poly (a b)
[(_ qqa . _) #'qqa]) (cl->*
(-poly (a b) (-> (-lst a) (-val '()) (-lst a))
(cl->* (-> (-lst a) (-lst b) (-lst (*Un a b)))))]
(-> (-lst a) (-val '()) (-lst a))
(-> (-lst a) (-lst b) (-lst (*Un a b)))))]
;; make-sequence ;; make-sequence
[(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) [(make-template-identifier 'make-sequence 'racket/private/for)
#:context #'make-sequence
#:literals (let-values quote)
[(let-values ([_ (m-s '(_) '())]) . _) #'m-s])
(-poly (a b) (-poly (a b)
(let ([seq-vals (let ([seq-vals
(lambda (a) (lambda (a)
@ -64,9 +67,7 @@
(-> Univ (-seq a) (seq-vals (list a))) (-> Univ (-seq a) (seq-vals (list a)))
(-> Univ (-seq a b) (seq-vals (list a b))))))] (-> Univ (-seq a b) (seq-vals (list a b))))))]
;; in-range ;; in-range
[(syntax-parse (local-expand #'(in-range 1) 'expression #f) [(make-template-identifier 'in-range 'racket/private/for)
[(i-n _ ...)
#'i-n])
(cl->* (-PosFixnum -Fixnum [-Nat] . ->opt . (-seq -PosFixnum)) (cl->* (-PosFixnum -Fixnum [-Nat] . ->opt . (-seq -PosFixnum))
(-NonNegFixnum [-Fixnum -Nat] . ->opt . (-seq -NonNegFixnum)) (-NonNegFixnum [-Fixnum -Nat] . ->opt . (-seq -NonNegFixnum))
(-Fixnum [-Fixnum -Int] . ->opt . (-seq -Fixnum)) (-Fixnum [-Fixnum -Int] . ->opt . (-seq -Fixnum))
@ -74,118 +75,61 @@
(-Nat [-Int -Nat] . ->opt . (-seq -Nat)) (-Nat [-Int -Nat] . ->opt . (-seq -Nat))
(-Int [-Int -Int] . ->opt . (-seq -Int)))] (-Int [-Int -Int] . ->opt . (-seq -Int)))]
;; in-naturals ;; in-naturals
[(syntax-parse (local-expand #'(in-naturals) 'expression #f) [(make-template-identifier 'in-naturals 'racket/private/for)
[(i-n _ ...)
#'i-n])
(cl->* (-> -PosInt (-seq -PosInt)) (cl->* (-> -PosInt (-seq -PosInt))
(-> -Int (-seq -Nat)))] (-> -Int (-seq -Nat)))]
;; in-list ;; in-list
[(syntax-parse (local-expand #'(in-list '(1 2 3)) 'expression #f) [(make-template-identifier 'in-list 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-poly (a) (-> (-lst a) (-seq a)))] (-poly (a) (-> (-lst a) (-seq a)))]
;; in-vector ;; in-vector
[(syntax-parse (local-expand #'(in-vector (vector 1 2 3)) 'expression #f) [(make-template-identifier 'in-vector 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-poly (a) (->opt (-vec a) [-Int (-opt -Int) -Int] (-seq a)))] (-poly (a) (->opt (-vec a) [-Int (-opt -Int) -Int] (-seq a)))]
;; in-string ;; in-string
[(syntax-parse (local-expand #'(in-string "abc") 'expression #f) [(make-template-identifier 'in-string 'racket/private/for)
[(i-n _ ...)
#'i-n])
(->opt -String [-Int (-opt -Int) -Int] (-seq -Char))] (->opt -String [-Int (-opt -Int) -Int] (-seq -Char))]
;; in-bytes ;; in-bytes
[(syntax-parse (local-expand #'(in-bytes #"abc") 'expression #f) [(make-template-identifier 'in-bytes 'racket/private/for)
[(i-n _ ...)
#'i-n])
(->opt -Bytes [-Int (-opt -Int) -Int] (-seq -Byte))] (->opt -Bytes [-Int (-opt -Int) -Int] (-seq -Byte))]
;; in-hash and friends ;; in-hash and friends
[(syntax-parse (local-expand #'(in-hash #hash((1 . 2))) 'expression #f) [(make-template-identifier 'in-hash 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-poly (a b) (-> (-HT a b) (-seq a b)))] (-poly (a b) (-> (-HT a b) (-seq a b)))]
[(syntax-parse (local-expand #'(in-hash-keys #hash((1 . 2))) 'expression #f) [(make-template-identifier 'in-hash-keys 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-poly (a b) (-> (-HT a b) (-seq a)))] (-poly (a b) (-> (-HT a b) (-seq a)))]
[(syntax-parse (local-expand #'(in-hash-values #hash((1 . 2))) 'expression #f) [(make-template-identifier 'in-hash-values 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-poly (a b) (-> (-HT a b) (-seq b)))] (-poly (a b) (-> (-HT a b) (-seq b)))]
;; in-port ;; in-port
[(syntax-parse (local-expand #'(in-port) 'expression #f) [(make-template-identifier 'in-port 'racket/private/for)
[(i-n _ ...)
#'i-n])
(->opt [(-> -Input-Port Univ) -Input-Port] (-seq Univ))] (->opt [(-> -Input-Port Univ) -Input-Port] (-seq Univ))]
;; in-input-port-bytes ;; in-input-port-bytes
[(syntax-parse (local-expand #'(in-input-port-bytes (open-input-bytes #"abc")) 'expression #f) [(make-template-identifier 'in-input-port-bytes 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-> -Input-Port (-seq -Byte))] (-> -Input-Port (-seq -Byte))]
;; in-input-port-chars ;; in-input-port-chars
[(syntax-parse (local-expand #'(in-input-port-chars (open-input-string "abc")) 'expression #f) [(make-template-identifier 'in-input-port-chars 'racket/private/for)
[(i-n _ ...)
#'i-n])
(-> -Input-Port (-seq -Char))] (-> -Input-Port (-seq -Char))]
;; in-lines ;; in-lines
[(syntax-parse (local-expand #'(in-lines) 'expression #f) [(make-template-identifier 'in-lines 'racket/private/for)
[(i-n _ ...)
#'i-n])
(->opt [-Input-Port -Symbol] (-seq -String))] (->opt [-Input-Port -Symbol] (-seq -String))]
;; in-bytes-lines ;; in-bytes-lines
[(syntax-parse (local-expand #'(in-bytes-lines) 'expression #f) [(make-template-identifier 'in-bytes-lines 'racket/private/for)
[(i-n _ ...)
#'i-n])
(->opt [-Input-Port -Symbol] (-seq -Bytes))] (->opt [-Input-Port -Symbol] (-seq -Bytes))]
;; check-in-bytes-lines ;; check-in-bytes-lines
[(syntax-parse (local-expand #'(for ([i (in-bytes-lines 0)]) i) [(make-template-identifier 'check-in-bytes-lines 'racket/private/for)
'expression #f)
#:literals (let-values let)
[(let-values ((_ (let _ (c . _) . _))
. _)
. _)
#'c])
(-> Univ Univ Univ)] (-> Univ Univ Univ)]
;; check-in-lines ;; check-in-lines
[(syntax-parse (local-expand #'(for ([i (in-lines 0)]) i) [(make-template-identifier 'check-in-lines 'racket/private/for)
'expression #f)
#:literals (let-values #%app let)
[(let-values ((_ (let _ (c . _) . _))
. _)
. _)
#'c])
(-> Univ Univ Univ)] (-> Univ Univ Univ)]
;; check-in-port ;; check-in-port
[(syntax-parse (local-expand #'(for ([i (in-port 0)]) i) [(make-template-identifier 'check-in-port 'racket/private/for)
'expression #f)
#:literals (let-values #%app let)
[(let-values ((_ (let _ (c . _) . _))
. _)
. _)
#'c])
(-> Univ Univ Univ)] (-> Univ Univ Univ)]
;; from the expansion of `with-syntax' ;; from the expansion of `with-syntax'
[(syntax-parse (local-expand #'(with-syntax ([x 1]) #'(x)) 'expression null) [(make-template-identifier 'apply-pattern-substitute 'racket/private/stxcase)
#: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])
(->* (list (-Syntax Univ) Univ) Univ Any-Syntax)] (->* (list (-Syntax Univ) Univ) Univ Any-Syntax)]
;; same
[(syntax-parse (local-expand #'(with-syntax ([x 1]) #'(x)) 'expression null) [(make-template-identifier 'with-syntax-fail 'racket/private/with-stx)
#: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])
(-> (-Syntax Univ) (Un))] (-> (-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)] (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)]
;; below here: keyword-argument functions from the base environment ;; below here: keyword-argument functions from the base environment