Make stx.rkt cross-phase persistent.
This eliminates more than 70 linklet instance creations.
This commit is contained in:
parent
ce97087507
commit
c6dd371ed6
|
@ -3,7 +3,7 @@
|
||||||
;; cond
|
;; cond
|
||||||
|
|
||||||
(module cond '#%kernel
|
(module cond '#%kernel
|
||||||
(#%require (for-syntax "stx.rkt" "qq-and-or.rkt" '#%kernel))
|
(#%require (for-syntax "stx.rkt" "qq-and-or.rkt" '#%kernel "gen-temp.rkt"))
|
||||||
|
|
||||||
(define-syntaxes (=>)
|
(define-syntaxes (=>)
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
|
|
18
racket/collects/racket/private/gen-temp.rkt
Normal file
18
racket/collects/racket/private/gen-temp.rkt
Normal file
|
@ -0,0 +1,18 @@
|
||||||
|
;;----------------------------------------------------------------------
|
||||||
|
;; stateful syntax support
|
||||||
|
|
||||||
|
(module gen-temp '#%kernel
|
||||||
|
(define-values (intro) #f)
|
||||||
|
(define-values (counter) 0)
|
||||||
|
(define-values (gen-temp-id)
|
||||||
|
;; Even though we gensym, using an introducer helps the
|
||||||
|
;; syntax system simplify renamings that can't apply
|
||||||
|
;; to other identifiers (when the generated identifier
|
||||||
|
;; is used as a binding id)
|
||||||
|
(lambda (pfx)
|
||||||
|
(if intro
|
||||||
|
(void)
|
||||||
|
(set! intro (make-syntax-introducer)))
|
||||||
|
(set! counter (add1 counter))
|
||||||
|
(intro (datum->syntax #f (string->uninterned-symbol (format "~a~a" pfx counter))))))
|
||||||
|
(#%provide gen-temp-id))
|
|
@ -2,7 +2,7 @@
|
||||||
;; basic syntax utilities
|
;; basic syntax utilities
|
||||||
|
|
||||||
(module stx '#%kernel
|
(module stx '#%kernel
|
||||||
|
(#%declare #:cross-phase-persistent)
|
||||||
;; These utilities facilitate operations on syntax objects.
|
;; These utilities facilitate operations on syntax objects.
|
||||||
;; A syntax object that represents a parenthesized sequence
|
;; A syntax object that represents a parenthesized sequence
|
||||||
;; can contain a mixture of cons cells and syntax objects,
|
;; can contain a mixture of cons cells and syntax objects,
|
||||||
|
@ -197,20 +197,6 @@
|
||||||
(loop s))])
|
(loop s))])
|
||||||
(values pre post (= m n)))))
|
(values pre post (= m n)))))
|
||||||
|
|
||||||
(define-values (intro) #f)
|
|
||||||
(define-values (counter) 0)
|
|
||||||
(define-values (gen-temp-id)
|
|
||||||
;; Even though we gensym, using an introducer helps the
|
|
||||||
;; syntax system simplify renamings that can't apply
|
|
||||||
;; to other identifiers (when the generated identifier
|
|
||||||
;; is used as a binding id)
|
|
||||||
(lambda (pfx)
|
|
||||||
(if intro
|
|
||||||
(void)
|
|
||||||
(set! intro (make-syntax-introducer)))
|
|
||||||
(set! counter (add1 counter))
|
|
||||||
(intro (datum->syntax #f (string->uninterned-symbol (format "~a~a" pfx counter))))))
|
|
||||||
|
|
||||||
(#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list?
|
(#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list?
|
||||||
stx-car stx-cdr stx->list
|
stx-car stx-cdr stx->list
|
||||||
stx-vector? stx-vector-ref
|
stx-vector? stx-vector-ref
|
||||||
|
@ -218,5 +204,4 @@
|
||||||
stx-prefab?
|
stx-prefab?
|
||||||
stx-check/esc cons/#f append/#f
|
stx-check/esc cons/#f append/#f
|
||||||
stx-rotate stx-rotate*
|
stx-rotate stx-rotate*
|
||||||
split-stx-list
|
split-stx-list))
|
||||||
gen-temp-id))
|
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
(#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
|
(#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
|
||||||
"ellipses.rkt"
|
"ellipses.rkt"
|
||||||
(for-syntax "stx.rkt" "small-scheme.rkt"
|
(for-syntax "stx.rkt" "small-scheme.rkt"
|
||||||
"member.rkt" "sc.rkt" '#%kernel))
|
"gen-temp.rkt" "member.rkt" "sc.rkt" '#%kernel))
|
||||||
|
|
||||||
(-define interp-match
|
(-define interp-match
|
||||||
(lambda (pat e literals immediate=?)
|
(lambda (pat e literals immediate=?)
|
||||||
|
|
|
@ -4,7 +4,7 @@
|
||||||
(module with-stx '#%kernel
|
(module with-stx '#%kernel
|
||||||
(#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt"
|
(#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt"
|
||||||
(for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt"
|
(for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt"
|
||||||
"sc.rkt" "qq-and-or.rkt" "cond.rkt"))
|
"gen-temp.rkt" "sc.rkt" "qq-and-or.rkt" "cond.rkt"))
|
||||||
|
|
||||||
(-define (with-syntax-fail stx)
|
(-define (with-syntax-fail stx)
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
(module repl '#%kernel
|
(module repl '#%kernel
|
||||||
|
(#%declare #:cross-phase-persistent)
|
||||||
(#%provide read-eval-print-loop)
|
(#%provide read-eval-print-loop)
|
||||||
|
|
||||||
(define-values (read-eval-print-loop)
|
(define-values (read-eval-print-loop)
|
||||||
|
@ -30,4 +30,4 @@
|
||||||
(abort-current-continuation (default-continuation-prompt-tag))))))
|
(abort-current-continuation (default-continuation-prompt-tag))))))
|
||||||
(default-continuation-prompt-tag)
|
(default-continuation-prompt-tag)
|
||||||
(lambda args (repl-loop))))])
|
(lambda args (repl-loop))))])
|
||||||
(repl-loop)))))
|
(repl-loop)))))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user