trace: limit length of "| | | "... prefix

* module/system/vm/trace.scm (build-prefix): New helper.
  (print-application, print-return): Use the helper.
  (trace-calls-to-procedure, trace-calls-in-procedure):
  (trace-instructions-in-procedure, call-with-trace): Add #:max-indent
  argument, defaulting to the terminal width less 40 characters.

* doc/ref/scheme-using.texi: Update `trace' docs.

Based on a patch by Nala Ginrut.

doc/ref/scheme-using.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2006, 2010, 2011, 2012
+@c Copyright (C) 2006, 2010, 2011, 2012, 2013
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -298,8 +298,13 @@ Time execution.
 Profile execution.
 @end deffn
 
-@deffn {REPL Command} trace exp
+@deffn {REPL Command} trace exp [#:width w] [#:max-indent i]
 Trace execution.
+
+By default, the trace will limit its width to the width of your
+terminal, or @var{width} if specified.  Nested procedure invocations
+will be printed farther to the right, though if the width of the
+indentation passes the @var{max-indent}, the indentation is abbreviated.
 @end deffn
 
 @node Debug Commands

module/system/vm/trace.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM tracer
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -36,61 +36,66 @@
 ;; FIXME: this constant needs to go in system vm objcode
 (define *objcode-header-len* 8)
 
-(define (print-application frame depth width prefix)
+(define (build-prefix prefix depth infix numeric-format max-indent)
-  (format (current-error-port) "~a~a~v:@y\n"
+  (let lp ((indent "") (n 0))
-          prefix
-          (let lp ((depth depth) (s ""))
-            (if (zero? depth)
-                s
-                (lp (1- depth) (string-append "|  " s))))
-          (max (- width (* 3 depth)) 1)
-          (frame-call-representation frame)))
-
-(define (print-return frame depth width prefix)
-  (let* ((len (frame-num-locals frame))
-         (nvalues (frame-local-ref frame (1- len))))
     (cond
-     ((= nvalues 1)
+     ((= n depth)
-      (format (current-error-port) "~a~a~v:@y\n"
+      (string-append prefix indent))
-              prefix
+     ((< (+ (string-length indent) (string-length infix)) max-indent)
-              (let lp ((depth depth) (s ""))
+      (lp (string-append indent infix) (1+ n)))
-                (if (zero? depth)
-                    s
-                    (lp (1- depth) (string-append "|  " s))))
-              width (frame-local-ref frame (- len 2))))
      (else
-      ;; this should work, but there appears to be a bug
+      (string-append prefix indent (format #f numeric-format depth))))))
-      ;; "~a~d values:~:{ ~v:@y~}\n"
+
-      (format (current-error-port) "~a~a~d values:~{ ~a~}\n"
+(define (print-application frame depth width prefix max-indent)
-              prefix
+  (let ((prefix (build-prefix prefix depth "|  " "~d> " max-indent)))
-              (let lp ((depth depth) (s ""))
+    (format (current-error-port) "~a~v:@y\n"
-                (if (zero? depth)
+            prefix
-                    s
+            width
-                    (lp (1- depth) (string-append "|  " s))))
+            (frame-call-representation frame))))
-              nvalues
+
-              (map (lambda (val)
+(define* (print-return frame depth width prefix max-indent)
-                     (format #f "~v:@y" width val))
+  (let* ((len (frame-num-locals frame))
-                   (frame-return-values frame)))))))
+         (nvalues (frame-local-ref frame (1- len)))
+         (prefix (build-prefix prefix depth "|  " "~d< "max-indent)))
+    (case nvalues
+      ((0)
+       (format (current-error-port) "~ano values\n" prefix))
+      ((1)
+       (format (current-error-port) "~a~v:@y\n"
+               prefix
+               width
+               (frame-local-ref frame (- len 2))))
+      (else
+       ;; this should work, but there appears to be a bug
+       ;; "~a~d values:~:{ ~v:@y~}\n"
+       (format (current-error-port) "~a~d values:~{ ~a~}\n"
+               prefix nvalues
+               (map (lambda (val)
+                      (format #f "~v:@y" width val))
+                    (frame-return-values frame)))))))
   
 (define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
-                                   (prefix "trace: "))
+                                   (prefix "trace: ")
+                                   (max-indent (- width 40)))
   (define (apply-handler frame depth)
-    (print-application frame depth width prefix))
+    (print-application frame depth width prefix max-indent))
   (define (return-handler frame depth)
-    (print-return frame depth width prefix))
+    (print-return frame depth width prefix max-indent))
   (trap-calls-to-procedure proc apply-handler return-handler
                            #:vm vm))
 
 (define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
-                                   (prefix "trace: "))
+                                   (prefix "trace: ")
+                                   (max-indent (- width 40)))
   (define (apply-handler frame depth)
-    (print-application frame depth width prefix))
+    (print-application frame depth width prefix max-indent))
   (define (return-handler frame depth)
-    (print-return frame depth width prefix))
+    (print-return frame depth width prefix max-indent))
   (trap-calls-in-dynamic-extent proc apply-handler return-handler
                                 #:vm vm))
 
-(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm)))
+(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+                                          (max-indent (- width 40)))
   (define (trace-next frame)
     (let* ((ip (frame-instruction-pointer frame))
            (objcode (program-objcode (frame-procedure frame)))
@@ -104,17 +109,20 @@
 ;; Note that because this procedure manipulates the VM trace level
 ;; directly, it doesn't compose well with traps at the REPL.
 ;;
-(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f) (width 80) (vm (the-vm)))
+(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f) 
+                          (width 80) (vm (the-vm)) (max-indent (- width 40)))
   (let ((call-trap #f)
         (inst-trap #f))
     (dynamic-wind
       (lambda ()
         (if calls?
             (set! call-trap
-                  (trace-calls-in-procedure thunk #:vm vm #:width width)))
+                  (trace-calls-in-procedure thunk #:vm vm #:width width
+                                            #:max-indent max-indent)))
         (if instructions?
             (set! inst-trap
-                  (trace-instructions-in-procedure thunk #:vm vm #:width width)))
+                  (trace-instructions-in-procedure thunk #:vm vm #:width width 
+                                                   #:max-indent max-indent)))
         (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
       thunk
       (lambda ()