From 1781866f1cd988ddf7f9f026a0c3d8a4c1f57065 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 19 May 2009 13:16:59 +0300
Subject: [PATCH] - small change to how the tracer works internally and how it
 keeps   track of continuation frames and trace depths.

---
 scheme/ikarus.trace.ss | 113 ++++++++++++++++++++++++++---------------
 scheme/last-revision   |   2 +-
 2 files changed, 74 insertions(+), 41 deletions(-)

diff --git a/scheme/ikarus.trace.ss b/scheme/ikarus.trace.ss
index 1ed115f..9f9e760 100644
--- a/scheme/ikarus.trace.ss
+++ b/scheme/ikarus.trace.ss
@@ -18,59 +18,92 @@
   (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)
-      (unless (null? ls)
-        (display (if t "|" " "))
-        (display-prefix (cdr ls) (not t)))))
-  
+    (lambda (n)
+      (let f ([i 0])
+        (unless (= i n)
+          (display (if (even? i) "|" " "))
+          (f (+ i 1))))))
+
   (define display-trace
     (lambda (k* v)
       (display-prefix k* #t)
       (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
-           (lambda (f)
-             (cond
-               [(memq f k*) => 
-                (lambda (ls)
-                  (display-trace ls (filter (cons name args)))
-                  (apply proc args))]
-               [else
-                (display-trace (cons 1 k*) (filter (cons name args)))
-                (dynamic-wind
-                  (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*))))]))))]))
-  
+         (stacked-call 
+           (lambda ()
+             (set! *trace-depth* (add1 *trace-depth*)))
+           (lambda ()
+             (set-scell-trace! *scell* *trace-depth*)
+             (set-scell-filter! *scell* filter)
+             (display-call-trace *trace-depth* (filter (cons name args)))
+             (apply proc args))
+           (lambda ()
+             (set! *trace-depth* (sub1 *trace-depth*)))))]))
+
+
   (define make-traced-macro
     (lambda (name x)
       (cond
diff --git a/scheme/last-revision b/scheme/last-revision
index 68194d9..30161eb 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1781
+1782