update trace. use > for new stack frames and < for return values. prefixes are parameterized

svn: r16055

original commit: 1c129b829b2ceb8419c6e96f3aa1fd884c8cb362

collects/mzlib/trace.ss

@@ -1,79 +1,63 @@
+#lang scheme/base
 
-(module trace scheme/base
+(require scheme/pretty
-  (require scheme/pretty
          (for-syntax scheme/base))
 
-  (provide trace untrace
+(provide trace untrace
          current-trace-print-args trace-apply
-           current-trace-notify)
+         current-trace-notify
+         current-prefix-out current-prefix-in)
 
-  (define max-dash-space-depth 10)
+(define max-dash-space-depth 10)
-  (define number-nesting-depth 6)
+(define number-nesting-depth 6)
+(define current-prefix-out (make-parameter "<"))
+(define current-prefix-in (make-parameter ">"))
 
-  (define (as-spaces s)
+(define (as-spaces s)
-    (build-string (string-length s)
+  (make-string (string-length s) #\space))
-                  (lambda (i) #\space)))
 
-  (define-struct prefix-entry (for-first for-rest))
+(define-struct prefix-entry (for-first for-rest))
 
-  (define prefixes (make-vector 20 #f))
+(define prefixes (make-hash))
-  (define prefix-vector-length 20)
 
-  (define lookup-prefix
+(define (lookup-prefix n label)
-    (lambda (n)
+  (hash-ref prefixes (cons n label) (lambda () #f)))
-      (and (< n prefix-vector-length)
-	   (vector-ref prefixes n))))
 
-  (define insert-prefix
+(define (insert-prefix n label first rest)
-    (lambda (n first rest)
+  (hash-set! prefixes (cons n label) (make-prefix-entry first rest)))
-      (if (>= n prefix-vector-length)
-	  (let ((v (make-vector (* 2 prefix-vector-length) #f)))
-	    (let loop ((k 0))
-	      (when (< k prefix-vector-length)
-		(vector-set! v k (vector-ref prefixes k))
-		(loop (add1 k))))
-	    (set! prefixes v)
-	    (set! prefix-vector-length (* 2 prefix-vector-length))
-	    (insert-prefix n first rest))
-	  (vector-set! prefixes n (make-prefix-entry first rest)))))
 
-  (define construct-prefixes
+(define (construct-prefixes level label)
-    (lambda (level)
+  (let loop ([n level]
-      (let loop ((n level)
+             [first (list label)]
-		 (first '("|"))
+             [rest '(" ")])
-		 (rest '(" ")))
     (if (>= n max-dash-space-depth)
-	    (let-values (((pre-first pre-rest)
+        (let-values ([(pre-first pre-rest)
-			  (build-prefixes number-nesting-depth)))
+                      (build-prefixes number-nesting-depth label)])
           (let ((s (number->string level)))
             (values
-		 (apply string-append
+             (string-append pre-first "[" s "] ")
-			(cons pre-first (cons "[" (cons s (cons "]" '())))))
+             (string-append pre-rest " " (as-spaces s) " "))))
-		 (apply string-append
-			(cons pre-rest (cons " " (cons (as-spaces s)
-						       (cons " " '()))))))))
         (cond
-	     ((= n 0) (values (apply string-append (reverse first))
+          [(= n 0) (values (apply string-append (reverse first))
-			      (apply string-append (reverse rest))))
+                           (apply string-append (reverse rest)))]
-	     ((= n 1) (loop (- n 1)
+          [(= n 1) (loop (- n 1)
                          (cons '" " first)
-			    (cons '" " rest)))
+                         (cons '" " rest))]
-	     (else (loop (- n 2)
+          [else (loop (- n 2)
-			 (cons " |" first)
+                      (cons (format " ~a" label) first)
-			 (cons "  " rest))))))))
+                      (cons "  " rest))]))))
 
-  (define build-prefixes
+(define (build-prefixes level label)
-    (lambda (level)
+  (let ([p (lookup-prefix level label)])
-      (let ((p (lookup-prefix level)))
     (if p
         (values (prefix-entry-for-first p)
                 (prefix-entry-for-rest p))
         (let-values (((first rest)
-			  (construct-prefixes level)))
+                      (construct-prefixes level label)))
-	      (insert-prefix level first rest)
+          (insert-prefix level label first rest)
-	      (values first rest))))))
+          (values first rest)))))
 
-  (define current-trace-notify
+(define current-trace-notify
   (make-parameter (lambda (s)
                     (display s)
                     (newline))
@@ -85,7 +69,7 @@
                                         p))
                     p)))
 
-  (define (as-trace-notify thunk)
+(define (as-trace-notify thunk)
   (let ([p (open-output-bytes)])
     (parameterize ([current-output-port p])
       (thunk))
@@ -94,17 +78,17 @@
                                (sub1 (file-position p)))])
       ((current-trace-notify) (bytes->string/utf-8 b)))))
 
-  (define -:trace-print-args
+(define -:trace-print-args
   (lambda (name args kws kw-vals level)
     (as-trace-notify
      (lambda ()
        ((current-trace-print-args) name args kws kw-vals level)))))
 
-  (define current-trace-print-args
+(define current-trace-print-args
   (make-parameter
    (lambda (name args kws kw-vals level)
      (let-values (((first rest)
-                     (build-prefixes level)))
+                   (build-prefixes level (current-prefix-in))))
        (parameterize ((pretty-print-print-line
                        (lambda (n port offset width)
                          (display
@@ -121,16 +105,16 @@
          (pretty-print (append (cons name args)
                                (apply append (map list kws kw-vals)))))))))
 
-  (define -:trace-print-results
+(define -:trace-print-results
   (lambda (name results level)
     (as-trace-notify
      (lambda ()
        (trace-print-results name results level)))))
 
-  (define trace-print-results
+(define trace-print-results
   (lambda (name results level)
     (let-values (((first rest)
-		    (build-prefixes level)))
+                  (build-prefixes level (current-prefix-out))))
       (parameterize ((pretty-print-print-line
                       (lambda (n port offset width)
                         (display
@@ -165,15 +149,15 @@
              (for-each pretty-print (cdr results)))))))))
 
 
-  ;; A traced-proc struct instance acts like a procedure,
+;; A traced-proc struct instance acts like a procedure,
-  ;;  but preserves the original, too.
+;;  but preserves the original, too.
-  (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
+(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
   (make-struct-type 'traced-proc #f 2 0 #f null (current-inspector) 0))
 
-  ;; Install traced versions of a given set of procedures.  The traced
+;; Install traced versions of a given set of procedures.  The traced
-  ;;  versions are also given, so that they can be constructed to have
+;;  versions are also given, so that they can be constructed to have
-  ;;  a nice name.
+;;  a nice name.
-  (define (do-trace ids procs setters traced-procs)
+(define (do-trace ids procs setters traced-procs)
   (for-each (lambda (id proc)
               (unless (procedure? proc)
                 (error 'trace
@@ -191,16 +175,16 @@
                          proc))))
             procs setters traced-procs))
 
-  ;; Key used for a continuation mark to indicate
+;; Key used for a continuation mark to indicate
-  ;;  the nesting depth:
+;;  the nesting depth:
-  (define -:trace-level-key (gensym))
+(define -:trace-level-key (gensym))
 
-  (define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
+(define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
 
-  ;; Apply a traced procedure to arguments, printing arguments
+;; Apply a traced procedure to arguments, printing arguments
-  ;; and results. We set and inspect the -:trace-level-key continuation
+;; and results. We set and inspect the -:trace-level-key continuation
-  ;; mark a few times to detect tail calls.
+;; mark a few times to detect tail calls.
-  (define (do-traced id args kws kw-vals real-value)
+(define (do-traced id args kws kw-vals real-value)
   (let* ([levels (continuation-mark-set->list
                   (current-continuation-marks)
                   -:trace-level-key)]
@@ -252,7 +236,7 @@
                                     ;; Return the results:
                                     (apply values results))))))))))
 
-  (define-syntax trace
+(define-syntax trace
   (lambda (stx)
     (syntax-case stx ()
       [(_ id ...)
@@ -289,7 +273,7 @@
                    traced-name))
                ...))))])))
 
-  (define-syntax untrace
+(define-syntax untrace
   (lambda (stx)
     (syntax-case stx ()
       [(_ id ...)
@@ -307,5 +291,3 @@
             (when (traced-proc? id)
               (set! id (traced-proc-ref id 1)))
             ...)))])))
-  )
-