aboutsummaryrefslogtreecommitdiff
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, 0 insertions, 161 deletions
diff --git a/src/stklos/debug.stk b/src/stklos/debug.stk
deleted file mode 100644
index a9fefde..0000000
--- a/src/stklos/debug.stk
+++ /dev/null
@@ -1,161 +0,0 @@
-;;;;
-;;;; 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))
-|#