home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / trace < prev    next >
Text File  |  1994-06-06  |  4KB  |  107 lines
  1. ;;;; "trace.scm" Utility macros for tracing in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'debug)            ;for the qp printer.
  21. (define debug:indent 0)
  22.  
  23. (define debug:tracef
  24.   (let ((null? null?)            ;These bindings are so that
  25.     (not not)            ;tracef will not trace parts
  26.     (car car) (cdr cdr)        ;of itself.
  27.     (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  28.     (apply apply) (display display) (qpn debug:qpn))
  29.     (lambda (function . optname)
  30.       (set! debug:indent 0)
  31.       (let ((name (if (null? optname) function (car optname))))
  32.     (lambda args
  33.       (cond ((and (not (null? args))
  34.               (eq? (car args) 'debug:untrace-object)
  35.               (null? (cdr args)))
  36.          function)
  37.         (else
  38.          (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
  39.          (apply qpn "CALLED" name args)
  40.          (set! debug:indent (modulo (+ 1 debug:indent) 8))
  41.          (let ((ans (apply function args)))
  42.            (set! debug:indent (modulo (+ -1 debug:indent) 8))
  43.            (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
  44.            (qpn "RETURNED" name ans)
  45.            ans))))))))
  46.  
  47. ;;; the reason I use a symbol for debug:untrace-object is so
  48. ;;; that functions can still be untraced if this file is read in twice.
  49.  
  50. (define (debug:untracef function)
  51.   (set! debug:indent 0)
  52.   (function 'debug:untrace-object))
  53.  
  54. ;;;;The trace: functions wrap around the debug: functions to provide
  55. ;;; niceties like keeping track of traced functions and dealing with
  56. ;;; redefinition.
  57.  
  58. (require 'alist)
  59. (define trace:adder (alist-associator eq?))
  60. (define trace:deler (alist-remover eq?))
  61.  
  62. (define *traced-procedures* '())
  63. (define (trace:tracef fun sym)
  64.   (cond ((not (procedure? fun))
  65.      (display "WARNING: not a procedure " (current-error-port))
  66.      (display sym (current-error-port))
  67.      (newline (current-error-port))
  68.      (set! *traced-procedures* (trace:deler *traced-procedures* sym))
  69.      fun)
  70.     (else
  71.      (let ((p (assq sym *traced-procedures*)))
  72.        (cond ((and p (eq? (cdr p) fun))
  73.           fun)
  74.          (else
  75.           (let ((tfun (debug:tracef fun sym)))
  76.             (set! *traced-procedures*
  77.               (trace:adder *traced-procedures* sym tfun))
  78.             tfun)))))))
  79.  
  80. (define (trace:untracef fun sym)
  81.   (let ((p (assq sym *traced-procedures*)))
  82.     (set! *traced-procedures* (trace:deler *traced-procedures* sym))
  83.     (cond ((not (procedure? fun)) fun)
  84.       ((not p) fun)
  85.       ((eq? (cdr p) fun)
  86.        (debug:untracef fun))
  87.       (else fun))))
  88.  
  89. (define tracef debug:tracef)
  90. (define untracef debug:untracef)
  91.  
  92. ;;;; Finally, the macros trace and untrace
  93.  
  94. (defmacro trace xs
  95.   (if (null? xs)
  96.       `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x)))
  97.              (map car *traced-procedures*))
  98.           (map car *traced-procedures*))
  99.       `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) xs))))
  100. (defmacro untrace xs
  101.   (if (null? xs)
  102.       (slib:eval
  103.        `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x)))
  104.               (map car *traced-procedures*))
  105.            '',(map car *traced-procedures*)))
  106.       `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) xs))))
  107.