From 3c5f2c7395bb13b03d134772a64aadd75a6844f0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 8 May 2007 01:02:40 +0000 Subject: [PATCH] fixed up minor bugs in program and lots of little problems in the test suites svn: r6173 --- collects/drscheme/syncheck.ss | 13 ++- collects/framework/framework.ss | 8 ++ collects/tests/drscheme/README | 5 - collects/tests/drscheme/io.ss | 7 +- collects/tests/drscheme/language-test.ss | 33 +++--- collects/tests/drscheme/repl-test.ss | 4 +- collects/tests/drscheme/stepper-test.ss | 32 ++++-- collects/tests/drscheme/syncheck-test.ss | 124 ++++++++++++---------- collects/tests/drscheme/teachpack.ss | 44 ++++---- collects/tests/drscheme/test-box-test.ss | 129 ----------------------- collects/tests/framework/load.ss | 1 + 11 files changed, 157 insertions(+), 243 deletions(-) delete mode 100644 collects/tests/drscheme/test-box-test.ss diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 34bc0983f2..96369677c5 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -2145,13 +2145,12 @@ If the namespace does not, they are colored the unbound color. ;; if someone just types `(λ (x) x)' it has no 'origin ;; field, but there still are keywords. (define (annotate-raw-keyword stx id-map) - (unless (syntax-property stx 'origin) - (let ([lst (syntax-e stx)]) - (when (pair? lst) - (let ([f-stx (car lst)]) - (when (and (syntax-original? f-stx) - (identifier? f-stx)) - (add-id id-map f-stx))))))) + (let ([lst (syntax-e stx)]) + (when (pair? lst) + (let ([f-stx (car lst)]) + (when (and (syntax-original? f-stx) + (identifier? f-stx)) + (add-id id-map f-stx)))))) ;; color-internal-structure : syntax str -> void (define (color-internal-structure stx style-name) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 950af34a46..7d61167114 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -118,6 +118,14 @@ "the second case in the case-lambda sets" "the name of the application to \\var{name}.") + (preferences:put-preferences/gui + (-> (listof symbol?) + (listof any/c) + any) + (name-list val-list) + "Like \\scheme{put-preferences}, but passes along" + "a \\var{locked-proc} that asks the user if they want to" + "try again.") (preferences:add-panel ((or/c string? (cons/c string? (listof string?))) ((is-a?/c area-container-window<%>) diff --git a/collects/tests/drscheme/README b/collects/tests/drscheme/README index fd6223358e..5f39521c7b 100644 --- a/collects/tests/drscheme/README +++ b/collects/tests/drscheme/README @@ -50,9 +50,4 @@ the function, all tests will be run. |# syncheck-test.ss #| -|# test-box-test.ss #| - - Test test boxes. - - |#) diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss index 27f0366177..03ef785834 100644 --- a/collects/tests/drscheme/io.ss +++ b/collects/tests/drscheme/io.ss @@ -55,15 +55,16 @@ add this test: (send text paragraph-start-position 2)))))) (channel-get chan))) - (define (output-style x) (equal? (list-ref x 9) '(150 0 150))) - (define (error-style x) (equal? (list-ref x 9) '(255 0 0))) + (define (output-style x) (eq? x '|ports out|)) + (define (error-style x) (eq? x '|ports err|)) + (define (value-style x) (eq? x '|ports value|)) (define prompt '("\n> " default-color)) ;; this test has to be first to test an uninitialized state of the port ;; NOTE: missing a name for the "value" style ... so this test appears to fail (altho it actually passes) (check-output "(port-next-location (current-input-port))" - (list '("1\n0\n1\n" value-style) + (list `("1\n0\n1\n" ,value-style) prompt)) (check-output "(display 1)" (list (list "1" output-style) prompt)) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 139c7b0fbf..09cc3f0695 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -258,7 +258,8 @@ the settings above should match r5rs (test-expression "(define x 1)(define x 2)" "") (test-expression "(define-struct spider (legs))(make-spider 4)" - "{bug09.png} reference to undefined identifier: define-struct") + "{bug09.png} reference to undefined identifier: define-struct" + "{bug09.png} reference to undefined identifier: define-struct\n{bug09.png} reference to undefined identifier: make-spider") (test-expression "(sqrt -1)" "0+1i") @@ -358,7 +359,7 @@ the settings above should match r5rs (test-expression "(define-struct spider (legs))(make-spider 4)" "(make-spider 4)" - "define-struct: cannot redefine name: spider") + "define-struct: cannot redefine name: spider\n(make-spider 4)") (test-expression "(sqrt -1)" "0+1i") @@ -403,7 +404,7 @@ the settings above should match r5rs (test-expression "'(1)" "quote: expected a name after a ', found something else") (test-expression "(define shrd (list 1)) (list shrd shrd)" "(cons (cons 1 empty) (cons (cons 1 empty) empty))" - "define: cannot redefine name: shrd") + "define: cannot redefine name: shrd\n(cons (cons 1 empty) (cons (cons 1 empty) empty))") (test-expression "(local ((define x x)) 1)" "local: name is not defined, not an argument, and not a primitive name" "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") @@ -482,7 +483,7 @@ the settings above should match r5rs (test-expression "(define-struct spider (legs))(make-spider 4)" "(make-spider 4)" - "define-struct: cannot redefine name: spider") + "define-struct: cannot redefine name: spider\n(make-spider 4)") (test-expression "(sqrt -1)" "0+1i") @@ -525,7 +526,7 @@ the settings above should match r5rs (test-expression "'(1)" "(list 1)") (test-expression "(define shrd (list 1)) (list shrd shrd)" "(list (list 1) (list 1))" - "define: cannot redefine name: shrd") + "define: cannot redefine name: shrd\n(list (list 1) (list 1))") (test-expression "(local ((define x x)) 1)" "local: name is not defined, not an argument, and not a primitive name" "function call: expected a defined name or a primitive operation name after an open parenthesis, but found something else") @@ -602,7 +603,7 @@ the settings above should match r5rs (test-expression "(define-struct spider (legs))(make-spider 4)" "(make-spider 4)" - "define-struct: cannot redefine name: spider") + "define-struct: cannot redefine name: spider\n(make-spider 4)") (test-expression "(sqrt -1)" "0+1i") @@ -644,7 +645,7 @@ the settings above should match r5rs (test-expression "'(1)" "(list 1)") (test-expression "(define shrd (list 1)) (list shrd shrd)" "(list (list 1) (list 1))" - "define: cannot redefine name: shrd") + "define: cannot redefine name: shrd\n(list (list 1) (list 1))") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") @@ -714,7 +715,7 @@ the settings above should match r5rs (test-expression "(define-struct spider (legs))(make-spider 4)" "(make-spider 4)" - "define-struct: cannot redefine name: spider") + "define-struct: cannot redefine name: spider\n(make-spider 4)") (test-expression "(sqrt -1)" "0+1i") @@ -756,7 +757,7 @@ the settings above should match r5rs (test-expression "'(1)" "(list 1)") (test-expression "(define shrd (list 1)) (list shrd shrd)" "(list (list 1) (list 1))" - "define: cannot redefine name: shrd") + "define: cannot redefine name: shrd\n(list (list 1) (list 1))") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") @@ -825,7 +826,7 @@ the settings above should match r5rs (test-expression "(define-struct spider (legs))(make-spider 4)" "(make-spider 4)" - "define-struct: cannot redefine name: spider") + "define-struct: cannot redefine name: spider\n(make-spider 4)") (test-expression "(sqrt -1)" "0+1i") @@ -858,13 +859,15 @@ the settings above should match r5rs (test-expression "(set! x 1)" "x: name is not defined" "set!: cannot set undefined identifier: x") - (test-expression "(define qqq 2) (set! qqq 1)" "(void)" "define: cannot redefine name: qqq") + (test-expression "(define qqq 2) (set! qqq 1)" + "(void)" + "define: cannot redefine name: qqq\n(void)") (test-expression "(cond [(= 1 2) 3])" "cond: all question results were false") (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") (test-expression "'(1)" "(list 1)") (test-expression "(define shrd (list 1)) (list shrd shrd)" "(shared ((-1- (list 1))) (list -1- -1-))" - "define: cannot redefine name: shrd") + "define: cannot redefine name: shrd\n(shared ((-1- (list 1))) (list -1- -1-))") (test-expression "(local ((define x x)) 1)" "local variable used before its definition: x") (test-expression "(letrec ([x x]) 1)" "local variable used before its definition: x") (test-expression "(if 1 1 1)" "if: question result is not true or false: 1") @@ -1222,9 +1225,9 @@ the settings above should match r5rs (define (run-test) ;(go mred) ;(go mzscheme) - ;(go beginner) ;; not really done - ;(go beginner/abbrev) ;; not really done - (go intermediate) + ;(go beginner) + ;(go beginner/abbrev) + ;(go intermediate) (go intermediate/lambda) (go advanced) (go r5rs))) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 84d0b4671c..4be912e7e3 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -878,7 +878,7 @@ ; directly, and second, we use the load command. We compare the ; the results of these operations against expected results. (define ((run-single-test execute-text-start escape raw?) in-vector) - (printf "\n>> testing ~s\n" (test-program in-vector)) + ;(printf "\n>> testing ~s\n" (test-program in-vector)) (let* ([program (test-program in-vector)] [execute-answer (if raw? (test-raw-execute-answer in-vector) @@ -1116,7 +1116,7 @@ (let* ([end (- (get-int-pos) 1)] [output (fetch-output drscheme-frame start end)] - [expected "{bug09.png} reference to undefined identifier: x"]) + [expected "reference to undefined identifier: x"]) (unless (equal? output expected) (error 'callcc-test "expected ~s, got ~s" expected output))))) diff --git a/collects/tests/drscheme/stepper-test.ss b/collects/tests/drscheme/stepper-test.ss index 917b5493b6..5c2b78299d 100644 --- a/collects/tests/drscheme/stepper-test.ss +++ b/collects/tests/drscheme/stepper-test.ss @@ -635,11 +635,22 @@ [after null] [snips snips]) + (define (die which when) + (printf "~a: didn't find ~s\n ~s\n ~s\n ~s\n ~s\n" which when + program + before + after + snips)) + (define (hunt-for-list id) (let loop () (cond - [(null? snips) (k #f)] - [(eq? 'unknown (car snips)) (k #f)] + [(null? snips) + (die 'hunt-for-list.1 id) + (k #f)] + [(eq? 'unknown (car snips)) + (die 'hunt-for-list.2 id) + (k #f)] [(list? (car snips)) (begin0 (car snips) (set! snips (cdr snips)))] @@ -648,8 +659,12 @@ (define (hunt-for-list/error id) (let loop () (cond - [(null? snips) (k #f)] - [(eq? 'unknown (car snips)) (k #f)] + [(null? snips) + (die 'hunt-for-list/error.1 id) + (k #f)] + [(eq? 'unknown (car snips)) + (die 'hunt-for-list/error.2 id) + (k #f)] [(or (err? (car snips)) (list? (car snips))) (begin0 (car snips) (set! snips (cdr snips)))] @@ -658,15 +673,16 @@ (define (hunt-for-unknown id) (let loop () (cond - [(null? snips) (k #f)] + [(null? snips) + (die 'hunt-for-unknown id) + (k #f)] [(eq? 'unknown (car snips)) (set! snips (cdr snips))] [else (set! snips (cdr snips)) (loop)]))) - (set! program (hunt-for-list 'program)) - (hunt-for-unknown 'before) + ;(set! program (hunt-for-list 'program)) (set! before (hunt-for-list 'before)) - (hunt-for-unknown 'after) + (hunt-for-unknown 'between) (set! after (hunt-for-list/error 'after)) (make-step program diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index 3ab06633ff..1f95c27d70 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -335,33 +335,33 @@ (build-test "(define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m x) (f x))" '(("(" default-color) - ("define-for-syntax" imported-identifier) + ("define-for-syntax" imported) (" (" default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") (" default-color) - ("define" imported-identifier) + ("define" imported) (" (" default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") " default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" (" default-color) - ("define-syntax" imported-identifier) + ("define-syntax" imported) (" (" default-color) - ("m" lexically-bound-identifier) + ("m" lexically-bound) (" " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") (" default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) ("))" default-color)) '(((20 21) (69 70)) ((22 23) (25 26)) @@ -371,35 +371,35 @@ (build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))" '(("(" default-color) - ("module" imported-identifier) + ("module" imported) (" m mzscheme (" default-color) - ("define-for-syntax" imported-identifier) + ("define-for-syntax" imported) (" (" default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") (" default-color) - ("define" imported-identifier) + ("define" imported) (" (" default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") " default-color) - ("x" lexically-bound-identifier) + ("x" lexically-bound) (") " default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" (" default-color) - ("define-syntax" imported-identifier) + ("define-syntax" imported) (" (" default-color) - ("m" lexically-bound-identifier) + ("m" lexically-bound) (" " default-color) - ("stx" lexically-bound-identifier) + ("stx" lexically-bound) (") (" default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" " default-color) - ("stx" lexically-bound-identifier) + ("stx" lexically-bound) (")))" default-color)) '(((10 18) (20 37) (48 54) (67 80)) ((39 40) (90 91)) @@ -605,7 +605,7 @@ (" " default-color) ("object%" lexically-bound-variable) (" " default-color) - ("this" imported-identifier) + ("this" imported) (")" default-color))) (build-test "(module m mzscheme (require (lib \"list.ss\")) foldl)" '(("(" default-color) @@ -646,8 +646,8 @@ ("foldl" imported-variable) (")" default-color)) (list '((10 18) (20 27)) - '((28 55) (73 80) (81 86)) - '((56 71) (73 80) (81 86)))) + '((28 55) (73 80)) + '((56 71) (81 86)))) (build-test "(module m mzscheme (require (only (lib \"list.ss\") foldr) (only (lib \"list.ss\") foldl)) foldl foldr)" '(("(" default-color) @@ -668,7 +668,7 @@ ("module" imported-syntax) (" m mzscheme (" default-color) ("require" imported-syntax) - ("(prefix x: mzscheme)) " default-color) + (" (prefix x: mzscheme)) " default-color) ("x:+" imported-variable) (" " default-color) ("+" imported-variable) @@ -707,44 +707,55 @@ '((62 63) (64 65) (68 69)))) - ;; the next two tests are new, complex ones that need to - ;; move to the bottom of the test file, when the rest of these - ;; tests are cleaned up. - ;; right now, there is a bug that causes lots of tests to fail for a stupid reason - (build-test "(module m mzscheme (define-syntax rename #f) (require (rename mzscheme ++ +)))" '(("(" default-color) - ("module" imported-identifier) + ("module" imported) (" m mzscheme (" default-color) - ("define-syntax" imported-identifier) + ("define-syntax" imported) (" " default-color) - ("rename" lexically-bound-identifier) + ("rename" lexically-bound) (" #f) (" default-color) - ("require" imported-identifier) + ("require" imported) (" (rename mzscheme ++ +)))" default-color)) - (list '((10 18) (20 33) (46 53)) - '((54 76) (20 33) (46 53)))) + (list '((10 18) (20 33) (46 53)))) (build-test "(module m mzscheme (define-syntax rename #f) (define f 1) (provide (rename f g)))" '(("(" default-color) - ("module" imported-identifier) + ("module" imported) (" m mzscheme (" default-color) - ("define-syntax" imported-identifier) + ("define-syntax" imported) (" " default-color) - ("rename" lexically-bound-identifier) + ("rename" lexically-bound) (" #f) (" default-color) - ("define" imported-identifier) + ("define" imported) (" " default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" 1) (" default-color) - ("provide" imported-identifier) + ("provide" imported) (" (rename " default-color) - ("f" lexically-bound-identifier) + ("f" lexically-bound) (" g)))" default-color)) (list '((10 18) (20 33) (46 52) (59 66)) '((53 54) (75 76)))) + (build-test "(module m mzscheme (require-for-syntax mzscheme) (require-for-template mzscheme) (quote-syntax +))" + '(("(" default-color) + ("module" imported) + (" m mzscheme (" default-color) + ("require-for-syntax" imported) + (" mzscheme) (" default-color) + ("require-for-template" imported) + (" mzscheme) (" default-color) + ("quote-syntax" imported) + (" +))" default-color)) + (list + '((71 79) (95 96)) + '((10 18) (20 38) (50 70) (82 94) (95 96)) + '((39 47) (95 96)))) + + + (make-dir-test "(module m mzscheme (require \"~a/list.ss\") foldl foldl)" '(("(" default-color) ("module" imported-syntax) @@ -816,10 +827,10 @@ (define remappings '((constant default-color) - (imported-syntax imported-identifier) - (imported-variable imported-identifier) - (lexically-bound-syntax lexically-bound-identifier) - (lexically-bound-variable lexically-bound-identifier))) + (imported-syntax imported) + (imported-variable imported) + (lexically-bound-syntax lexically-bound) + (lexically-bound-variable lexically-bound))) (define (collapse-and-rename expected) (let ([renamed @@ -842,7 +853,8 @@ (cddr ids))) (cons fst (loop (cdr ids)))))])))) - ;; compare-arrows : (listof (cons (list number number) (listof (list number number)))) + ;; compare-arrows : expression + ;; (listof (cons (list number number) (listof (list number number)))) ;; hash-table[(list text number number) -o> (listof (list text number number))] ;; -> void (define (compare-arrows test-exp expected raw-actual) diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index 49da3ee9a8..4f7cc08237 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -158,10 +158,8 @@ "3")) (define (good-tests) - (set-language-level! `("PLT" ,(regexp "Graphical"))) - (generic-tests) - (set-language-level! '("How to Design Programs" "Beginning Student")) + (do-execute drs-frame) (generic-tests)) (define (bad-tests) @@ -196,29 +194,39 @@ (when (or (equal? #"ss" (filename-extension teachpack)) (equal? #"scm" (filename-extension teachpack))) (unless (equal? "graphing.ss" (path->string teachpack)) - (printf " testing ~a~n" (build-path dir teachpack)) - (let ([filename (normal-case-path (build-path dir teachpack))]) - (fw:test:menu-select "Language" "Clear All Teachpacks") - (use-get/put-dialog - (lambda () - (fw:test:menu-select "Language" "Add Teachpack...")) - filename) - (do-execute drs-frame) - - (let ([got (fetch-output drs-frame)] - [expected (format "Teachpack: ~a.~n1" filename)]) - (unless (equal? got expected) - (printf "FAILED built in teachpack test: ~a~n" filename) - (printf " got: ~s~n expected: ~s~n" got expected))))))))] + (printf " testing ~a~n" teachpack) + (fw:test:menu-select "Language" "Clear All Teachpacks") + (fw:test:menu-select "Language" "Add Teachpack...") + (wait-for-new-frame drs-frame) + (let* ([tp-dialog (get-top-level-focus-window)] + [choice (find-leftmost-choice tp-dialog)]) + (fw:test:set-list-box! choice (path->string teachpack)) + (fw:test:button-push "OK") + (wait-for-new-frame tp-dialog)) + (do-execute drs-frame) + + (let ([got (fetch-output drs-frame)] + [expected (format "Teachpack: ~a.\n1" (path->string teachpack))]) + (unless (equal? got expected) + (printf "FAILED built in teachpack test: ~a~n" (path->string teachpack)) + (printf " got: ~s~n expected: ~s~n" got expected)))))))] [test-teachpacks (lambda (dir) (for-each (test-teachpack dir) (directory-list dir)))] [teachpack-dir (normalize-path (collection-path "teachpack"))]) (set-language-level! '("How to Design Programs" "Advanced Student")) - (test-teachpacks teachpack-dir) + (do-execute drs-frame) (test-teachpacks (build-path teachpack-dir "htdp")))) + (define (find-leftmost-choice frame) + (let loop ([p frame]) + (cond + [(is-a? p list-box%) p] + [(is-a? p area-container<%>) + (ormap loop (send p get-children))] + [else #f]))) + (define (run-test) ;(good-tests) ;(bad-tests) diff --git a/collects/tests/drscheme/test-box-test.ss b/collects/tests/drscheme/test-box-test.ss deleted file mode 100644 index 32425ecca7..0000000000 --- a/collects/tests/drscheme/test-box-test.ss +++ /dev/null @@ -1,129 +0,0 @@ -(module test-box-test mzscheme - (require "drscheme-test-util.ss" - (lib "class.ss") - (lib "file.ss") - (lib "mred.ss" "mred") - (lib "framework.ss" "framework") - (rename (lib "teachprims.ss" "lang" "private") beginner-equal? beginner-equal?)) - - (provide run-test) - - (define (run-test) - - (define drscheme-frame (wait-for-drscheme-frame)) - - (define definitions-text (send drscheme-frame get-definitions-text)) - (define definitions-canvas (send drscheme-frame get-definitions-canvas)) - (define execute-button (send drscheme-frame get-execute-button)) - - (define (insert-string string) - (let loop ([n 0]) - (unless (= n (string-length string)) - (let ([c (string-ref string n)]) - (if (char=? c #\newline) - (test:keystroke #\return) - (test:keystroke c))) - (loop (+ n 1))))) - - (define wait-for-execute (lambda () (wait-for-button execute-button))) - - (define (get-test-box) - (send definitions-text find-snip (send definitions-text last-position) 'before)) - - (define (get-test-image fn) - (make-object - image-snip% - (make-object bitmap% (build-path (collection-path "test-suite" "private" "icons") fn)))) - - (define check-img (get-test-image "small-check-mark.jpeg")) - (define cross-img (get-test-image "small-cross.jpeg")) - (define non-img (get-test-image "small-empty.gif")) - - (define red-square (make-object image-snip% - (let* ([bm (make-object bitmap% 20 20)] - [dc (make-object bitmap-dc% bm)]) - (send dc set-brush "red" 'solid) - (send dc set-pen "red" 1 'solid) - (send dc draw-rectangle 0 0 20 20) - (send dc set-bitmap #f) - bm))) - - (define (same-img? a b) - (beginner-equal? a b)) - - (define (test-box-status s) - (let eloop ([e (send s get-editor)]) - (let sloop ([s (send e find-first-snip)]) - (and s - (or - (cond - [(s . is-a? . editor-snip%) - (eloop (send s get-editor))] - [(s . is-a? . image-snip%) - (cond - [(same-img? s check-img) 'pass] - [(same-img? s cross-img) 'fail] - [(same-img? s non-img) 'not-run] - [else #f])] - [else #f]) - (sloop (send s next))))))) - - (define (check-test-box-status v s) - (let ([u (test-box-status s)]) - (if (eq? v u) - (printf "~a - good\n" v) - (printf "FAILED: ~a != ~a\n" u v)))) - - - (define (try-test preamble expr expect result) - (test:new-window definitions-canvas) - (send definitions-text erase) - - (insert-string preamble) - - (test:menu-select "Special" "Insert Test Case") - - (insert-string expr) - (insert-string "\t") - (let loop ([expect expect]) - (cond - [(expect . is-a? . snip%) - (send (send drscheme-frame get-edit-target-object) insert (send expect copy))] - [(list? expect) - (for-each loop expect)] - [else - (insert-string expect)])) - - (check-test-box-status 'not-run (get-test-box)) - (do-execute drscheme-frame #t) - (check-test-box-status result (get-test-box))) - - (define scheme-languages - '(("How to Design Programs" "Beginning Student") - ("How to Design Programs" "Intermediate Student") - ("How to Design Programs" "Advanced Student") - ("PLT" #rx"Textual") - ("PLT" #rx"Graphical"))) - - (for-each (lambda (lang) - (set-language-level! lang #t) - - (try-test "" "(+ 1 2)" "3" 'pass) - (try-test "" "(+ 1 -2)" "3" 'fail) - (try-test "" "(list 1)" "(list 1)" 'pass) - (try-test "" "not-defined" "3" 'not-run) - (try-test "(define (f x) (+ x 1))" "(f 2)" "3" 'pass) - - (use-get/put-dialog - (lambda () - (test:menu-select "Language" "Add Teachpack...")) - (build-path (collection-path "mzlib") 'up 'up "teachpack" "htdp" "image.ss")) - (try-test "" "(rectangle 20 20 'solid \"red\")" "3" 'fail) - (try-test "" "(rectangle 20 20 'solid \"red\")" red-square 'pass) - (try-test "" "(list (rectangle 20 20 'solid \"red\") 17)" `("(list " ,red-square " 17)") 'pass) - (test:menu-select "Language" "Clear All Teachpacks") - - (void)) - scheme-languages) - - (void))) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss index 34fb5ad708..9a972a4088 100644 --- a/collects/tests/framework/load.ss +++ b/collects/tests/framework/load.ss @@ -40,6 +40,7 @@ ;; these extra evals let me submit multiple, independent top-level ;; expressions in the newly created namespace. '(begin (eval '(require (lib "unit.ss"))) + (eval '(require-for-syntax mzscheme)) (eval '(require-for-syntax (lib "unit-exptime.ss"))) (eval '(define-syntax (signature->symbols stx) (syntax-case stx ()