suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed bug Jens Axel mentioned recently on plt-internal

Browse Source 
svn: r4788
This commit is contained in:
Robby Findler 2006-11-06 00:38:41 +00:00
parent 434b579d2f
commit bd1aaac077
1 changed files with 55 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/drscheme/private/debug.ss
View File

@ -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* <src> 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)