- small change to how the tracer works internally and how it keeps

track of continuation frames and trace depths.

scheme/ikarus.trace.ss

@@ -18,13 +18,22 @@
   (export make-traced-procedure make-traced-macro) 
   (import (except (ikarus) make-traced-procedure make-traced-macro))
 
-  (define k* '())
+
+  (define-struct scell (cf trace filter prev))
+
+  (define (mkcell prev)
+    (make-scell #f #f #f prev))
+
+  (define *scell* (mkcell #f))
+
+  (define *trace-depth* 0)
 
   (define display-prefix
-    (lambda (ls t)
+    (lambda (n)
-      (unless (null? ls)
+      (let f ([i 0])
-        (display (if t "|" " "))
+        (unless (= i n)
-        (display-prefix (cdr ls) (not t)))))
+          (display (if (even? i) "|" " "))
+          (f (+ i 1))))))
 
   (define display-trace
     (lambda (k* v)
@@ -32,44 +41,68 @@
       (write v)
       (newline)))
 
+  (define (display-return-trace n ls)
+    (display-prefix n)
+    (unless (null? ls)
+      (write (car ls))
+      (let f ([ls (cdr ls)])
+        (unless (null? ls)
+          (write-char #\space)
+          (write (car ls))
+          (f (cdr ls)))))
+    (newline))
+
+  (define (display-call-trace n ls)
+    (display-prefix n)
+    (write ls)
+    (newline))
+ 
+  (define (stacked-call pre thunk post)
+    (call/cf
+      (lambda (cf)
+        (if (eq? cf (scell-cf *scell*))
+            (thunk)
+            (dynamic-wind
+              (let ([scell (mkcell *scell*)])
+                (lambda () 
+                  (set! *scell* scell)
+                  (pre)))
+              (lambda ()
+                (call-with-values
+                  (lambda ()
+                    (call/cf
+                      (lambda (cf)
+                        (set-scell-cf! *scell* cf)
+                        (thunk))))
+                  return-handler))
+              (lambda ()
+                (post)
+                (set! *scell* (scell-prev *scell*))))))))
+
+  (define return-handler
+    (lambda v*
+      (cond
+        [(scell-trace *scell*) =>
+         (lambda (n)
+           (display-return-trace n ((scell-filter *scell*) v*)))])
+      (apply values v*)))
 
   (define make-traced-procedure
     (case-lambda
       [(name proc) (make-traced-procedure name proc (lambda (x) x))]
       [(name proc filter)
        (lambda args
-         (call/cf
+         (stacked-call 
-           (lambda (f)
+           (lambda ()
-             (cond
+             (set! *trace-depth* (add1 *trace-depth*)))
-               [(memq f k*) => 
+           (lambda ()
-                (lambda (ls)
+             (set-scell-trace! *scell* *trace-depth*)
-                  (display-trace ls (filter (cons name args)))
+             (set-scell-filter! *scell* filter)
-                  (apply proc args))]
+             (display-call-trace *trace-depth* (filter (cons name args)))
-               [else
+             (apply proc args))
-                (display-trace (cons 1 k*) (filter (cons name args)))
+           (lambda ()
-                (dynamic-wind
+             (set! *trace-depth* (sub1 *trace-depth*)))))]))
-                  (lambda () (set! k* (cons f k*)))
+
-                  (lambda () 
-                    (call-with-values
-                      (lambda ()
-                        (call/cf
-                          (lambda (nf)
-                            (set! f nf)
-                            (set-car! k* nf)
-                            (apply proc args))))
-                      (lambda v*
-                        (display-prefix k* #t)
-                        (unless (null? v*)
-                          (let ([v* (filter v*)])
-                            (write (car v*))
-                            (let f ([v* (cdr v*)])
-                              (unless (null? v*)
-                                (write-char #\space)
-                                (write (car v*))
-                                (f (cdr v*))))))
-                        (newline)
-                        (apply values v*))))
-                  (lambda () (set! k* (cdr k*))))]))))]))
 
   (define make-traced-macro
     (lambda (name x)

scheme/last-revision

@@ -1 +1 @@
-1781
+1782