diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index 162ba651..b6fdf2d3 100644 --- a/collects/framework/editor.ss +++ b/collects/framework/editor.ss @@ -156,13 +156,11 @@ (lambda (x) (set! is-locked? x) (super-lock x))] - ;[on-new-box - ; (lambda (type) - ; (cond - ; [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] - ; [else (make-object editor-snip% (make-object pasteboard:basic%))]))] - ;; need a snipclass to handle copying/pasting. This isn't enough. - ) + [on-new-box + (lambda (type) + (cond + [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] + [else (make-object editor-snip% (make-object pasteboard:basic%))]))]) (override diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 5ac5ffb3..66ce6844 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -50,6 +50,7 @@ class class* class-asi class-asi* define-some do opt-lambda send* local catch shared + make-object unit/sig with-handlers interface diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss index 942e2b29..914f67a8 100644 --- a/collects/tests/framework/group-test.ss +++ b/collects/tests/framework/group-test.ss @@ -4,6 +4,7 @@ (lambda () (send-sexp-to-mred '(begin (send (make-object frame:basic% "test") show #t) + (preferences:set 'framework:verify-exit #f) (preferences:set 'framework:exit-when-no-frames #f))) (wait-for-frame "test") (send-sexp-to-mred @@ -18,6 +19,7 @@ (lambda () (send-sexp-to-mred '(begin (send (make-object frame:basic% "test") show #t) + (preferences:set 'framework:verify-exit #t) (preferences:set 'framework:exit-when-no-frames #t))) (wait-for-frame "test") (send-sexp-to-mred diff --git a/collects/tests/framework/handler-test.ss b/collects/tests/framework/handler-test.ss index b7e56a60..f5b5b534 100644 --- a/collects/tests/framework/handler-test.ss +++ b/collects/tests/framework/handler-test.ss @@ -10,19 +10,8 @@ (void))) (wait-for-frame filename) (send-sexp-to-mred - `(map (lambda (x) (send x get-label)) (get-top-level-windows))))) - - (test - 'file-opened - (lambda (x) (equal? filename x)) - (lambda () - (send-sexp-to-mred - `(begin (handler:edit-file ,tmp-filename) - (void))) - (wait-for-frame filename) - (send-sexp-to-mred - `(let ([f (car (get-top-level-windows))]) - (send (send f get-editor) get-filename))))) + `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows)) + (send (car (get-top-level-windows)) close))))) (test 'files-opened-twice @@ -37,4 +26,17 @@ (void))) (wait-for-frame filename) (send-sexp-to-mred - `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))) \ No newline at end of file + `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows)) + (send (car (get-top-level-windows)) close))))) + + (test + 'file-opened-in-editor + (lambda (x) (equal? filename x)) + (lambda () + (send-sexp-to-mred + `(begin (handler:edit-file ,tmp-filename) + (void))) + (wait-for-frame filename) + (send-sexp-to-mred + `(let ([f (car (get-top-level-windows))]) + (send (send f get-editor) get-filename)))))) \ No newline at end of file diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index 95dd771f..3ad44dc9 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -23,7 +23,8 @@ (require-library "tests.ss" "framework") (require-library "mred-interfaces.ss" "framework") (eval - '(invoke-open-unit/sig + '(define-values/invoke-unit/sig + ((unit test : framework:test^)) (compound-unit/sig (import) (link [mred : mred-interfaces^ (mred-interfaces@)] @@ -60,13 +61,14 @@ 'mred-interfaces.ss/gen (lambda (x) x) '(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "invoke.ss") (require-library "mred-interfaces.ss" "framework") (eval - '(let ([orig-button% (global-defined-value 'button%)]) - (invoke-open-unit/sig mred-interfaces@) - (let ([first-button% (global-defined-value 'button%)]) - (invoke-open-unit/sig mred-interfaces@) - (let ([second-button% (global-defined-value 'button%)]) + '(let ([orig-button% button%]) + (define-values/invoke-unit/sig mred-interfaces^ mred-interfaces@) + (let ([first-button% button%]) + (define-values/invoke-unit/sig mred-interfaces^ mred-interfaces@) + (let ([second-button% button%]) (and (eq? second-button% first-button%) (not (eq? first-button% orig-button%))))))))) (test @@ -76,7 +78,8 @@ (require-library "frameworks.ss" "framework") (require-library "mred-interfaces.ss" "framework") (eval - '(invoke-open-unit/sig + '(define-values/invoke-unit/sig + framework^ (compound-unit/sig (import) (link [mred : mred-interfaces^ (mred-interfaces@)] diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 10074b87..451dc435 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -299,10 +299,10 @@ (when (file-exists? preferences-file) (printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) - (when (file-exists? old-preferences-file) - (error 'framework-test "backup preferences file exists, aborting")) - (printf " saved preferences file~n") - (copy-file preferences-file old-preferences-file)) + (if (file-exists? old-preferences-file) + (printf " backup preferences file exists, using that one~n") + (begin (copy-file preferences-file old-preferences-file) + (printf " saved preferences file~n")))) (for-each (lambda (x) (when (member x all-files) diff --git a/collects/tests/utils/gui.ss b/collects/tests/utils/gui.ss index 694ec766..dc607171 100644 --- a/collects/tests/utils/gui.ss +++ b/collects/tests/utils/gui.ss @@ -1,4 +1,6 @@ (require-library "guis.ss" "tests" "utils") -(invoke-open-unit/sig - (require-library "guir.ss" "tests" "utils") #f mred^) \ No newline at end of file +(define-values/invoke-unit/sig test-utils:gui^ + (require-library "guir.ss" "tests" "utils") + #f + mred^) \ No newline at end of file