aboutsummaryrefslogtreecommitdiff
path: root/src/guile/skribe/debug.scm
diff options
context:
space:
mode:
authorLudovic Court`es2005-09-23 16:16:44 +0000
committerLudovic Court`es2005-09-23 16:16:44 +0000
commit15456d415e58a5823700fe3198cf3916e917f2b9 (patch)
tree3b3bb9c26e2b79653f1b0fe193ae64964b2f624a /src/guile/skribe/debug.scm
parentc323ee2c0207a02d8af1d0366fdf000f051fdb27 (diff)
parenta85155f7c411761cfbd75431f265675ae0f394e3 (diff)
downloadskribilo-15456d415e58a5823700fe3198cf3916e917f2b9.tar.gz
skribilo-15456d415e58a5823700fe3198cf3916e917f2b9.tar.lz
skribilo-15456d415e58a5823700fe3198cf3916e917f2b9.zip
Lots of changes...
Patches applied: * lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--base-0 tag of lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-5 * lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-1 Lots of changes. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-6
Diffstat (limited to 'src/guile/skribe/debug.scm')
-rw-r--r--src/guile/skribe/debug.scm160
1 files changed, 0 insertions, 160 deletions
diff --git a/src/guile/skribe/debug.scm b/src/guile/skribe/debug.scm
deleted file mode 100644
index e2bff27..0000000
--- a/src/guile/skribe/debug.scm
+++ /dev/null
@@ -1,160 +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)
- :export (with-debug %with-debug
- 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)
- `(%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))
-