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

Preserve source location in the optimizer.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-05-24 16:27:08 -04:00
parent 5352593bf1
commit c7d2f13dd0
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) (cons (car l)
(map (optimize) (cdr l))))) (map (optimize) (cdr l)))))
#'([formals e ...] ...)) #'([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))) (pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:expr] ...) e-body:expr ...) ([ids e-rhs:expr] ...) e-body:expr ...)
#:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...)) #:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...))
#:with opt #`(op ([ids opt-rhs] ...) #:with opt (quasisyntax/loc this-syntax
#,@(syntax-map (optimize) #'(e-body ...)))) (op ([ids opt-rhs] ...)
#,@(syntax-map (optimize) #'(e-body ...)))))
(pattern (letrec-syntaxes+values stx-bindings (pattern (letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:expr] ...) ([(ids ...) e-rhs:expr] ...)
e-body:expr ...) e-body:expr ...)
@ -63,17 +64,19 @@
(let ((l (syntax->list clause))) (let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l))))) (list (car l) ((optimize) (cadr l)))))
#'([(ids ...) e-rhs] ...)) #'([(ids ...) e-rhs] ...))
#:with opt #`(letrec-syntaxes+values #:with opt (quasisyntax/loc this-syntax
(letrec-syntaxes+values
stx-bindings stx-bindings
(opt-clauses ...) (opt-clauses ...)
#,@(syntax-map (optimize) #'(e-body ...)))) #,@(syntax-map (optimize) #'(e-body ...)))))
(pattern (kw:identifier expr ...) (pattern (kw:identifier expr ...)
#:when #:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)]) #'#%variable-reference #'with-continuation-mark)])
(free-identifier=? k #'kw)) (free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause ;; 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 (pattern other:expr
#:with opt #'other)) #:with opt #'other))