diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index a0ef109ea1..4e4f88c1b5 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -227,20 +227,24 @@ profile todo: (orig-error-display-handler msg exn)]))) debug-error-display-handler) + (define (print-bug-to-stderr msg cms) + (let ([note% (if (mf-bday?) mf-note% bug-note%)]) + (when note% + (let ([note (new note%)]) + (send note set-callback (λ () (show-backtrace-window msg cms))) + (write-special note (current-error-port)) + (display #\space (current-error-port)))))) + (define (show-error-and-highlight msg exn highlight-errors) - (let* ([cms (and (exn? exn) - (continuation-mark-set? (exn-continuation-marks exn)) - (continuation-mark-set->list - (exn-continuation-marks exn) - cm-key))]) + (let ([cms + (and (exn? exn) + (continuation-mark-set? (exn-continuation-marks exn)) + (continuation-mark-set->list + (exn-continuation-marks exn) + cm-key))]) (when (and cms (pair? cms)) - (let ([note% (if (mf-bday?) mf-note% bug-note%)]) - (when note% - (let ([note (new note%)]) - (send note set-callback (λ () (show-backtrace-window msg cms))) - (write-special note (current-error-port)) - (display #\space (current-error-port)))))) + (print-bug-to-stderr msg cms)) (let ([srcs-to-display (find-src-to-display exn cms)]) (for-each display-srcloc-in-error srcs-to-display) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 951dd0c352..f745bd654f 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -46,6 +46,7 @@ make-debug-error-display-handler/text make-debug-eval-handler hide-backtrace-window + print-bug-to-stderr profile-definitions-text-mixin profile-tab-mixin diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 55216987c5..b796429836 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -172,9 +172,25 @@ TODO ;; the highlight must be set after the error message, because inserting into the text resets ;; the highlighting. (define (drscheme-error-display-handler msg exn) - (let ([src-locs (if (exn:srclocs? exn) - ((exn:srclocs-accessor exn) exn) - '())]) + (let* ([srclocs-stack + (filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))] + [stack + (filter + values + (map (λ (srcloc) + (let ([source (srcloc-source srcloc)] + [pos (srcloc-position srcloc)] + [span (srcloc-span srcloc)]) + (and source pos span + (cons source (cons pos span))))) + srclocs-stack))] + [src-locs (if (exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn) + (if (null? stack) + '() + (list (car srclocs-stack))))]) + (unless (null? stack) + (drscheme:debug:print-bug-to-stderr msg stack)) (for-each drscheme:debug:display-srcloc-in-error src-locs) (display msg (current-error-port)) (when (exn:fail:syntax? exn) @@ -187,7 +203,9 @@ TODO (parameterize ([current-eventspace drscheme:init:system-eventspace]) (queue-callback (λ () - (send rep highlight-errors/exn exn)))))))) + (send rep highlight-errors + src-locs + (filter (λ (x) (is-a? (car x) text%)) stack))))))))) ;; drscheme-error-value->string-handler : TST number -> string (define (drscheme-error-value->string-handler x n) diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index 9b4bc5940a..8404aea2e2 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -2,8 +2,7 @@ ;; Fri Dec 9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw ;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now (module world mzscheme - (require ; (lib "unitsig.ss") - (lib "etc.ss") + (require (lib "class.ss") (lib "mred.ss" "mred") (lib "error.ss" "htdp") diff --git a/collects/make/make-unit.ss b/collects/make/make-unit.ss index f79ec3bf3f..b2080b6786 100644 --- a/collects/make/make-unit.ss +++ b/collects/make/make-unit.ss @@ -99,7 +99,8 @@ (when (and (make-print-checking) (or line (make-print-dep-no-line))) - (printf "make: ~achecking ~a~n" indent s)) + (printf "make: ~achecking ~a~n" indent s) + (flush-output)) (if line (let ([deps (cadr line)]) @@ -134,6 +135,7 @@ (format " because (reason: ~a date: ~a)" reason date))]) "")) + (flush-output) (with-handlers ([exn:fail? (lambda (exn) (raise (make-exn:fail:make @@ -161,7 +163,8 @@ (for-each (lambda (item) (printf "make: made ~a~n" (path-string->string item))) - (reverse made)))) + (reverse made)) + (flush-output))) (define make/proc (case-lambda diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss index 998cbf0cd7..27f0366177 100644 --- a/collects/tests/drscheme/io.ss +++ b/collects/tests/drscheme/io.ss @@ -29,14 +29,16 @@ add this test: (clear-definitions drs-frame) (type-in-definitions drs-frame expression) (do-execute drs-frame) - (let* ([got (get-annotated-output)]) - (unless (andmap (λ (exp got) - (and (string=? (car exp) (car got)) - (or (equal? (cadr exp) (cadr got)) - (and (procedure? (cadr exp)) - ((cadr exp) (cadr got)))))) - expected - got) + (let ([got (get-annotated-output)]) + (unless (and (= (length expected) + (length got)) + (andmap (λ (exp got) + (and (string=? (car exp) (car got)) + (or (equal? (cadr exp) (cadr got)) + (and (procedure? (cadr exp)) + ((cadr exp) (cadr got)))))) + expected + got)) (fprintf (current-error-port) "expected ~s, got ~s for ~s\n\n" expected diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 06727f8212..1325dcdcee 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -1183,14 +1183,17 @@ the settings above should match r5rs (printf (make-err-msg defs-expected) 'definitions (language) expression defs-expected got))) - (send definitions-text select-all) - (send definitions-text copy) - - (send interactions-text set-position - (send interactions-text last-position) - (send interactions-text last-position)) - - (send interactions-text paste) + (let ([s (make-semaphore 0)]) + (queue-callback + (λ () + (send definitions-text select-all) + (send definitions-text copy) + (send interactions-text set-position + (send interactions-text last-position) + (send interactions-text last-position)) + (send interactions-text paste) + (semaphore-post s))) + (semaphore-wait s)) (let ([last-para (send interactions-text last-paragraph)]) (type-in-interactions drs (string #\newline)) @@ -1220,11 +1223,11 @@ the settings above should match r5rs (let ([drs (wait-for-drscheme-frame)]) (fw:test:menu-select "Language" "Clear All Teachpacks")) + (go mred) + (go mzscheme) (go beginner) (go beginner/abbrev) (go intermediate) (go intermediate/lambda) (go advanced) - (go r5rs) - (go mred) - (go mzscheme))) + (go r5rs))) diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index a47d05a5ed..feb257cdd1 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -193,9 +193,9 @@ (let* ([test-teachpack (lambda (dir) (lambda (teachpack) - (when (or (equal? "ss" (filename-extension teachpack)) - (equal? "scm" (filename-extension teachpack))) - (unless (equal? "graphing.ss" teachpack) + (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") @@ -212,7 +212,8 @@ (printf " got: ~s~n expected: ~s~n" got expected))))))))] [test-teachpacks (lambda (dir) - (for-each (test-teachpack dir) (directory-list dir)))] + (for-each (test-teachpack dir) + (directory-list dir)))] [teachpack-dir (normalize-path (build-path (collection-path "mzlib") 'up 'up "teachpack"))]) (set-language-level! '("How to Design Programs" "Advanced Student")) (test-teachpacks teachpack-dir)