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-syntax (htdp-top stx)
(syntax-case stx (quote)
[(_ expr)
#'(set! body-accum (append body-accum (list #'expr)))]))
#'(set! body-accum (append body-accum (list (strip-context #'expr))))]))
(define (htdp-top-pop w)
(set! body-accum (let loop ([body-accum body-accum])
(if (null? (cdr body-accum))
@ -16,7 +29,7 @@
[(stx rx)
(error-test #`(module m #,current-htdp-lang
#,@body-accum
#,stx)
#,(strip-context stx))
(lambda (x)
(and (exn:fail:syntax? x)
(regexp-match rx (exn-message x)))))]))
@ -39,7 +52,7 @@
(eval
#`(module #,name #,current-htdp-lang
#,@body-accum
expr))
#,(strip-context #'expr)))
(dynamic-require name #f))]
[_
(printf "~s\n" (syntax-object->datum stx))
@ -86,7 +99,7 @@
(all-except #,current-htdp-lang #%module-begin)
#f
#,@body-accum
#,stx))
#,(strip-context stx)))
(unless stx-err?
(if exn?
(err/rt-test (eval #`(require #,name)) exn?)
@ -104,5 +117,5 @@
(all-except #,current-htdp-lang #%module-begin)
the-answer
#,@body-accum
(define the-answer #,stx)))
(define the-answer #,(strip-context stx))))
(dynamic-require name 'the-answer)))