1 files changed, 161 insertions, 0 deletions
diff --git a/src/stklos/debug.stk b/src/stklos/debug.stk
new file mode 100644
index 0000000..a9fefde
--- /dev/null
+++ b/src/stklos/debug.stk
@@ -0,0 +1,161 @@
+;;;;
+;;;; debug.stk	-- Debug Facilities (stolen to Manuel Serrano) 
+;;;; 
+;;;; 
+;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
+;;;; USA.
+;;;; 
+;;;;           Author: Erick Gallesio [eg@essi.fr]
+;;;;    Creation date: 10-Aug-2003 20:45 (eg)
+;;;; Last file update: 28-Oct-2004 13:16 (eg)
+;;;;
+
+
+(define-module SKRIBE-DEBUG-MODULE
+  (export debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol
+	  no-debug-color)
+
+(define *skribe-debug* 			0)
+(define *skribe-debug-symbols*		'())
+(define *skribe-debug-color* 		#t)
+(define *skribe-debug-item* 		#f)
+(define *debug-port* 			(current-error-port))
+(define *debug-depth* 			0)
+(define *debug-margin* 			"")
+(define *skribe-margin-debug-level*	0)
+
+
+(define (set-skribe-debug! val)
+  (set! *skribe-debug* val))
+
+(define (add-skribe-debug-symbol s)
+  (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*)))
+
+
+(define (no-debug-color)
+  (set! *skribe-debug-color* #f))
+
+(define (skribe-debug)
+  *skribe-debug*)
+
+;;
+;;   debug-port
+;;
+; (define (debug-port . o)
+;    (cond
+;       ((null? o)
+;        *debug-port*)
+;       ((output-port? (car o))
+;        (set! *debug-port* o)
+;        o)
+;       (else
+;        (error 'debug-port "Illegal debug port" (car o)))))
+;
+
+;;;
+;;; debug-color
+;;;
+(define (debug-color col . o)
+  (with-output-to-string
+    (if (and *skribe-debug-color*
+	     (equal? (getenv "TERM") "xterm")
+	     (interactive-port? *debug-port*))	
+	(lambda ()
+	  (format #t "[0m[1;~Am" (+ 31 col))
+	  (for-each display o)
+	  (display "[0m"))
+	(lambda ()
+	  (for-each display o)))))
+
+;;;
+;;; debug-bold
+;;;
+(define (debug-bold . o)
+   (apply debug-color -30 o))
+
+;;;
+;;; debug-item
+;;;
+(define (debug-item . args)
+  (when (or (>= *skribe-debug* *skribe-margin-debug-level*)
+	    *skribe-debug-item*)
+    (display *debug-margin* *debug-port*)
+    (display (debug-color (- *debug-depth* 1) "- ") *debug-port*)
+    (for-each (lambda (a) (display a *debug-port*)) args)
+    (newline *debug-port*)))
+
+;;(define-macro (debug-item  . args)
+;;  `())
+
+;;;
+;;; %with-debug-margin
+;;;
+(define (%with-debug-margin margin thunk)
+  (let ((om *debug-margin*))
+    (set! *debug-depth* (+ *debug-depth* 1))
+    (set! *debug-margin* (string-append om margin))
+    (let ((res (thunk)))
+      (set! *debug-depth* (- *debug-depth* 1))
+      (set! *debug-margin* om)
+      res)))
+      
+;;;
+;;; %with-debug
+;;
+(define (%with-debug lvl lbl thunk)
+  (let ((ol *skribe-margin-debug-level*)
+	(oi *skribe-debug-item*))
+    (set! *skribe-margin-debug-level* lvl)
+    (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl))
+		     (and (symbol? lbl)
+			  (memq lbl *skribe-debug-symbols*)
+			  (set! *skribe-debug-item* #t)))
+		 (begin
+		   (display *debug-margin* *debug-port*)
+		   (display (if (= *debug-depth* 0)
+				(debug-color *debug-depth* "+ " lbl)
+				(debug-color *debug-depth* "--+ " lbl))
+			    *debug-port*)
+		   (newline *debug-port*)
+		   (%with-debug-margin (debug-color *debug-depth* "  |")
+				       thunk))
+		 (thunk))))
+      (set! *skribe-debug-item* oi)
+      (set! *skribe-margin-debug-level* ol)
+      r)))
+
+(define-macro (with-debug  level label . body)
+  `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body)))
+
+;;(define-macro (with-debug  level label . body)
+;;  `(begin ,@body))
+
+)
+
+#|
+Example:
+
+(with-debug 0 'foo1.1
+  (debug-item 'foo2.1)
+  (debug-item 'foo2.2)
+  (with-debug 0 'foo2.3
+     (debug-item 'foo3.1)
+     (with-debug 0 'foo3.2
+	(debug-item 'foo4.1)
+	(debug-item 'foo4.2))
+     (debug-item 'foo3.3))
+  (debug-item 'foo2.4))
+|#