summaryrefslogtreecommitdiff
path: root/src/stklos/debug.stk
diff options
context:
space:
mode:
Diffstat (limited to 'src/stklos/debug.stk')
-rw-r--r--src/stklos/debug.stk161
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 "[1;~Am" (+ 31 col))
+ (for-each display o)
+ (display ""))
+ (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))
+|#