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

26
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 loop ([e3s #'e3s]
[e1s #'e1s]
[def-ids #'def-ids])
(syntax-case e3s ()
[()
#`(frm () #,e1s #,def-ids)]
[(e2 . e3s)
(let ([e2 (local-expand #'e2 'module local-expand-stop-list)]) (let ([e2 (local-expand #'e2 'module local-expand-stop-list)])
;; Lift out certain forms to make them visible to the module ;; Lift out certain forms to make them visible to the module
;; expander: ;; expander:
(syntax-case e2 (#%require define-syntaxes define-values-for-syntax define-values begin) (syntax-case e2 (#%require define-syntaxes define-values-for-syntax define-values begin)
[(#%require . __) [(#%require . __)
#`(begin #,e2 (frm e1s e3s def-ids))] #`(begin #,e2 (frm e3s #,e1s #,def-ids))]
[(define-syntaxes (id ...) . _) [(define-syntaxes (id ...) . _)
#`(begin #,e2 (frm e1s e3s (id ... . def-ids)))] #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))]
[(define-values-for-syntax . _) [(define-values-for-syntax . _)
#`(begin #,e2 (frm e1s e3s def-ids))] #`(begin #,e2 (frm e3s #,e1s #,def-ids))]
[(begin b1 ...) [(begin b1 ...)
(syntax-track-origin #`(frm e1s (b1 ... . e3s) def-ids) (syntax-track-origin
(loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids)
e2 e2
(car (syntax-e e2)))] (car (syntax-e e2)))]
[(define-values (id ...) . _) [(define-values (id ...) . _)
#`(frm (#,e2 . e1s) e3s (id ... . def-ids))] (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids))]
[_ [_
#`(frm ((print-results #,e2) . e1s) e3s 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))