From 82ec65680dc458f2bfc22699c9318c971ef63b4d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 7 May 2007 01:30:32 +0000 Subject: [PATCH] fixed up some of the old tests svn: r6165 --- collects/tests/framework/frame.ss | 19 -------------- collects/tests/framework/group-test.ss | 19 ++++++++------ collects/tests/framework/load.ss | 36 ++++++++------------------ 3 files changed, 22 insertions(+), 52 deletions(-) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index 22ecfcc8a1..3debb4e400 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -145,23 +145,4 @@ (test-open "frame:searchable open" 'frame:searchable%) (test-open "frame:text open" 'frame:text%) - - ;; test to be sure that shutting down one frame doesn't kill others - (test - "custodian shutdown old frame" - (lambda (x) (eq? 'passed x)) - (lambda () - (send-sexp-to-mred - `(let ([c (make-custodian)]) - (parameterize ((current-custodian c)) - (parameterize ((current-eventspace (make-eventspace))) - (send (new frame:basic% (label "to be shutdown")) - show #t))) - (custodian-shutdown-all c) - (send (new frame:basic% (label "after shutdown")) show #t))) - (wait-for-frame "after shutdown") - (queue-sexp-to-mred - '(send (get-top-level-focus-window) close)) - 'passed)) - ) diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss index 7a5e91107b..d4bbac720d 100644 --- a/collects/tests/framework/group-test.ss +++ b/collects/tests/framework/group-test.ss @@ -1,5 +1,12 @@ (module group-test mzscheme (require "test-suite-utils.ss") + + (define windows-menu-prefix + (let ([basics (list "Bring Frame to Front..." "Most Recent Window" + #f)]) + (if (eq? (system-type) 'macosx) + (list* "Minimize" "Zoom" #f basics) + basics))) (test 'exit-on @@ -75,8 +82,7 @@ (test 'windows-menu (lambda (x) - (equal? x (list "Bring Frame to Front..." "Most Recent Window" - #f "first" "test"))) + (equal? x (append windows-menu-prefix (list "first" "test")))) (lambda () (send-sexp-to-mred '(let ([frame (make-object frame:basic% "test")]) @@ -92,8 +98,7 @@ (test 'windows-menu-unshown (lambda (x) - (equal? x (list "Bring Frame to Front..." "Most Recent Window" - #f "first" "test"))) + (equal? x (append windows-menu-prefix (list "first" "test")))) (lambda () (send-sexp-to-mred '(let ([frame1 (make-object frame:basic% "test")] @@ -110,8 +115,7 @@ (test 'windows-menu-sorted1 (lambda (x) - (equal? x (list "Bring Frame to Front..." "Most Recent Window" - #f "aaa" "bbb" "first"))) + (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (lambda () (send-sexp-to-mred '(let ([frame (make-object frame:basic% "aaa")]) @@ -135,8 +139,7 @@ (test 'windows-menu-sorted2 (lambda (x) - (equal? x (list "Bring Frame to Front..." "Most Recent Window" - #f "aaa" "bbb" "first"))) + (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (lambda () (send-sexp-to-mred '(let ([frame (make-object frame:basic% "bbb")]) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index 56d1dbc543..34fb5ad708 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -26,8 +26,8 @@ (test/load "gui-utils.ss" 'gui-utils:next-untitled-name) (test/load "test.ss" 'test:run-interval) (test/load "splash.ss" 'start-splash) - (test/load "framework-sig.ss" '(begin (eval '(require (lib "unitsig.ss"))) - (eval '(define-signature dummy-signature^ framework^)))) + (test/load "framework-sig.ss" '(begin (eval '(require (lib "unit.ss"))) + (eval '(define-signature dummy-signature^ ((open framework^)))))) (test/load "framework-unit.ss" 'framework@) (test/load "framework.ss" '(list test:button-push gui-utils:next-untitled-name @@ -39,27 +39,13 @@ "framework.ss" ;; these extra evals let me submit multiple, independent top-level ;; expressions in the newly created namespace. - '(begin (eval '(require (lib "unitsig.ss"))) + '(begin (eval '(require (lib "unit.ss"))) + (eval '(require-for-syntax (lib "unit-exptime.ss"))) + (eval '(define-syntax (signature->symbols stx) + (syntax-case stx () + [(_ sig) + (let-values ([(_1 eles _2 _3) (signature-members #'sig #'whatever)]) + (with-syntax ([eles eles]) + #''eles))]))) (eval '(require (lib "framework-sig.ss" "framework"))) - (eval '(letrec ([prepend-symbol - (lambda (s1) - (lambda (s2) - (string->symbol - (string-append - (symbol->string s1) - ":" - (symbol->string s2)))))] - ;; exp-sig = (union (vectorof exp-sig) - ;; (cons sym exp-sig) - ;; symbol) - [flatten ;; : exp-sig -> (listof symbol) - (lambda (l) - (cond - [(vector? l) - (apply append (map flatten (vector->list l)))] - [(pair? l) - (map (prepend-symbol (car l)) (flatten (cdr l)))] - [(symbol? l) (list l)] - [else (error 'flatten "unk: ~e" l)]))] - [names (flatten (signature->symbols framework^))]) - (for-each eval names)))))) + (eval '(for-each eval (signature->symbols framework^))))))