From 86c7ef726434b31b78570bf80db3cdecf8b84ca3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Tue, 7 Mar 2006 22:58:58 +0000 Subject: 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 --- src/guile/skribilo.scm | 5 +- src/guile/skribilo/debug.scm | 126 ++++++++++++++++++------------------ src/guile/skribilo/utils/compat.scm | 17 +++++ 3 files changed, 83 insertions(+), 65 deletions(-) (limited to 'src') 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 -;;; Copyright 2005 Ludovic Courtès +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 Ludovic Courtès ;;; ;;; 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*))) + ;;; -- cgit v1.2.3