From bd1aaac0778a104c9fc67e2dc598b9ad2531204d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Nov 2006 00:38:41 +0000 Subject: [PATCH] fixed bug Jens Axel mentioned recently on plt-internal svn: r4788 --- collects/drscheme/private/debug.ss | 88 +++++++++++++++++++----------- 1 file changed, 55 insertions(+), 33 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 2e24ac351c..60dc2c718f 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -189,6 +189,20 @@ profile todo: [(begin expr ...) ;; Found a `begin', so expand/eval each contained ;; expression one at a time + + (let i-loop ([exprs (syntax->list #'(expr ...))] + [last-one (list (void))]) + (cond + [(null? exprs) + (apply values last-one)] + [else + (i-loop (cdr exprs) + (call-with-values (λ () (loop (car exprs))) + list))])) + + ;; the version below behaves properly wrt continuations + ;; but doesn't match mzscheme. So, we use the one above. + #; (let ([exprs (syntax->list #'(expr ...))] [last-one (list (void))]) (let i-loop () @@ -231,12 +245,13 @@ profile todo: 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)))))) + (when (port-writes-special? (current-error-port)) + (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 @@ -285,22 +300,23 @@ profile todo: fn)) raw-src)]) (when (and (path? src) file-note%) - (let ([note (new file-note%)]) - (send note set-callback - (λ () (open-and-highlight-in-file src-to-display))) - (write-special note (current-error-port)) - (display #\space (current-error-port)) - (display (path->string (find-relative-path (current-directory) src)) - (current-error-port)) - (let ([line (srcloc-line src-to-display)] - [col (srcloc-column src-to-display)] - [pos (srcloc-position src-to-display)]) - (cond - [(and (number? line) (number? col)) - (fprintf (current-error-port) ":~a:~a" line col)] - [pos - (fprintf (current-error-port) "::~a" pos)])) - (display ": " (current-error-port)))))) + (when (port-writes-special? (current-error-port)) + (let ([note (new file-note%)]) + (send note set-callback + (λ () (open-and-highlight-in-file src-to-display))) + (write-special note (current-error-port)) + (display #\space (current-error-port)))) + (display (path->string (find-relative-path (current-directory) src)) + (current-error-port)) + (let ([line (srcloc-line src-to-display)] + [col (srcloc-column src-to-display)] + [pos (srcloc-position src-to-display)]) + (cond + [(and (number? line) (number? col)) + (fprintf (current-error-port) ":~a:~a" line col)] + [pos + (fprintf (current-error-port) "::~a" pos)])) + (display ": " (current-error-port))))) ;; find-src-to-display : exn (union #f (listof (list* number number))) ;; -> (listof srclocs) @@ -330,18 +346,24 @@ profile todo: (define (show-syntax-error-context port exn) - (let ([error-text-style-delta (make-object style-delta%)]) + (let ([error-text-style-delta (make-object style-delta%)] + [send-out + (λ (msg f) + (if (port-writes-special? (current-error-port)) + (let ([snp (make-object string-snip% " in:")]) + (f snp) + (write-special snp (current-error-port))) + (display msg (current-error-port))))]) (send error-text-style-delta set-delta-foreground (make-object color% 200 0 0)) - (write-special (make-object string-snip% " in:") (current-error-port)) + (send-out " in:" void) (for-each (λ (expr) - (let ([snp (make-object string-snip% - (format "~s" (syntax-object->datum expr)))]) - (display " " (current-error-port)) - (send snp set-style - (send the-style-list find-or-create-style - (send snp get-style) - error-text-style-delta)) - (write-special snp (current-error-port)))) + (display " " (current-error-port)) + (send-out (format "~s" (syntax-object->datum expr)) + (λ (snp) + (send snp set-style + (send the-style-list find-or-create-style + (send snp get-style) + error-text-style-delta))))) (exn:fail:syntax-exprs exn)))) ;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void @@ -583,7 +605,7 @@ profile todo: (values file void)] [else (error 'insert-context "unknown file spec ~e" file)])]) (when from-text - (let* ([finish (+ start span)] + (let* ([finish (+ start span -1)] [context-text (copy/highlight-text from-text start finish)]) (send context-text lock #t) (send context-text hide-caret #t)