diff --git a/collects/tests/mred/blits.ss b/collects/tests/mred/blits.ss index 24afdc4bc9..570840af9e 100644 --- a/collects/tests/mred/blits.ss +++ b/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") )) diff --git a/collects/tests/mred/frame-edit.ss b/collects/tests/mred/frame-edit.ss deleted file mode 100644 index 5add33ddd8..0000000000 --- a/collects/tests/mred/frame-edit.ss +++ /dev/null @@ -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) diff --git a/collects/tests/mred/gui-main.ss b/collects/tests/mred/gui-main.ss index 588b125d0f..7ce14b6fa8 100644 --- a/collects/tests/mred/gui-main.ss +++ b/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 diff --git a/collects/tests/mred/imred.ss b/collects/tests/mred/imred.ss deleted file mode 100644 index f7bda4aeaf..0000000000 --- a/collects/tests/mred/imred.ss +++ /dev/null @@ -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))) diff --git a/collects/tests/mred/mediastream.ss b/collects/tests/mred/mediastream.ss deleted file mode 100644 index a4c8a261c8..0000000000 --- a/collects/tests/mred/mediastream.ss +++ /dev/null @@ -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"))