home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / scheme / GNU / jacalrc / jacal / debug < prev    next >
Encoding:
Text File  |  1993-10-24  |  2.7 KB  |  89 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992, 1993 Aubrey Jaffer.
  3.  
  4. (require 'defmacro)
  5. (define debug:indent 0)
  6.  
  7. (define (math:printn x) (math:print x) (newline-diag))
  8.  
  9. (define (print . args)
  10.   (define result #f)
  11.   (for-each (lambda (x) (set! result x) (math:print x)
  12.             (display-diag #\ ))
  13.         args)
  14.   (newline-diag)
  15.   result)
  16.  
  17. (define (mtracef function . optname)
  18.     (set! debug:indent 0)
  19.     (let ((name (if (null? optname) function (car optname))))
  20.       (lambda args
  21.     (cond ((and (not (null? args))
  22.             (eq? (car args) 'debug:untrace-object)
  23.             (null? (cdr args)))
  24.            function)
  25.           (else
  26.            (do ((i debug:indent (+ -1 i))) ((zero? i)) (display "  "))
  27.            (display "CALLED ") (display name) (newline)
  28.            (for-each math:printn args)
  29.            (set! debug:indent (modulo (+ 1 debug:indent) 8))
  30.            (let ((ans (apply function args)))
  31.          (set! debug:indent (modulo (+ -1 debug:indent) 8))
  32.          (do ((i debug:indent (+ -1 i))) ((zero? i)) (display "  "))
  33.          (display "RETURNED ") (display name) (newline)
  34.          (math:printn ans)
  35.          ans))))))
  36.  
  37. (define (muntracef function)
  38.   (set! debug:indent 0)
  39.   (function 'debug:untrace-object))
  40.  
  41. (define *traced-procedures* '())
  42. (define (mtrace:tracef fun sym)
  43.   (cond ((memq sym *traced-procedures*)
  44.      (display "WARNING: already traced " (current-error-port))
  45.      (display sym (current-error-port))
  46.      (newline (current-error-port))
  47.      fun)
  48.     (else
  49.      (set! *traced-procedures* (cons sym *traced-procedures*))
  50.      (mtracef fun sym))))
  51. (define (mtrace:untracef fun sym)
  52.   (require 'common-list-functions)
  53.   (cond ((memq sym *traced-procedures*)
  54.      (set! *traced-procedures* (remove sym *traced-procedures*))
  55.      (muntracef fun))
  56.     (else
  57.      (display "WARNING: not traced " (current-error-port))
  58.      (display sym (current-error-port))
  59.      (newline (current-error-port))
  60.      fun)))
  61.  
  62. ;;; Macros.
  63.  
  64. (defmacro:eval
  65.   '(defmacro mtrace x
  66.      (if (null? x) '*traced-procedures*
  67.      `(begin ,@(map (lambda (x) `(set! ,x (mtrace:tracef ,x ',x))) x)))))
  68. (defmacro:eval
  69.   '(defmacro muntrace x
  70.      (if (null? x)
  71.      (slib:eval
  72.       `(begin ,@(map (lambda (x) `(set! ,x (mtrace:untracef ,x ',x)))
  73.              *traced-procedures*)
  74.           '',*traced-procedures*))
  75.      `(begin ,@(map (lambda (x) `(set! ,x (mtrace:untracef ,x ',x))) x)))))
  76.  
  77. (defmacro:eval
  78.   '(defmacro trace x
  79.      (if (null? x) '*traced-procedures*
  80.      `(begin ,@(map (lambda (x) `(set! ,x (mtrace:tracef ,x ',x))) x)))))
  81. (defmacro:eval
  82.   '(defmacro untrace x
  83.      (if (null? x)
  84.      (slib:eval
  85.       `(begin ,@(map (lambda (x) `(set! ,x (mtrace:untracef ,x ',x)))
  86.              *traced-procedures*)
  87.           '',*traced-procedures*))
  88.      `(begin ,@(map (lambda (x) `(set! ,x (mtrace:untracef ,x ',x))) x)))))
  89.