Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0

1 files changed, 188 insertions, 0 deletions

diff --git a/skribe/src/bigloo/debug.scm b/skribe/src/bigloo/debug.scm
new file mode 100644
index 0000000..8f1691c
--- /dev/null
+++ b/skribe/src/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)))
+