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

Preserve source location in the optimizer.

Browse Source 
original commit: c7d2f13dd0124cf87ea8770c8c5b0299d95694d5
This commit is contained in:
Vincent St-Amour 2011-05-24 16:27:08 -04:00
parent 64ca59cc41
commit 534cd21a09
1 changed files with 9 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -48,12 +48,13 @@
(cons (car l)
(map (optimize) (cdr l)))))
#'([formals e ...] ...))
#:with opt #'(case-lambda opt-parts ...))
#:with opt (syntax/loc this-syntax (case-lambda opt-parts ...)))
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:expr] ...) e-body:expr ...)
#:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...))
#:with opt #`(op ([ids opt-rhs] ...)
#,@(syntax-map (optimize) #'(e-body ...))))
#:with opt (quasisyntax/loc this-syntax
(op ([ids opt-rhs] ...)
#,@(syntax-map (optimize) #'(e-body ...)))))
(pattern (letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:expr] ...)
e-body:expr ...)
@ -63,17 +64,19 @@
(let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l)))))
#'([(ids ...) e-rhs] ...))
#:with opt #`(letrec-syntaxes+values
#:with opt (quasisyntax/loc this-syntax
(letrec-syntaxes+values
stx-bindings
(opt-clauses ...)
#,@(syntax-map (optimize) #'(e-body ...))))
#,@(syntax-map (optimize) #'(e-body ...)))))
(pattern (kw:identifier expr ...)
#:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)])
(free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause
#:with opt #`(kw #,@(syntax-map (optimize) #'(expr ...))))
#:with opt (quasisyntax/loc this-syntax
(kw #,@(syntax-map (optimize) #'(expr ...)))))
(pattern other:expr
#:with opt #'other))