From 15ff2e69e69fdfb1f8353e92d8f71f29804b15d0 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Fri, 4 Nov 2011 16:53:39 +0900
Subject: [PATCH] Adding (chibi trace) library.

---
 Makefile            |  2 +-
 lib/chibi/trace.scm | 78 +++++++++++++++++++++++++++++++++++++++++++++
 lib/chibi/trace.sld | 18 +++++++++++
 3 files changed, 97 insertions(+), 1 deletion(-)
 create mode 100644 lib/chibi/trace.scm
 create mode 100644 lib/chibi/trace.sld

diff --git a/Makefile b/Makefile
index 9e39aedc..05e3e792 100644
--- a/Makefile
+++ b/Makefile
@@ -189,7 +189,7 @@ doc/lib/chibi/%.html: lib/chibi/%.sld tools/chibi-doc chibi-scheme$(EXE)
 
 MODULE_DOCS := ast disasm equiv filesystem generic heap-stats io loop \
 	match mime modules net pathname process repl scribble stty \
-	system test time type-inference uri weak
+	system test time trace type-inference uri weak
 
 doc: doc/chibi.html $(MODULE_DOCS:%=doc/lib/chibi/%.html)
 
diff --git a/lib/chibi/trace.scm b/lib/chibi/trace.scm
new file mode 100644
index 00000000..6b0c30ff
--- /dev/null
+++ b/lib/chibi/trace.scm
@@ -0,0 +1,78 @@
+
+;; Table mapping traced procedures to their original untraced values.
+(define all-traces
+  (make-parameter (make-hash-table eq?)))
+
+;; The current number of traced procedure frames on the stack.
+(define active-trace-depth
+  (make-parameter 0))
+
+(define (show-trace cell args)
+  (let ((out (current-error-port)))
+    (do ((i 0 (+ i 1)))
+        ((>= i (active-trace-depth)))
+      (display "| " out))
+    (display "> " out)
+    (write/ss (cons (car cell) args) out)
+    (newline out)))
+
+(define (show-trace-result cell args res)
+  (let ((out (current-error-port)))
+    (do ((i 0 (+ i 1)))
+        ((>= i (active-trace-depth)))
+      (display "| " out))
+    (write/ss res out)
+    (newline out)))
+
+(define (make-tracer cell)
+  (let ((proc (cdr cell)))
+    (lambda args
+      (show-trace cell args)
+      (active-trace-depth (+ (active-trace-depth) 1))
+      (let ((res (apply proc args)))
+        (active-trace-depth (- (active-trace-depth) 1))
+        (show-trace-result cell args res)
+        res))))
+
+(define-syntax trace
+  (syntax-rules ()
+    ((trace id)
+     (trace-cell (env-cell (interaction-environment) 'id)))))
+
+(define-syntax untrace
+  (syntax-rules ()
+    ((untrace id)
+     (untrace-cell (env-cell (interaction-environment) 'id)))))
+
+(define (warn . args)
+  (let ((out (current-error-port)))
+    (display "WARNING: " out)
+    (for-each (lambda (x) (display x out)) args)
+    (newline out)))
+
+(define (trace-cell cell)
+  (let ((tab (all-traces)))
+    (cond
+     ((not (pair? cell))
+      (warn "No such binding."))
+     ((hash-table-exists? tab cell)
+      (warn "Procedure already being traced: " (car cell)))
+     (else
+      (hash-table-set! tab cell (cdr cell))
+      (set-cdr! cell (make-tracer cell))))))
+
+(define (untrace-cell cell)
+  (let ((tab (all-traces)))
+    (cond
+     ((not (pair? cell))
+      (warn "No such binding."))
+     ((not (hash-table-exists? tab cell))
+      (warn "Procedure not being traced: " (car cell)))
+     (else
+      (let ((proc (hash-table-ref tab cell)))
+        (hash-table-delete! tab cell)
+        (set-cdr! cell proc))))))
+
+(define (untrace-all)
+  (hash-table-walk (all-traces) (lambda (cell proc) (set-cdr! cell proc)))
+  (all-traces (make-hash-table eq?)))
diff --git a/lib/chibi/trace.sld b/lib/chibi/trace.sld
new file mode 100644
index 00000000..ea63af02
--- /dev/null
+++ b/lib/chibi/trace.sld
@@ -0,0 +1,18 @@
+
+;;> @subsubsubsection{(trace proc)}
+
+;;> Write a trace of all calls to the procedure @var{proc} to
+;;> @scheme{(current-error-port)}.
+
+;;> @subsubsubsection{(untrace proc)}
+
+;;> Remove any active traces on the procedure @var{proc}.
+
+;;> @subsubsubsection{(untrace-all)}
+
+;;> Remove all active procedure traces.
+
+(define-library (chibi trace)
+  (export trace untrace untrace-all)
+  (import (scheme) (chibi ast) (srfi 38) (srfi 39) (srfi 69))
+  (include "trace.scm"))