Partial rewrite of the debugging facilities (slightly slower).

* src/guile/skribilo.scm (skribilo): Use the new debugging API.

* src/guile/skribilo/debug.scm: Use SRFI-39 parameter objects.
  Moved legacy procedures to `compat.scm'.

* src/guile/skribilo/utils/compat.scm (set-skribe-debug!): New.
  (no-debug-color): New.
  (skribe-debug): New.
  (add-skribe-debug-symbol): New.

git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-44

3 files changed, 83 insertions, 65 deletions

diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index f683080..dbaa368 100644
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -413,9 +413,7 @@ Processes a Skribilo/Skribe source file and produces its output.
 
     ;; Parse the most important options.
 
-    (set-skribe-debug! (string->number debugging-level))
-
-    (if (> (skribe-debug) 4)
+    (if (> (*debug*) 4)
 	(set! %load-hook
 	      (lambda (file)
 		(format #t "~~ loading `~a'...~%" file))))
@@ -428,6 +426,7 @@ Processes a Skribilo/Skribe source file and produces its output.
 					   (append %load-path
 						   (*source-path*))))
 		   (*image-path*     (cons image-path (*image-path*)))
+		   (*debug*          (string->number debugging-level))
 		   (*warning*        (string->number warning-level))
 		   (*verbose*        (let ((v (option-ref options
 							  'verbose 0)))
diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm
index 1cac749..1481a56 100644
--- a/src/guile/skribilo/debug.scm
+++ b/src/guile/skribilo/debug.scm
@@ -1,7 +1,7 @@
-;;; debug.scm  --  Debug facilities.
+;;; debug.scm  --  Debugging facilities.
 ;;;
-;;; Copyright 2003-2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;; Copyright 2005  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2006  Ludovic Courtès <ludovic.courtes@laas.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
@@ -20,41 +20,50 @@
 
 
 (define-module (skribilo debug)
-  :export (with-debug %with-debug
-	   debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol
-	   no-debug-color)
   :use-module (skribilo utils syntax)
-  :use-module (srfi srfi-17))
+  :use-module (srfi srfi-17)
+  :use-module (srfi srfi-39))
 
 (fluid-set! current-reader %skribilo-module-reader)
 
+
+;;;
+;;; Parameters.
+;;;
 
-;;; FIXME: Use SRFI-39 fluids.
-;;; FIXME: Move this to `parameters.scm'?
+;; Current debugging level.
+(define-public *debug*
+  (make-parameter 0 (lambda (val)
+		      (cond ((number? val) val)
+			    ((string? val)
+			     (string->number val))
+			    (else
+			     (error "*debug*: wrong argument type"
+				    val))))))
 
-(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)
+;; Whether to use colors.
+(define-public *debug-use-colors?* (make-parameter #t))
 
+;; Where to spit debugging output.
+(define-public *debug-port* (make-parameter (current-output-port)))
 
-(define (set-skribe-debug! val)
-  (set! *skribe-debug* val))
+;; Whether to debug individual items.
+(define-public *debug-item?* (make-parameter #f))
 
-(define (add-skribe-debug-symbol s)
-  (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*)))
+;; Watched (debugged) symbols (procedure names).
+(define-public *watched-symbols* (make-parameter '()))
 
 
-(define (no-debug-color)
-  (set! *skribe-debug-color* #f))
+
+;;;
+;;; Implementation.
+;;;
+
+(define *debug-depth*   (make-parameter 0))
+(define *debug-margin*	(make-parameter ""))
+(define *margin-level*  (make-parameter 0))
+
 
-(define-public skribe-debug
-  (getter-with-setter (lambda () *skribe-debug*)
-		      (lambda (val) (set! *skribe-debug* val))))
 
 ;;
 ;;   debug-port
@@ -75,7 +84,7 @@
 ;;;
 (define (debug-color col . o)
   (with-output-to-string
-    (if (and *skribe-debug-color*
+    (if (and (*debug-use-colors?*)
 	     (equal? (getenv "TERM") "xterm"))
 	(lambda ()
 	  (format #t "[1;~Am" (+ 31 col))
@@ -93,54 +102,45 @@
 ;;;
 ;;; debug-item
 ;;;
-(define (debug-item . args)
-  (if (or (>= *skribe-debug* *skribe-margin-debug-level*)
-          *skribe-debug-item*)
+(define-public (debug-item . args)
+  (if (or (>= (*debug*) (*margin-level*))
+          (*debug-item?*))
       (begin
-        (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*))))
+        (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)))
+  (parameterize ((*debug-depth*   (+ (*debug-depth*) 1))
+		 (*debug-margin*  (string-append (*debug-margin*) margin)))
+    (thunk)))
 
 ;;;
 ;;; %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-public (%with-debug lvl lbl thunk)
+  (parameterize ((*margin-level* lvl))
+    (if (or (and (number? lvl) (>= (*debug*) lvl))
+	    (and (symbol? lbl)
+		 (memq lbl (*watched-symbols*))))
+	(parameterize ((*debug-item?* #t))
+	  (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))))
 
 (define-macro (with-debug  level label . body)
   `(%with-debug ,level ,label (lambda () ,@body)))
@@ -148,6 +148,8 @@
 ;;(define-macro (with-debug  level label . body)
 ;;  `(begin ,@body))
 
+(export with-debug)
+
 
 ; Example:
 
diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm
index 9ed9f3e..d4a4367 100644
--- a/src/guile/skribilo/utils/compat.scm
+++ b/src/guile/skribilo/utils/compat.scm
@@ -31,6 +31,7 @@
   :use-module (ice-9 optargs)
   :autoload   (skribilo ast) (ast?)
   :autoload   (skribilo condition) (file-search-error? &file-search-error)
+  :use-module (skribilo debug)
   :re-export (file-size)
   :replace (gensym))
 
@@ -166,6 +167,22 @@
 (define-public skribe-eval         evaluate-document)
 (define-public skribe-eval-port    evaluate-document-from-port)
 
+
+;;;
+;;; Debugging facilities.
+;;;
+
+(define-public (set-skribe-debug! val)
+  (*debug* val))
+
+(define-public (no-debug-color)
+  (*debug-use-colors?* #f))
+
+(define-public skribe-debug *debug*)
+
+(define-public (add-skribe-debug-symbol s)
+  (*watched-symbols* (cons s *watched-symbols*)))
+
 
 
 ;;;