summaryrefslogtreecommitdiff
path: root/legacy/bigloo/debug.scm
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/bigloo/debug.scm')
-rw-r--r--legacy/bigloo/debug.scm188
1 files changed, 188 insertions, 0 deletions
diff --git a/legacy/bigloo/debug.scm b/legacy/bigloo/debug.scm
new file mode 100644
index 0000000..8f1691c
--- /dev/null
+++ b/legacy/bigloo/debug.scm
@@ -0,0 +1,188 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/bigloo/debug.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Wed Jun 11 10:01:47 2003 */
+;* Last change : Thu Oct 28 21:33:00 2004 (eg) */
+;* Copyright : 2003 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Simple debug facilities */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module skribe_debug
+
+ (export *skribe-debug*
+ *skribe-debug-symbols*
+ *skribe-debug-color*
+
+ (skribe-debug::int)
+ (debug-port::output-port . ::obj)
+ (debug-margin::bstring)
+ (debug-color::bstring ::int . ::obj)
+ (debug-bold::bstring . ::obj)
+ (debug-string ::obj)
+ (debug-item . ::obj)
+
+ (%with-debug ::obj ::obj ::procedure)))
+
+;*---------------------------------------------------------------------*/
+;* *skribe-debug* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-debug* 0)
+
+;*---------------------------------------------------------------------*/
+;* *skribe-debug-symbols* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-debug-symbols* '())
+
+;*---------------------------------------------------------------------*/
+;* *skribe-debug-color* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-debug-color* #t)
+
+;*---------------------------------------------------------------------*/
+;* *skribe-debug-item* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-debug-item* #f)
+
+;*---------------------------------------------------------------------*/
+;* *debug-port* ... */
+;*---------------------------------------------------------------------*/
+(define *debug-port* (current-error-port))
+
+;*---------------------------------------------------------------------*/
+;* *debug-depth* ... */
+;*---------------------------------------------------------------------*/
+(define *debug-depth* 0)
+
+;*---------------------------------------------------------------------*/
+;* *debug-margin* ... */
+;*---------------------------------------------------------------------*/
+(define *debug-margin* "")
+
+;*---------------------------------------------------------------------*/
+;* *skribe-margin-debug-level* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-margin-debug-level* 0)
+
+;*---------------------------------------------------------------------*/
+;* skribe-debug ... */
+;*---------------------------------------------------------------------*/
+(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-margin ... */
+;*---------------------------------------------------------------------*/
+(define (debug-margin)
+ *debug-margin*)
+
+;*---------------------------------------------------------------------*/
+;* debug-color ... */
+;*---------------------------------------------------------------------*/
+(define (debug-color col::int . o)
+ (with-output-to-string
+ (if *skribe-debug-color*
+ (lambda ()
+ (display* "[1;" (+ 31 col) "m")
+ (apply display* o)
+ (display ""))
+ (lambda ()
+ (apply display* o)))))
+
+;*---------------------------------------------------------------------*/
+;* debug-bold ... */
+;*---------------------------------------------------------------------*/
+(define (debug-bold . o)
+ (apply debug-color -30 o))
+
+;*---------------------------------------------------------------------*/
+;* debug-item ... */
+;*---------------------------------------------------------------------*/
+(define (debug-item . args)
+ (if (or (>= *skribe-debug* *skribe-margin-debug-level*)
+ *skribe-debug-item*)
+ (begin
+ (display (debug-margin) *debug-port*)
+ (display (debug-color (-fx *debug-depth* 1) "- "))
+ (for-each (lambda (a) (display a *debug-port*)) args)
+ (newline *debug-port*))))
+
+;*---------------------------------------------------------------------*/
+;* %with-debug-margin ... */
+;*---------------------------------------------------------------------*/
+(define (%with-debug-margin margin thunk)
+ (let ((om *debug-margin*))
+ (set! *debug-depth* (+fx *debug-depth* 1))
+ (set! *debug-margin* (string-append om margin))
+ (let ((res (thunk)))
+ (set! *debug-depth* (-fx *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)))
+ (with-output-to-port *debug-port*
+ (lambda ()
+ (display (debug-margin))
+ (display (if (= *debug-depth* 0)
+ (debug-color *debug-depth* "+ " lbl)
+ (debug-color *debug-depth* "--+ " lbl)))
+ (newline)
+ (%with-debug-margin (debug-color *debug-depth* " |")
+ thunk)))
+ (thunk))))
+ (set! *skribe-debug-item* oi)
+ (set! *skribe-margin-debug-level* ol)
+ r)))
+
+;*---------------------------------------------------------------------*/
+;* debug-string ... */
+;*---------------------------------------------------------------------*/
+(define (debug-string o)
+ (with-output-to-string
+ (lambda ()
+ (write o))))
+
+;*---------------------------------------------------------------------*/
+;* example */
+;*---------------------------------------------------------------------*/
+;; (%with-debug 0 'foo1.1
+;; (lambda ()
+;; (debug-item 'foo2.1)
+;; (debug-item 'foo2.2)
+;; (%with-debug 0 'foo2.3
+;; (lambda ()
+;; (debug-item 'foo3.1)
+;; (%with-debug 0 'foo3.2
+;; (lambda ()
+;; (debug-item 'foo4.1)
+;; (debug-item 'foo4.2)))
+;; (debug-item 'foo3.3)))
+;; (debug-item 'foo2.4)))
+