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

added tests for pr 8136 and recent posts about top-level namespace strangeness on plt-scheme

Browse Source 
svn: r3935
This commit is contained in:
Robby Findler 2006-08-02 19:04:35 +00:00
parent 3028094e42
commit cd03877fae
2 changed files with 75 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/tests/drscheme/drscheme-test-util.ss
View File

@ -441,6 +441,7 @@
(send interactions-text split-snip start)
(send interactions-text split-snip end)
(let loop ([snip (send interactions-text find-snip end 'before)]
[strings null])
(cond
@ -479,7 +480,10 @@
(send snip get-fraction-view))
strings))]
[else (error 'find-output "{unknown snip: ~e}~n" snip)])]))))))]))
[else
(loop (send snip previous)
(cons (format "{unknown snip: ~e}~n" snip)
strings))])]))))))]))
;; run-one/sync : (-> A) -> A
;; runs the thunk `f' as a test action, and
@ -487,14 +491,17 @@
;; exceptions.
(define (run-one/sync f)
(let ([s (make-semaphore 0)]
[raised-exn? #f]
[exn #f]
[anss #f])
(fw:test:run-one
(lambda ()
(with-handlers ([exn:fail? (lambda (exn) (set! exn exn))])
(with-handlers ([exn:fail? (lambda (-exn)
(set! raised-exn? #t)
(set! exn -exn))])
(call-with-values f (lambda x (set! anss x))))
(semaphore-post s)))
(semaphore-wait s)
(if anss
(apply values anss)
(raise exn)))))
(if raised-exn?
(raise exn)
(apply values anss)))))

69
collects/tests/drscheme/repl-test.ss
View File

@ -2,9 +2,6 @@
add this test:
(require (lib "pretty.ss"))
(pretty-print-print-hook (lambda x (car)))
(list 1 2 3)
There shouldn't be any error (but add in a bug that triggers one to be sure!)
@ -53,9 +50,12 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
teardown ;; : -> void
))
(define (to-strings . args)
(apply string-append (map (λ (x) (format "~s\n" x)) args)))
(define test-data
(list
;; basic tests
(make-test "1"
"1"
@ -696,7 +696,64 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(cons (make-loc 0 26 26) (make-loc 0 27 27))
#f
void
void)))
void)
;; setup of the namespaces for pict printing (from slideshow)
(make-test "(require (lib \"utils.ss\" \"texpict\"))(disk 3)"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
'interactions
#f
void
void)
(make-test (to-strings
'(require (lib "utils.ss" "texpict"))
'(let ()
(current-namespace (make-namespace))
(namespace-set-variable-value! 'd (disk 3)))
'd)
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
"{unknown snip: #<struct:object:pict-value-snip%>}\n"
'interactions
#f
void
void)
(make-test (to-strings
'(let ([on (current-namespace)]
[n ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)])
(current-namespace (make-namespace))
(namespace-attach-module on n))
'(require (lib "utils.ss" "texpict"))
'(disk 3))
"#<struct:pict>"
"#<struct:pict>"
"#<struct:pict>"
"#<struct:pict>"
'interactions
#f
void
void)
(make-test (string-append
"(require (lib \"pretty.ss\"))"
"(pretty-print-print-hook (lambda x (car)))"
"(list 1 2 3)")
"(1 2 3)"
"(1 2 3)"
"(1 2 3)"
"(1 2 3)"
'interactions
#f
void
void)
))
(define backtrace-image-string "{bug09.gif}")
(define file-image-string "{file.gif}")
@ -1010,7 +1067,7 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
(delete-file tmp-load-filename))
(save-drscheme-window-as tmp-load-filename)
;(run-test-in-language-level #t)
(run-test-in-language-level #t)
(run-test-in-language-level #f)
(kill-tests)
(callcc-test)