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
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