From bd0b8d9c9f2f8da262eb11ad5af0c9dd29bf32f5 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 6 Dec 2010 22:48:17 -0500 Subject: [PATCH] the Utah refactoring accidentally nested queue-callback; closes PR11500 --- collects/2htdp/private/world.rkt | 19 +++++------ collects/2htdp/tests/record.rkt | 2 +- collects/2htdp/tests/stop-when-crash.rkt | 42 ++++++++++++++++++++++++ collects/2htdp/tests/xtest | 36 ++++++++++---------- collects/2htdp/universe.rkt | 1 - 5 files changed, 71 insertions(+), 29 deletions(-) create mode 100644 collects/2htdp/tests/stop-when-crash.rkt diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 1bdc37a427..916be2ed3b 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -219,6 +219,7 @@ ;; responsiveness (where too many updates might not get ;; through if the canvas is mostly in suspended-refresh ;; mode for scene changes): + #; (send c flush))) ;; ---------------------------------------------------------------------- @@ -345,11 +346,13 @@ (stop! (if re-raise e (send world get))))) (define/public (start!) - (queue-callback - (lambda () - (with-handlers ([exn? (handler #t)]) - (when draw (show-canvas)) - (when register (register-with-host)))))) + (with-handlers ([exn? (handler #t)]) + (when draw (show-canvas)) + (when register (register-with-host)) + (define w (send world get)) + (cond + [(stop w) (stop! w)] + [(stop-the-world? w) (stop! (stop-the-world-world w))]))) (define/public (stop! w) (set! live #f) @@ -358,11 +361,7 @@ ;; ------------------------------------------------------------------------- ;; initialize the world and run (super-new) - (start!) - (let ([w (send world get)]) - (cond - [(stop w) (stop! w)] - [(stop-the-world? w) (stop! (stop-the-world-world w))])))))) + (start!))))) ; (define make-new-world (new-world world%)) diff --git a/collects/2htdp/tests/record.rkt b/collects/2htdp/tests/record.rkt index f22ca740f2..f4ab3b55df 100644 --- a/collects/2htdp/tests/record.rkt +++ b/collects/2htdp/tests/record.rkt @@ -37,5 +37,5 @@ (error 'record? "(~s, ~s) didn't record proper number of images: ~s" n dir number-of-png))) -(create-n-images 3 4 "images3/") +(create-n-images 3 3 "images3/") (create-n-images 0 0 "images0/") \ No newline at end of file diff --git a/collects/2htdp/tests/stop-when-crash.rkt b/collects/2htdp/tests/stop-when-crash.rkt new file mode 100644 index 0000000000..c4940c69d9 --- /dev/null +++ b/collects/2htdp/tests/stop-when-crash.rkt @@ -0,0 +1,42 @@ +#lang racket + +(require 2htdp/universe 2htdp/image) + +(with-handlers ((exn:fail? void)) + (big-bang 0 + (on-draw (λ _ (empty-scene 500 500))) + (stop-when (λ _ (car '()))))) + +#| ----------------------------------------------------------------------------- +(struct:object:...tdp/private/last.rkt:8:2 + `# + #(struct:object:checked-cell% ...) + #f + # + # + #f + 501 + 501 + # + # + #(struct:object:pasteboard% ...) + #f + # + #f + #f + # + #f + 0 + #f + #f + #f + # + #f + #f + #f + # + #f + # + 1 + # ...) +|# \ No newline at end of file diff --git a/collects/2htdp/tests/xtest b/collects/2htdp/tests/xtest index 842230dbcd..ca0208589e 100755 --- a/collects/2htdp/tests/xtest +++ b/collects/2htdp/tests/xtest @@ -1,37 +1,39 @@ #!/bin/tcsh gracket bad-draw.rkt -echo "--- bad-draw.rkt ---" echo "" +echo "done:--- bad-draw.rkt ---" echo "" racket batch-io.rkt -echo "--- batch-io.rkt ---" echo "" +echo "done:--- batch-io.rkt ---" echo "" gracket clause-once.rkt -echo "--- clause-once.rkt ---" echo "" +echo "done:--- clause-once.rkt ---" echo "" gracket full-scene-visible.rkt -echo "--- full-scene-visible.rkt ---" echo "" +echo "done:--- full-scene-visible.rkt ---" echo "" gracket image-equality-performance-htdp.rkt -echo "--- image-equality-performance-htdp.rkt ---" echo "" +echo "done:--- image-equality-performance-htdp.rkt ---" echo "" gracket image-equality-performance.rkt -echo "--- image-equality-performance.rkt ---" echo "" +echo "done:--- image-equality-performance.rkt ---" echo "" gracket mouse-evt.rkt -echo "--- mouse-evt.rkt ---" echo "" +echo "done:--- mouse-evt.rkt ---" echo "" gracket on-tick-defined.rkt -echo "--- on-tick-defined.rkt ---" echo "" +echo "done:--- on-tick-defined.rkt ---" echo "" gracket perform-robby.rkt -echo "--- perform-robby.rkt ---" echo "" +echo "done:--- perform-robby.rkt ---" echo "" gracket profile-robby.rkt -echo "--- profile-robby.rkt ---" echo "" +echo "done:--- profile-robby.rkt ---" echo "" gracket release.rkt -echo "--- release.rkt ---" echo "" +echo "done:--- release.rkt ---" echo "" gracket stop.rkt -echo "--- stop.rkt ---" echo "" +echo "done:--- stop.rkt ---" echo "" gracket test-image.rkt -echo "--- test-image.rkt ---" echo "" +echo "done:--- test-image.rkt ---" echo "" gracket ufo-rename.rkt -echo "--- ufo-rename.rkt ---" echo "" +echo "done:--- ufo-rename.rkt ---" echo "" gracket world0-stops.rkt - -echo "--- record.rkt ---" echo "" +echo "done:--- world0-stops.rkt ---" echo "" gracket record.rkt -echo "--- record-stop-when.rkt ---" echo "" +echo "done:--- record.rkt ---" echo "" gracket record-stop-when.rkt +echo "done:--- record-stop-when.rkt ---" echo "" +gracket stop-when-crash.rkt +echo "done:--- stop-when-crash.rkt ---" echo "" diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 791f5a68c3..b7b67b0065 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -341,4 +341,3 @@ (parameterize ([current-eventspace esp]) (queue-callback (lambda () (channel-put obj:ch (o))))) (send (channel-get obj:ch) last))) -