clean up some tests

svn: r16350

collects/tests/mred/blits.ss

@@ -1,3 +1,4 @@
+#lang scheme/gui
 
 (define ok-frame (make-object frame% "Ok"))
 (define ok-panel #f)
@@ -57,14 +58,14 @@
 
 (define targets
   (list
-   (build-path (collection-path "frtime") "clock.png")
-   (self-mask (build-path (collection-path "frtime") "clock.png"))
+   (build-path (collection-path "frtime") "tool" "clock.png")
+   (self-mask (build-path (collection-path "frtime") "tool" "clock.png"))
    (build-path (collection-path "icons") "foot-up.png")
    (build-path (collection-path "icons") "mred.xbm")
    (self-mask (build-path (collection-path "icons") "mred.xbm"))
    (plus-mask (build-path (collection-path "icons") "mred.xbm")
 	      (build-path (collection-path "icons") "PLT-206.png"))
-   (plus-mask (build-path (collection-path "frtime") "clock.png")
+   (plus-mask (build-path (collection-path "frtime") "tool" "clock.png")
 	      (build-path (collection-path "icons") "mred.xbm"))
    (build-path (collection-path "icons") "htdp-icon.gif")
    ))

collects/tests/mred/frame-edit.ss

@@ -1,73 +0,0 @@
-;; this file tests frames with various edits in them
-
-(define testing-frame #f)
-
-(define test-frame/edit
-  (lambda (frame% edit% title)
-    (let* ([frame (make-object
-		   (class frame% args
-		     (public [get-edit% (lambda () edit%)])
-		     (inherit show)
-		     (sequence (apply super-init args))))]
-	   [edit (send frame get-edit)]
-	   [string-good "test insert"]
-	   [string-bad "SHOULD NOT SEE THIS"]
-	   [get-insertion
-	    (lambda (string)
-	      (if (is-a? edit wx:media-edit%)
-		  string
-		  (let ([snip (make-object wx:media-snip%)]
-			[snip-e (make-object mred:media-edit%)])
-		    (send snip set-media snip-e)
-		    (send snip-e insert string)
-		    snip)))])
-      (set! testing-frame frame)
-      (send frame set-title-prefix title)
-      (send frame show #t)
-      (send edit insert (get-insertion string-good))
-      (send edit lock #t)
-      (send edit insert (get-insertion string-bad))
-      (send edit lock #f))))
-
-(define continue? #t)
-
-(define close-down
-  (lambda ()
-    (let ([answer (mred:get-choice "Continue the test suite?"
-				   "Yes" "No"
-				   "connections test suite")])
-      (when (send testing-frame on-close)
-	(send testing-frame show #f))
-      (unless answer
-	(error 'close-down)))))
-
-(define-macro frame/edit
-  (lambda (frame% edit%)
-    `(when continue?
-       (printf "testing frame: ~a edit: ~a~n" ',frame% ',edit%)
-       (test-frame/edit ,frame% ,edit% (format "~a ~a" ',frame% ',edit%)))))
-	     
-(define searching-frame% (mred:make-searchable-frame% mred:simple-menu-frame%))
-(define searching-info-frame% (mred:make-searchable-frame% mred:info-frame%))
-
-(frame/edit mred:pasteboard-frame% mred:pasteboard%) (close-down)
-(frame/edit mred:simple-menu-frame% mred:media-edit%) (close-down)
-(frame/edit searching-frame% mred:media-edit%) (close-down)
-
-(frame/edit mred:info-frame% mred:info-edit%) (close-down)
-
-(frame/edit searching-info-frame% mred:searching-edit%)
-(mred:find-string (send testing-frame get-canvas)
-		  null
-		  0 0 (list 'ignore-case))
-(close-down)
-
-(frame/edit mred:info-frame% mred:clever-file-format-edit%) (close-down)
-(frame/edit mred:info-frame% mred:file-edit%) (close-down)
-(frame/edit mred:info-frame% mred:backup-autosave-edit%) (close-down)
-(frame/edit mred:info-frame% mred:scheme-mode-edit%) (close-down)
-
-(frame/edit searching-info-frame% mred:clever-file-format-edit%) (close-down)
-(frame/edit searching-info-frame% mred:file-edit%) (close-down)
-(frame/edit searching-info-frame% mred:backup-autosave-edit%) (close-down)
-(frame/edit searching-info-frame% mred:scheme-mode-edit%) (close-down)

collects/tests/mred/gui-main.ss

@@ -12,7 +12,7 @@
 		    (sleep 1/2)
 		    (loop #t)))))]
 	 [wait
-	  (opt-lambda (test desc-string [time 5])
+	  (lambda (test desc-string [time 5])
 	    (let ([int 1/2])
 	      (let loop ([sofar 0])
 		(cond

collects/tests/mred/imred.ss

@@ -1,70 +0,0 @@
-(define make-invokable-unit
-  (lambda (application)
-    (compound-unit/sig (import)
-      (link [wx : wx^ (wx@)]
-	    [core : mzlib:core^ (mzlib:core@)]
-	    [mred : mred^ ((require-library "linkwx.ss" "mred") core wx)]
-	    [application : () (application mred core wx)])
-      (export (unit mred mred2)))))
-
-(define (go flags)
-  (define die? #f)
-  (define my-app
-    (unit/sig ()
-     (import mred^ 
-	     mzlib:core^
-	     [wx : wx^])
-     
-     (define app-name "Tester")
-     (define console (if (memq 'console flags)
-			 (make-object console-frame%)
-			 #f))
-     (define eval-string pretty-print@:pretty-print)
-     (when (memq 'thread flags)
-	   (let ([s (make-semaphore 1)]
-		 [s2 (make-semaphore 0)]
-		 [done (make-semaphore 0)])
-	     ; Use of semaphore-callback insures that thread is a child
-	     ; of the eventspace
-	     (semaphore-callback s
-				 (lambda ()
-				   (semaphore-post done)
-				   (thread (lambda ()
-					     (let loop ()
-					       (sleep 1)
-					       (loop))))
-				   (when (begin0
-					  die?
-					  (set! die? (not die?)))
-				       (kill-thread (current-thread))))) ; kills handler thread
-	     ; Add another callback that we know will not get triggered
-	     (semaphore-callback s2 void)
-	     (wx:yield done)))
-     (when (memq 'eventspace flags)
-	   (let ([e (wx:make-eventspace)])
-	     (parameterize ([wx:current-eventspace e])
-		(send (make-object wx:frame% null "Testing" -1 -1 100 100)
-		      show #t))))
-     (unless (memq 'force flags)
-	     (run-exit-callbacks))))
-  
-  (let loop ()
-    (collect-garbage)
-    (collect-garbage)
-    (wx:yield) (sleep) (wx:yield) (sleep)
-    (wx:yield) (sleep) (wx:yield) (sleep)
-    (wx:yield) (sleep) (wx:yield) (sleep)
-    (wx:yield) (sleep) (wx:yield) (sleep)
-    (wx:yield) (sleep) (wx:yield) (sleep)
-    (dump-memory-stats)
-    (let ([custodian (make-custodian)])
-      (parameterize ([current-custodian custodian]
-		     [wx:current-eventspace 
-		      (if (memq 'force flags)
-			  (wx:make-eventspace)
-			  (wx:current-eventspace))])
-	  (invoke-unit/sig
-	   (make-invokable-unit my-app)))
-      (when (memq 'force flags)
-	    (custodian-shutdown-all custodian)))
-    (loop)))

collects/tests/mred/mediastream.ss

@@ -1,60 +0,0 @@
-
-(define out-base (make-object wx:media-stream-out-string-base%))
-(define out (make-object wx:media-stream-out% out-base))
-
-(define items (list 10 3.5 100 0 -1 -100 -3.5 "howdy"))
-
-(define (write-all)
-  (for-each
-   (lambda (i)
-     (send out put i))
-   items))
-
-(write-all)
-
-(let ([start (send out tell)])
-  (send out put-fixed 100)
-  (write-all)
-  (let ([end (send out tell)])
-    (send out jump-to start)
-    (send out put-fixed 99)
-    (send out jump-to end)
-    (send out put "End Second")))
-
-(define file (send out-base get-string))
-
-(define in-base (make-object wx:media-stream-in-string-base% file))
-(define in (make-object wx:media-stream-in% in-base))
-
-(define (test expected got)
-  (unless (equal? expected got)
-    (error 'media-stream-test "expected ~s, got ~s~n" expected got)))
-
-(define (read-all)
-  (for-each
-   (lambda (i)
-     (test i
-	   (cond
-	    [(string? i) (send in get-string)]
-	    [(inexact? i) (send in get-inexact)]
-	    [else (send in get-exact)])))
-   items))
-(read-all)
-(test 99 (let ([b (box 0)])
-	   (send in get-fixed b)
-	   (unbox b)))
-(read-all)
-(test "End Second" (send in get-string))
-
-(define example-file-name (build-path (current-load-relative-directory) "mediastream.example"))
-(define expect (if (file-exists? example-file-name)
-		   (with-input-from-file example-file-name
-		     (lambda ()
-		       (read-string (+ (string-length file) 10))))
-		   (begin
-		     (fprintf (current-error-port) "Warning: ~a does not exist; creating it.~n" example-file-name)
-		     (with-output-to-file example-file-name
-		       (lambda () (display file)))
-		     file)))
-(unless (string=? file expect)
-  (error "generated file does not match expected file"))