[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-33-g36c210d

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=36c210d14e8572939901b9251492a3f4bf94988c

The branch, stable-2.0 has been updated
       via  36c210d14e8572939901b9251492a3f4bf94988c (commit)
      from  3404ada0a695b7e9ea1e6221fb1531ebdd73c211 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 36c210d14e8572939901b9251492a3f4bf94988c
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 16 13:20:54 2013 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/scheme-using.texi  |    9 +++-
 module/system/vm/trace.scm |   96 ++++++++++++++++++++++++--------------------
 2 files changed, 59 insertions(+), 46 deletions(-)

diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 4f9e6db..e0f91af 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2006, 2010, 2011, 2012
address@hidden 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
 
address@hidden {REPL Command} trace exp
address@hidden {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
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 2dad376..e27dc37 100644
--- a/module/system/vm/trace.scm
+++ b/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)
-  (format (current-error-port) "~a~a~v:@y\n"
-          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))))
+(define (build-prefix prefix depth infix numeric-format max-indent)
+  (let lp ((indent "") (n 0))
     (cond
-     ((= nvalues 1)
-      (format (current-error-port) "~a~a~v:@y\n"
-              prefix
-              (let lp ((depth depth) (s ""))
-                (if (zero? depth)
-                    s
-                    (lp (1- depth) (string-append "|  " s))))
-              width (frame-local-ref frame (- len 2))))
+     ((= n depth)
+      (string-append prefix indent))
+     ((< (+ (string-length indent) (string-length infix)) max-indent)
+      (lp (string-append indent infix) (1+ n)))
      (else
-      ;; this should work, but there appears to be a bug
-      ;; "~a~d values:~:{ ~v:@y~}\n"
-      (format (current-error-port) "~a~a~d values:~{ ~a~}\n"
-              prefix
-              (let lp ((depth depth) (s ""))
-                (if (zero? depth)
-                    s
-                    (lp (1- depth) (string-append "|  " s))))
-              nvalues
-              (map (lambda (val)
-                     (format #f "~v:@y" width val))
-                   (frame-return-values frame)))))))
+      (string-append prefix indent (format #f numeric-format depth))))))
+
+(define (print-application frame depth width prefix max-indent)
+  (let ((prefix (build-prefix prefix depth "|  " "~d> " max-indent)))
+    (format (current-error-port) "~a~v:@y\n"
+            prefix
+            width
+            (frame-call-representation frame))))
+
+(define* (print-return frame depth width prefix max-indent)
+  (let* ((len (frame-num-locals 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 ()


hooks/post-receive
-- 
GNU Guile