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 expr
(keep-lambda-properties (keep-lambda-properties
expr expr
(profile-annotate-lambda name expr expr (syntax body) (profile-annotate-lambda name expr disarmed-expr (syntax body)
phase)))] phase)))]
[(case-lambda clause ...) [(case-lambda clause ...)
(with-syntax ([([args . body] ...) (with-syntax ([([args . body] ...)

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

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

2
collects/mzlib/shared.rkt
View File

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

14
collects/racket/package.rkt
View File

@ -102,6 +102,16 @@
orig orig
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) (define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx () (syntax-case exp-stx ()
[(_ pack-id mode exports form ...) [(_ pack-id mode exports form ...)
@ -155,8 +165,8 @@
[new-bindings (make-bound-identifier-mapping)] [new-bindings (make-bound-identifier-mapping)]
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes) [fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
(lambda (stx) (lambda (stx)
(syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax (syntax-case* (disarm* stx) (define-syntaxes #%plain-app make-package quote-syntax
list cons #%plain-lambda) list cons #%plain-lambda)
free-transformer-identifier=? free-transformer-identifier=?
[(define-syntaxes (pack-id) [(define-syntaxes (pack-id)
(#%plain-app (#%plain-app