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

syntax-taint repairs

Browse Source 
for problems exposed by more agressive arming of `lambda'
and `#%app'
This commit is contained in:
Matthew Flatt 2011-08-08 20:40:50 -06:00
parent f646511ca7
commit 001cb75bac
5 changed files with 28 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/errortrace/stacktrace.rkt
View File

@ -428,7 +428,7 @@
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
(profile-annotate-lambda name expr disarmed-expr (syntax body)
phase)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)

2
collects/lang/private/teach-shared.rkt
View File

@ -12,6 +12,8 @@
scheme/base
(only-in "teachprims.rkt" [advanced-cons the-cons])))
(define code-insp (current-code-inspector))
(define shared/proc
(lambda (stx make-check-cdr undefined-expr)
(with-syntax ([undefined undefined-expr])

18
collects/mzlib/private/shared-body.rkt
View File

@ -1,8 +1,9 @@
;; Used by ../shared.rkt, and also collects/lang/private/teach.rkt
;; Besides the usual things, this code expects `undefined' and
;; `the-cons' to be bound, and it expects `struct-declaration-info?'
;; from the "struct.rkt" library of the "syntax" collection.
;; `the-cons', to be bound, it expects `struct-declaration-info?'
;; from the "struct.rkt" library of the "syntax" collection, and it
;; expects `code-insp' for-syntax.
(syntax-case stx ()
[(_ ([name expr] ...) body1 body ...)
@ -31,7 +32,7 @@
(kernel-form-identifier-list)
names))])
;; Remove #%app if present...
(syntax-case e (#%plain-app)
(syntax-case (syntax-disarm e code-insp) (#%plain-app)
[(#%plain-app a ...)
(syntax/loc e (a ...))]
[_else e])))
@ -89,7 +90,8 @@
(if (null? rmv-lst)
lst
(loop (remove (car rmv-lst) lst)
(cdr rmv-lst)))))])
(cdr rmv-lst)))))]
[disarm (lambda (stx) (syntax-disarm stx code-insp))])
(with-syntax ([(graph-expr ...)
(map (lambda (expr)
(let loop ([expr expr])
@ -107,7 +109,7 @@
ph))
names placeholder-ids ph-used?s))
(loop expr)))
(syntax-case* expr (the-cons mcons append box box-immutable vector vector-immutable) same-special-id?
(syntax-case* (disarm expr) (the-cons mcons append box box-immutable vector vector-immutable) same-special-id?
[(the-cons a d)
(with-syntax ([a (cons-elem #'a)]
[d (cons-elem #'d)])
@ -194,7 +196,9 @@
[(vector . _) temp-id]
[(vector-immutable . _) temp-id]
[(make-x . _)
(struct-decl-for (syntax make-x))
(syntax-case (syntax-disarm expr code-insp) ()
[(make-x . _)
(struct-decl-for (syntax make-x))])
temp-id]
[else #f])])
(cond
@ -217,7 +221,7 @@
(map (lambda (name expr)
(let loop ([name name] [expr expr])
(with-syntax ([name name])
(syntax-case* expr (the-cons mcons list list* append box box-immutable vector vector-immutable)
(syntax-case* (disarm expr) (the-cons mcons list list* append box box-immutable vector vector-immutable)
same-special-id?
[(the-cons a d)
#`(begin #,(loop #`(car name) #'a)

2
collects/mzlib/shared.rkt
View File

@ -9,6 +9,8 @@
(provide shared)
(define-for-syntax code-insp (current-code-inspector))
(define undefined (letrec ([x x]) x))
(require (only-in scheme/base [cons the-cons]))

14
collects/racket/package.rkt
View File

@ -102,6 +102,16 @@
orig
orig))
(define-for-syntax code-insp (current-code-inspector))
(define-for-syntax (disarm* stx)
(cond
[(and (syntax? stx)
(pair? (syntax-e stx)))
(let ([stx (syntax-disarm stx code-insp)])
(datum->syntax stx (disarm* (syntax-e stx)) stx stx))]
[(pair? stx) (cons (disarm* (car stx)) (disarm* (cdr stx)))]
[else stx]))
(define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx ()
[(_ pack-id mode exports form ...)
@ -155,8 +165,8 @@
[new-bindings (make-bound-identifier-mapping)]
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
(lambda (stx)
(syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax
list cons #%plain-lambda)
(syntax-case* (disarm* stx) (define-syntaxes #%plain-app make-package quote-syntax
list cons #%plain-lambda)
free-transformer-identifier=?
[(define-syntaxes (pack-id)
(#%plain-app