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

svn: r16055

original commit: 1c129b829b2ceb8419c6e96f3aa1fd884c8cb362

collects/mzlib/trace.ss

@@ -1,77 +1,61 @@
+#lang scheme/base
 
-(module trace scheme/base
 (require scheme/pretty
          (for-syntax scheme/base))
 
 (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 number-nesting-depth 6)
+(define current-prefix-out (make-parameter "<"))
+(define current-prefix-in (make-parameter ">"))
 
 (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 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
   (make-parameter (lambda (s)
@@ -104,7 +88,7 @@
   (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
@@ -130,7 +114,7 @@
 (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
@@ -307,5 +291,3 @@
             (when (traced-proc? id)
               (set! id (traced-proc-ref id 1)))
             ...)))])))
-  )
-