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

tune htdp language #%module-begin to avoid unnecessary macro trampolining

Browse Source 
svn: r11405
This commit is contained in:
Matthew Flatt 2008-08-24 12:34:04 +00:00
parent a6d552478a
commit fea6ea12bf
1 changed files with 29 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
collects/lang/private/contracts/contracts-module-begin.ss
View File

@ -208,12 +208,12 @@
;; the module-expansion machinery can be used to handle ;; the module-expansion machinery can be used to handle
;; requires, etc.: ;; requires, etc.:
#`(#%plain-module-begin #`(#%plain-module-begin
(#,module-begin-continue-id () (e1 ...) ()))])) (#,module-begin-continue-id (e1 ...) () ()))]))
;; module-continue (for a specific language:) ;; module-continue (for a specific language:)
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ (e1 ...) () (defined-id ...)) [(_ () (e1 ...) (defined-id ...))
;; Local-expanded all body elements, lifted out requires, etc. ;; Local-expanded all body elements, lifted out requires, etc.
;; Now process the result. ;; Now process the result.
(begin (begin
@ -239,25 +239,33 @@
language-level-define-data language-level-define-data
cnt-list cnt-list
expr-list)))] expr-list)))]
[(frm e1s (e2 . e3s) def-ids) [(frm e3s e1s def-ids)
(let ([e2 (local-expand #'e2 'module local-expand-stop-list)]) (let loop ([e3s #'e3s]
;; Lift out certain forms to make them visible to the module [e1s #'e1s]
;; expander: [def-ids #'def-ids])
(syntax-case e2 (#%require define-syntaxes define-values-for-syntax define-values begin) (syntax-case e3s ()
[(#%require . __) [()
#`(begin #,e2 (frm e1s e3s def-ids))] #`(frm () #,e1s #,def-ids)]
[(define-syntaxes (id ...) . _) [(e2 . e3s)
#`(begin #,e2 (frm e1s e3s (id ... . def-ids)))] (let ([e2 (local-expand #'e2 'module local-expand-stop-list)])
[(define-values-for-syntax . _) ;; Lift out certain forms to make them visible to the module
#`(begin #,e2 (frm e1s e3s def-ids))] ;; expander:
[(begin b1 ...) (syntax-case e2 (#%require define-syntaxes define-values-for-syntax define-values begin)
(syntax-track-origin #`(frm e1s (b1 ... . e3s) def-ids) [(#%require . __)
e2 #`(begin #,e2 (frm e3s #,e1s #,def-ids))]
(car (syntax-e e2)))] [(define-syntaxes (id ...) . _)
[(define-values (id ...) . _) #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))]
#`(frm (#,e2 . e1s) e3s (id ... . def-ids))] [(define-values-for-syntax . _)
[_ #`(begin #,e2 (frm e3s #,e1s #,def-ids))]
#`(frm ((print-results #,e2) . e1s) e3s def-ids)]))])))) [(begin b1 ...)
(syntax-track-origin
(loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids)
e2
(car (syntax-e e2)))]
[(define-values (id ...) . _)
(loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids))]
[_
(loop #'e3s (cons #`(print-results #,e2) e1s) def-ids)]))]))]))))
(define-values (parse-beginner-contract/func continue-beginner-contract/func) (define-values (parse-beginner-contract/func continue-beginner-contract/func)
(parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue)) (parse-contracts #'beginner-contract #'beginner-define-data #'beginner-continue))