fix stack and header, display source info

scheme/inspector.scm

@@ -10,28 +10,95 @@
      num-lines)))
 
 (define (make-header focus-obj num-cols)
-  (list (val-to-string focus-obj num-cols)
+  (cons (val-to-string focus-obj num-cols)
-        (if (exception-continuation? focus-obj)
+        (maybe-source focus-obj #f)))
-            "Press cont-down key to see more"
+;        (if (exception-continuation? focus-obj)
-            "")))
+;            "Press cont-down key to see more"
+;            "")))
+
+(define (header-length header) 
+  (length header))
+
+(define (set-header-message! header msg)
+  (if (null? (cdr header))
+      (set-cdr! header (list msg))
+      (begin
+        (set-car! (cdr header) msg)
+        (set-cdr! (cdr header) '()))))
 
 (define (layout-menu-entry num-cols entry)
   (let ((head (format #f "[~a]" (or (car entry) ""))))
     (string-append head (val-to-string (cdr entry) 
                                        (- num-cols (string-length head))))))
 
+(define *write-depth* 3)
+(define *write-length* 5)
+
 (define (val-to-string val max-length)
   (let ((out (open-output-string)))
     (limited-write val 
                    out 
-                   3 
+                   *write-depth*
-                   5)
+                   *write-length*)
     (let ((str (get-output-string out)))
       (substring str 0 (min (string-length str) max-length)))))
 
 (define (prepare-selection-for-scheme-mode file-names)
   (string-append "'" (exp->string file-names)))
 
+(define (continuation-debug-data thing)
+  (template-debug-data (continuation-template thing)))
+
+
+; Exception continuations don't have source, so we get the source from
+; the next continuation if it is from the same procedure invocation.
+
+(define (maybe-source thing exception?)
+  (cond ((not (continuation? thing))
+	 '())
+	((exception-continuation? thing)
+	 (let ((next (continuation-cont thing)))
+	   (if (not (eq? next (continuation-parent thing)))
+	       (maybe-source next #t)
+               '())))
+	(else
+	 (let ((dd (continuation-debug-data thing)))
+	   (if dd
+	       (let ((source (assoc (continuation-pc thing)
+				    (debug-data-source dd))))
+		 (if source
+		     (maybe-source-info (cdr source) exception?)
+                     '()))
+               '())))))
+  
+; Show the source code for a continuation, if we have it.
+
+(define (maybe-source-info info exception?)
+  (if (pair? info)
+      (let ((i (car info))
+	    (exp (cdr info)))
+	(if (and (integer? i) (list? exp))
+	    (let ((out1 (open-output-string))
+                  (out2 (open-output-string)))
+	      (display (if exception?
+			   "Next call is "
+			   "Waiting for ")
+		       out1)
+	      (limited-write (list-ref exp i) out1
+			     *write-depth* *write-length*)
+	      (display "  in " out2)
+	      (limited-write (append (sublist exp 0 i)
+				     (list '^^^)
+				     (list-tail exp (+ i 1)))
+			     out2
+			     *write-depth* *write-length*)
+              (list (get-output-string out1)
+                    (get-output-string out2)))
+            '()))
+      '()))
+
+
+
 (define (inspect-value val)
   (error "not yet"))
 
@@ -53,32 +120,28 @@
          (num-lines num-lines)
          (selection-list
           (make-inspector-selection-list num-cols
-                                         (- num-lines (length header))
+                                         (- num-lines (header-length header))
                                          focus-obj)))
 
     (define (push-val! new)
-      (set! header (make-header val num-cols))
+      (set! header (make-header new num-cols))
-      (set! stack (cons new stack))
+      (set! stack (cons val stack))
       (set! val new)
       (set! selection-list
             (make-inspector-selection-list
              num-cols
-             (- num-lines (length header))
+             (- num-lines (header-length header))
              new)))
 
     (define (inspect-next-continuation)
       (if (continuation? val)
           (push-val! (continuation-parent val))
-          (set-header-message!
+          (set-header-message! header
            "Can't go down from a non-continuation.")))
 
-    (define (set-header-message! msg)
-      (set! header (cons (car header)
-                         (list msg))))
-
     (define (pop-val!)
       (if (null? stack)
-          (set-header-message! "Can't go up from here.")
+          (set-header-message! header "Can't go up from here.")
           (begin            
             (set! val (car stack))
             (set! header (make-header val num-cols))
@@ -86,7 +149,7 @@
             (set! selection-list
                   (make-inspector-selection-list
                    num-cols
-                   (- num-lines (length header))
+                   (- num-lines (header-length header))
                    val)))))
 
     (define (get-focus-object self focus-object-table)
@@ -112,7 +175,7 @@
       (case message
         ((paint)
          (lambda (self win result-buffer have-focus?)
-           (let ((hdr-len (length header)))
+           (let ((hdr-len (header-length header)))
              (for-each (lambda (text y)
                          (mvwaddstr win y 0 text))
                        header

scheme/nuit-packages.scm

@@ -226,6 +226,8 @@
         display-conditions
 	signals
         (subset srfi-13 (string-join))
+        debug-data 
+        (subset disclosers (template-debug-data))
 
         focus-table
 	ncurses