fixed error reporting and brought back the red arrows for the stack trace

svn: r8172

collects/drscheme/private/debug.ss

@@ -64,6 +64,16 @@ profile todo:
     
     (define (get-cm-key) cm-key)
     
+    ;; cms->srclocs : continuation-marks -> (listof srcloc)
+    (define (cms->srclocs cms)
+      (map 
+       (λ (x) (make-srcloc (list-ref x 0)
+                           (list-ref x 1)
+                           (list-ref x 2)
+                           (list-ref x 3)
+                           (list-ref x 4)))
+       (continuation-mark-set->list cms cm-key)))
+    
     ;; error-delta : (instanceof style-delta%)
     (define error-delta (make-object style-delta% 'change-style 'italic))
     (send error-delta set-delta-foreground (make-object color% 255 0 0))
@@ -271,9 +281,7 @@ profile todo:
       (let ([cms
              (and (exn? exn) 
                   (continuation-mark-set? (exn-continuation-marks exn))
-                  (continuation-mark-set->list 
+                  (cms->srclocs (exn-continuation-marks exn)))])
-                   (exn-continuation-marks exn)
-                   cm-key))])
         (when (and cms
                    (pair? cms))
           (print-bug-to-stderr msg cms))
@@ -290,16 +298,7 @@ profile todo:
           ;; don't get erased if this output were to happen after the insertion
           (flush-output (current-error-port))
           
-          (highlight-errors srcs-to-display
+          (highlight-errors srcs-to-display cms))))
-                            (and cms
-                                 (filter 
-                                  (λ (x)
-                                    (and (pair? x)
-                                         (is-a? (car x) text:basic<%>)
-                                         (pair? (cdr x))
-                                         (number? (cadr x))
-                                         (number? (cddr x))))
-                                  cms))))))
     
     ;; display-srcloc-in-error : src-loc -> void
     ;; prints out the src location information for src-to-display
@@ -334,7 +333,7 @@ profile todo:
                (fprintf (current-error-port) "::~a" pos)]))
           (display ": " (current-error-port)))))
     
