From 75a60162b0f173d19d6ac5bd3d4c3b434c9243e4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 6 Feb 2010 17:13:49 +0000 Subject: [PATCH] another attempt to get the drscheme gui test suite in shape to be run by drdr svn: r18004 --- collects/tests/drscheme/drscheme-test-util.ss | 44 ++++++--- collects/tests/drscheme/io.ss | 27 +++--- collects/tests/drscheme/language-test.ss | 5 +- .../tests/drscheme/module-lang-test-utils.ss | 1 - collects/tests/drscheme/module-lang-test.ss | 13 +-- collects/tests/drscheme/repl-test.ss | 92 +++++++++---------- collects/tests/drscheme/run.sh | 7 ++ collects/tests/drscheme/syncheck-test.ss | 37 +++----- collects/tests/drscheme/teachpack.ss | 5 +- 9 files changed, 115 insertions(+), 116 deletions(-) create mode 100644 collects/tests/drscheme/run.sh diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index d529b5a917..f140b7772f 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -11,7 +11,7 @@ [use-get/put-dialog (-> (-> any) path? void?)] [set-module-language! (->* () (boolean?) void?)]) - (provide fire-up-drscheme + (provide fire-up-drscheme-and-run-tests save-drscheme-window-as do-execute test-util-error @@ -622,13 +622,35 @@ ;; but just to print and return. (define orig-display-handler (error-display-handler)) - (define (fire-up-drscheme) - (dynamic-require 'drscheme #f) - - ;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it) - (uncaught-exception-handler - (λ (x) - (if (exn? x) - (orig-display-handler (exn-message x) x) - (fprintf (current-error-port) "uncaught exception ~s\n" x)) - (exit 1)))) \ No newline at end of file + (define (fire-up-drscheme-and-run-tests run-test) + (let () + ;; change the preferences system so that it doesn't write to + ;; a file; partly to avoid problems of concurrency in drdr + ;; but also to make the test suite easier for everyone to run. + (let ([prefs-table (make-hash)]) + (fw:preferences:low-level-put-preferences + (lambda (names vals) + (for-each (lambda (name val) (hash-set! prefs-table name val)) + names vals))) + (fw:preferences:low-level-get-preference + (lambda (name [fail (lambda () #f)]) + (hash-ref prefs-table name fail)))) + + (dynamic-require 'drscheme #f) + + ;; set all preferences to their defaults (some pref values may have + ;; been read by this point, but hopefully that won't affect much + ;; of the startup of drscheme) + (fw:preferences:restore-defaults) + + (thread (λ () + (let ([orig-display-handler (error-display-handler)]) + (uncaught-exception-handler + (λ (x) + (if (exn? x) + (orig-display-handler (exn-message x) x) + (fprintf (current-error-port) "uncaught exception ~s\n" x)) + (exit 1)))) + (run-test) + (exit))) + (yield (make-semaphore 0)))) \ No newline at end of file diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss index 442550537d..8665a42459 100644 --- a/collects/tests/drscheme/io.ss +++ b/collects/tests/drscheme/io.ss @@ -183,20 +183,15 @@ add this test: (define drs-frame #f) (define interactions-text #f) -(let ([s (make-semaphore)]) - (fire-up-drscheme) - (thread - (λ () - (set! drs-frame (wait-for-drscheme-frame)) - (set! interactions-text (send drs-frame get-interactions-text)) - (set-language-level! (list #rx"Pretty Big")) - (clear-definitions drs-frame) - (do-execute drs-frame) - - (output-err-port-checking) ;; must come first - ;(long-io/execute-test) - (reading-test) - (semaphore-post s))) - (yield s) - (exit)) +(fire-up-drscheme-and-run-tests + (λ () + (set! drs-frame (wait-for-drscheme-frame)) + (set! interactions-text (send drs-frame get-interactions-text)) + (set-language-level! (list #rx"Pretty Big")) + (clear-definitions drs-frame) + (do-execute drs-frame) + + (output-err-port-checking) ;; must come first + ;;(long-io/execute-test) + (reading-test))) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 11bc5c7c69..cfed7e29c8 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -1352,7 +1352,4 @@ the settings above should match r5rs (go pretty-big) (go r5rs)) -(let () - (fire-up-drscheme) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore))) \ No newline at end of file +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drscheme/module-lang-test-utils.ss b/collects/tests/drscheme/module-lang-test-utils.ss index af9295d51e..4dc6289b12 100644 --- a/collects/tests/drscheme/module-lang-test-utils.ss +++ b/collects/tests/drscheme/module-lang-test-utils.ss @@ -129,7 +129,6 @@ error-ranges-expected (send interactions-text get-error-ranges))))]))))) - (define drs 'not-yet-drs-frame) (define interactions-text 'not-yet-interactions-text) (define definitions-text 'not-yet-definitions-text) diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index 83bbecea9f..7b9dc8a5ee 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -141,7 +141,7 @@ (provide s) (define-syntax (s stx) e))} @t{(require m) s} - @rx{module-lang-test-tmp2.ss:1:[67][90]: compile: bad syntax; + @rx{compile: bad syntax; literal data is not allowed, because no #%datum syntax transformer is bound in: 1$}) (test @t{(module tmp mzscheme @@ -247,11 +247,7 @@ f (f) -- - #t - #:error-ranges - (λ (defs ints) - (list (make-srcloc ints 3 3 107 1) - (make-srcloc ints 3 2 106 3)))) + #t) ;; test protection against user-code changing the namespace (test @t{#lang scheme/base @@ -265,7 +261,4 @@ (require "drscheme-test-util.ss") -(let () - (fire-up-drscheme) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore 0))) \ No newline at end of file +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 874ddeed0e..c2dfb6d793 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -73,7 +73,7 @@ This produces an ACK message backtrace-image-string " " file-image-string - " ../../mred/private/snipfile.ss:")) + " .*mred/private/snipfile.ss:")) "[0-9]+:[0-9]+: " (regexp-quote str)))) @@ -190,8 +190,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -266,8 +266,8 @@ This produces an ACK message "define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+") 'interactions #f void @@ -305,8 +305,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:7: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -350,8 +350,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -417,8 +417,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" "reference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") 'definitions #f void @@ -457,8 +457,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: expt: expected argument of type ; given #" "expt: expected argument of type ; given #" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #") 'definitions #f void @@ -507,8 +507,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" "1\n2\nreference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x") 'definitions #f void @@ -620,8 +620,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f\n15" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:5:19: expt: expected argument of type ; given #f\n15" "expt: expected argument of type ; given #f\n15" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15") 'definitions #f void @@ -644,12 +644,12 @@ This produces an ACK message ;; should produce a syntax object with a turn-down triangle. (mktest "(write (list (syntax x)))" - (#rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})" - #rx"({embedded \".#\"})") + (#rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})" + #rx"({embedded \".#\"})") 'interactions #f void @@ -685,12 +685,12 @@ This produces an ACK message (mktest "(parameterize ([current-output-port (open-output-string)]) (fprintf (current-error-port) \"~e\" #'foot))" - (#rx"#" - #rx"#" - #rx"#" - #rx"#" - #rx"#" - #rx"#") + (#rx"#" + #rx"#" + #rx"#" + #rx"#" + #rx"#" + #rx"#") 'interactions #f void @@ -719,8 +719,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} expt: expected argument of type ; given #f" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:6:15: expt: expected argument of type ; given #f" "expt: expected argument of type ; given #f" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f") 'definitions #f void @@ -796,8 +796,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3" "procedure application: expected procedure, given: 3; arguments were: 3" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: procedure application: expected procedure, given: 3; arguments were: 3") 'definitions #f void @@ -898,8 +898,8 @@ This produces an ACK message "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" "reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" - #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx" + #rx"{stop-multi.png} {stop-22x22.png} .*mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx") 'definitions #f void @@ -1069,7 +1069,8 @@ This produces an ACK message (define backtrace-image-string "{stop-multi.png}") (define file-image-string "{stop-22x22.png}") -(define tmp-load-directory +(define tmp-load-directory (find-system-path 'temp-dir) + #; (normal-case-path (normalize-path (collection-path "tests" "drscheme")))) @@ -1080,8 +1081,6 @@ This produces an ACK message (define tmp-load3-short-filename "repl-test-tmp3.ss") (define tmp-load3-filename (build-path tmp-load-directory tmp-load3-short-filename)) -tmp-load-filename - (define (cleanup-tmp-files) (when (file-exists? tmp-load-filename) (delete-file tmp-load-filename)) (when (file-exists? tmp-load3-filename) (delete-file tmp-load3-filename))) @@ -1515,13 +1514,10 @@ tmp-load-filename (string-append a b))) -(let () - (fire-up-drscheme) - (wait-for-drscheme-frame) ;; after this point, it is safe to set the exit handler - (exit-handler - (let ([eh (exit-handler)]) - (λ (val) - (cleanup-tmp-files) - (eh val)))) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore 0))) +(exit-handler + (let ([eh (exit-handler)]) + (λ (val) + (cleanup-tmp-files) + (eh val)))) + +(fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drscheme/run.sh b/collects/tests/drscheme/run.sh new file mode 100644 index 0000000000..1f8cefae07 --- /dev/null +++ b/collects/tests/drscheme/run.sh @@ -0,0 +1,7 @@ +#!/bin/sh -x +mred module-lang-test.ss && +mred repl-test.ss && +mred io.ss && +mred language-test.ss && +mred syncheck-test.ss && +mred teachpack.ss diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index 18a0555c03..82b016b909 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -849,28 +849,21 @@ trigger runtime errors in check syntax. (list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) (define (main) - (let ([s (make-semaphore 0)]) - (thread - (λ () - (let ([drs (wait-for-drscheme-frame)]) - (set-language-level! (list "Pretty Big")) - (do-execute drs) - (let* ([defs (send drs get-definitions-text)] - [filename (make-temporary-file "syncheck-test~a")]) - (let-values ([(dir _1 _2) (split-path filename)]) - (send defs save-file filename) - (preferences:set 'framework:coloring-active #f) - (for-each (run-one-test (normalize-path dir)) tests) - (preferences:set 'framework:coloring-active #t) - (send defs save-file) ;; clear out autosave - (send defs set-filename #f) - (delete-file filename) - ;; let the app die. - (semaphore-post s)))))) - (fire-up-drscheme) - (yield s) - (printf "Tests complete.\n") - (exit))) + (fire-up-drscheme-and-run-tests + (λ () + (let ([drs (wait-for-drscheme-frame)]) + (set-language-level! (list "Pretty Big")) + (do-execute drs) + (let* ([defs (send drs get-definitions-text)] + [filename (make-temporary-file "syncheck-test~a")]) + (let-values ([(dir _1 _2) (split-path filename)]) + (send defs save-file filename) + (preferences:set 'framework:coloring-active #f) + (for-each (run-one-test (normalize-path dir)) tests) + (preferences:set 'framework:coloring-active #t) + (send defs save-file) ;; clear out autosave + (send defs set-filename #f) + (delete-file filename))))))) (define ((run-one-test save-dir) test) (let* ([drs (wait-for-drscheme-frame)] diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index 3e03dc5ff4..57417db162 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -238,7 +238,4 @@ ;(bad-tests) (test-built-in-teachpacks)) -(let () - (fire-up-drscheme) - (thread (λ () (run-test) (exit))) - (yield (make-semaphore))) +(fire-up-drscheme-and-run-tests run-test)