summaryrefslogtreecommitdiff
path: root/src/guile/skribe/debug.scm
diff options
context:
space:
mode:
authorLudovic Court`es2005-06-15 17:35:06 +0000
committerLudovic Court`es2005-06-15 17:35:06 +0000
commitccc7e34619661c676b8169c3d88360f070b49b51 (patch)
treebdcc1edf22ff312bd0359d05de7ff5fb2901dc9f /src/guile/skribe/debug.scm
parent8de14180fa2e4aa3cbd8cd85f8080985a59557f9 (diff)
downloadskribilo-ccc7e34619661c676b8169c3d88360f070b49b51.tar.gz
skribilo-ccc7e34619661c676b8169c3d88360f070b49b51.tar.lz
skribilo-ccc7e34619661c676b8169c3d88360f070b49b51.zip
Started a port of Skribe to Guile.
* src/guile: New directory. Contains the beginning of a Guile implementation that borrows most of its code to the STkLos implementation of Skribe. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-4
Diffstat (limited to 'src/guile/skribe/debug.scm')
-rw-r--r--src/guile/skribe/debug.scm159
1 files changed, 159 insertions, 0 deletions
diff --git a/src/guile/skribe/debug.scm b/src/guile/skribe/debug.scm
new file mode 100644
index 0000000..01f88c2
--- /dev/null
+++ b/src/guile/skribe/debug.scm
@@ -0,0 +1,159 @@
+;;;;
+;;;; 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)
+ :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))
+