-    ;; find-src-to-display : exn (union #f (listof (list* <src> number number)))
+    ;; find-src-to-display : exn (union #f (listof srcloc))
     ;;                    -> (listof srclocs)
     ;; finds the source location to display, choosing between
     ;; the stack trace and the exception record.
@@ -351,13 +350,7 @@ profile todo:
           [(and (exn:srclocs? exn)
                 (ormap has-info? ((exn:srclocs-accessor exn) exn)))
            ((exn:srclocs-accessor exn) exn)]
-          [(pair? cms)
+          [(pair? cms) (list (car cms))]
-           (let ([fst (car cms)])
-             (list (make-srcloc (car fst)
-                                #f
-                                #f
-                                (cadr fst)
-                                (cddr fst))))]
           [else '()])))
     
     
@@ -431,10 +424,12 @@ profile todo:
                        (syntax-source src-stx)]
                       [else #f])]
             [position (or (syntax-position src-stx) 0)]
-            [span (or (syntax-span src-stx) 0)])
+            [span (or (syntax-span src-stx) 0)]
+            [line (or (syntax-line src-stx) 0)]
+            [column (or (syntax-column src-stx) 0)])
         (if source
             (with-syntax ([expr expr]
-                          [mark (list* source position span)]
+                          [mark (list source line column position span)]
                           [cm-key cm-key])
               (syntax
                (with-continuation-mark 'cm-key
@@ -489,7 +484,7 @@ profile todo:
         (super-new)))
     
     ;; show-backtrace-window : string
-    ;;                         (listof mark?)
+    ;;                         (listof srcloc?)
     ;;                         -> 
     ;;                         void
     (define (show-backtrace-window error-text dis)
@@ -580,14 +575,16 @@ profile todo:
     ;;              void 
     ;; shows one frame of the continuation
     (define (show-frame editor-canvas text di)
-      (let* ([debug-source (car di)]
+      (let* ([debug-source (srcloc-source di)]
-             [start (cadr di)]
+             [line (srcloc-line di)]
-             [span (cddr di)]
+             [column (srcloc-column di)]
+             [start (srcloc-position di)]
+             [span (srcloc-span di)]
              [fn (get-filename debug-source)]
              [start-pos (send text last-position)])
         
         ;; make hyper link to the file
-        (send text insert (format "~a: ~a-~a" fn start (+ start span)))
+        (send text insert (format "~a: ~a:~a" fn line column))
         (let ([end-pos (send text last-position)])
           (send text insert " ")
           (send text change-style 

collects/drscheme/private/rep.ss

@@ -34,6 +34,8 @@ TODO
   
   (provide rep@)
 
+  (define-struct unsaved-editor (editor))
+  
   (define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name"))
   
   ;; this macro wraps its argument expression in some code in a non-tail manner
@@ -234,9 +236,7 @@ TODO
             (parameterize ([current-eventspace drscheme:init:system-eventspace])
               (queue-callback
                (λ ()
-                 (send rep highlight-errors
+                 (send rep highlight-errors src-locs stack))))))))
-                       src-locs 
-                       (filter (λ (x) (is-a? (car x) text%)) stack)))))))))
     
     (define (main-user-eventspace-thread?)
       (let ([rep (current-rep)])
@@ -725,8 +725,6 @@ TODO
         
         ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number))))
         (define error-ranges #f)
-        ;; error-arrows : (union #f (listof (cons editor<%> number)))
-        (define error-arrows #f)
         (define/public (get-error-ranges) error-ranges)
         (define internal-reset-callback void)
         (define internal-reset-error-arrows-callback void)
@@ -749,21 +747,32 @@ TODO
         
         ;; =Kernel= =handler=
         ;; highlight-errors :    (listof srcloc)
-        ;;                       (union #f (listof (list (is-a?/c text:basic<%>) number number)))
+        ;;                       (union #f (listof srcloc))
         ;;                    -> (void)
-        (define/public (highlight-errors raw-locs error-arrows)
+        (define/public (highlight-errors raw-locs raw-error-arrows)
-          (let ([locs (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
+          (let* ([cleanup-locs
-                                            (number? (srcloc-position loc))
+                  (λ (locs)
-                                            (number? (srcloc-span loc))))
+                    (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
-                              (map (λ (srcloc)
+                                          (number? (srcloc-position loc))
-                                     (if (send definitions-text port-name-matches? (srcloc-source srcloc))
+                                          (number? (srcloc-span loc))))
-                                         (make-srcloc definitions-text
+                            (map (λ (srcloc)
-                                                      (srcloc-line srcloc)
+                                   (cond
-                                                      (srcloc-column srcloc)
+                                     [(send definitions-text port-name-matches? (srcloc-source srcloc))
-                                                      (srcloc-position srcloc)
+                                      (make-srcloc definitions-text
-                                                      (srcloc-span srcloc))
+                                                   (srcloc-line srcloc)
-                                         srcloc))
+                                                   (srcloc-column srcloc)
-                                   raw-locs))])
+                                                   (srcloc-position srcloc)
+                                                   (srcloc-span srcloc))]
+                                     [(unsaved-editor? (srcloc-source srcloc))
+                                      (make-srcloc (unsaved-editor-editor (srcloc-source srcloc))
+                                                   (srcloc-line srcloc)
+                                                   (srcloc-column srcloc)
+                                                   (srcloc-position srcloc)
+                                                   (srcloc-span srcloc))]
+                                     [else srcloc]))
+                                 locs)))]
+                 [locs (cleanup-locs raw-locs)]
+                 [error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))])
             (reset-highlighting)
             
             (set! error-ranges locs)
@@ -784,8 +793,7 @@ TODO
                   (let ([filtered-arrows
                          (remove-duplicate-error-arrows
                           (filter
-                           (λ (arr)
+                           (λ (arr) (embedded-in? (srcloc-source arr) definitions-text))
-                             (embedded-in? (car arr) definitions-text))
                            error-arrows))])
                     (send definitions-text set-error-arrows filtered-arrows)))
                 

collects/drscheme/private/tool-contracts.ss

@@ -353,7 +353,7 @@
   
   (drscheme:debug:show-backtrace-window
    (string?
-    (listof any/c)
+    (listof srcloc?)
     . -> .
     void?)
    (error-message dis)
@@ -372,10 +372,8 @@
    "Returns a key used with \\scheme|contination-mark-set->list|."
    "The contination mark set attached to an exception record"
    "for the user's program may use this mark. If it does,"
-   "each mark on the continuation is the same type as"
+   "each mark on the continuation is a list of the fields"
-   "the input to"
+   "of a srcloc object.")
-   "@flink drscheme:debug:open-and-highlight-in-file %"
-   ".")
   
   ;                           
   ;                           

collects/drscheme/private/unit.ss

@@ -653,8 +653,8 @@ module browser threading seems wrong.
                   (send dc set-pen old-pen)))))
           
           (define/private (draw-arrow dc dx dy pt1 pt2)
-            (let-values ([(x1 y1) (find-poss (car pt1) (cadr pt1) (+ (cadr pt1) 1))]
+            (let-values ([(x1 y1) (find-poss (srcloc-source pt1) (- (srcloc-position pt1) 1) (srcloc-position pt1))]
-                         [(x2 y2) (find-poss (car pt2) (cadr pt2) (+ (cadr pt2) 1))])
+                         [(x2 y2) (find-poss (srcloc-source pt2) (- (srcloc-position pt2) 1) (srcloc-position pt2))])
               (drscheme:arrow:draw-arrow dc x1 y1 x2 y2 dx dy)))
           
           (inherit dc-location-to-editor-location)
@@ -677,7 +677,7 @@ module browser threading seems wrong.
             (set! error-arrows arrows)
             (invalidate-bitmap-cache))
           
-          (field [error-arrows #f])
+          (define error-arrows #f)
           
           (super-new)
           

doc/release-notes/drscheme/HISTORY

@@ -4,6 +4,9 @@
 
   . renamed the get-special-menu method to get-insert-menu
 
+  . drscheme:debug:show-backtrace-window
+    now accepts srcloc structures.
+
 ------------------------------
         Version 372
 ------------------------------