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

get context right for forms put into a module

Browse Source 
svn: r3736
This commit is contained in:
Matthew Flatt 2006-07-17 02:44:37 +00:00
parent 7cb8b4536d
commit b8e4c018f2
1 changed files with 18 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/tests/mzscheme/htdp-test.ss
View File

@ -1,9 +1,22 @@
(define (strip-context v)
;; Just to be sure, remove all top-level context from the syntax object
(cond
[(syntax? v)
(datum->syntax-object
#f
(strip-context (syntax-e v))
v
v)]
[(pair? v) (cons (strip-context (car v))
(strip-context (cdr v)))]
[else v]))
(define body-accum null) (define body-accum null)
(define-syntax (htdp-top stx) (define-syntax (htdp-top stx)
(syntax-case stx (quote) (syntax-case stx (quote)
[(_ expr) [(_ expr)
#'(set! body-accum (append body-accum (list #'expr)))])) #'(set! body-accum (append body-accum (list (strip-context #'expr))))]))
(define (htdp-top-pop w) (define (htdp-top-pop w)
(set! body-accum (let loop ([body-accum body-accum]) (set! body-accum (let loop ([body-accum body-accum])
(if (null? (cdr body-accum)) (if (null? (cdr body-accum))
@ -16,7 +29,7 @@
[(stx rx) [(stx rx)
(error-test #`(module m #,current-htdp-lang (error-test #`(module m #,current-htdp-lang
#,@body-accum #,@body-accum
#,stx) #,(strip-context stx))
(lambda (x) (lambda (x)
(and (exn:fail:syntax? x) (and (exn:fail:syntax? x)
(regexp-match rx (exn-message x)))))])) (regexp-match rx (exn-message x)))))]))
@ -39,7 +52,7 @@
(eval (eval
#`(module #,name #,current-htdp-lang #`(module #,name #,current-htdp-lang
#,@body-accum #,@body-accum
expr)) #,(strip-context #'expr)))
(dynamic-require name #f))] (dynamic-require name #f))]
[_ [_
(printf "~s\n" (syntax-object->datum stx)) (printf "~s\n" (syntax-object->datum stx))
@ -86,7 +99,7 @@
(all-except #,current-htdp-lang #%module-begin) (all-except #,current-htdp-lang #%module-begin)
#f #f
#,@body-accum #,@body-accum
#,stx)) #,(strip-context stx)))
(unless stx-err? (unless stx-err?
(if exn? (if exn?
(err/rt-test (eval #`(require #,name)) exn?) (err/rt-test (eval #`(require #,name)) exn?)
@ -104,5 +117,5 @@
(all-except #,current-htdp-lang #%module-begin) (all-except #,current-htdp-lang #%module-begin)
the-answer the-answer
#,@body-accum #,@body-accum
(define the-answer #,stx))) (define the-answer #,(strip-context stx))))
(dynamic-require name 'the-answer))) (dynamic-require name 'the-answer)))