From cd03877fae64ece78dda80ff4c6817d31089058b Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 2 Aug 2006 19:04:35 +0000
Subject: [PATCH] added tests for pr 8136 and recent posts about top-level
 namespace strangeness on plt-scheme

svn: r3935
---
 collects/tests/drscheme/drscheme-test-util.ss | 17 +++--
 collects/tests/drscheme/repl-test.ss          | 69 +++++++++++++++++--
 2 files changed, 75 insertions(+), 11 deletions(-)

diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss
index 4b1594e57a..da3ce84ec0 100644
--- a/collects/tests/drscheme/drscheme-test-util.ss
+++ b/collects/tests/drscheme/drscheme-test-util.ss
@@ -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)))))
\ No newline at end of file
+      (if raised-exn?
+          (raise exn)
+          (apply values anss)))))
diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss
index 833e465c20..03deba02e6 100644
--- a/collects/tests/drscheme/repl-test.ss
+++ b/collects/tests/drscheme/repl-test.ss
@@ -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)