module/slib/trace.scm

   1 ;;;; "trace.scm" Utility macros for tracing in Scheme.
   2 ;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000 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 'qp)                           ;for the qp printer.
  21 (define trace:indent 0)
  22 (define debug:call-stack '())           ;keeps track of call stack.
  23 (define debug:max-count 5)
  24
  25 ;;Formats for call-stack elements:
  26 ;; (procedure-count name . args)        ;for debug:track procedure
  27 ;; (procedure-count name)               ;for debug:stack procedure
  28 ;;Traced functions also stack.
  29
  30 (define print-call-stack
  31   (let ((car car) (null? null?) (current-error-port current-error-port)
  32         (qpn qpn) (for-each for-each))
  33     (lambda cep
  34       (set! cep (if (null? cep) (current-error-port) (car cep)))
  35       (for-each qpn debug:call-stack))))
  36
  37 (define (call-stack-news? name)
  38   (or (null? debug:call-stack)
  39       (not (eq? name (cadar debug:call-stack)))
  40       (< (caar debug:call-stack) debug:max-count)))
  41
  42 (define debug:trace-procedure
  43   (let ((null? null?) (not not)         ;These bindings are so that
  44         (cdar cdar) (cadar cadar)       ;trace will not trace parts
  45         (car car) (cdr cdr) (caar caar) ;of itself.
  46         (eq? eq?) (+ +) (zero? zero?) (modulo modulo)
  47         (apply apply) (display display) (qpn qpn) (list list) (cons cons)
  48
  49         (CALL (string->symbol "CALL"))
  50         (RETN (string->symbol "RETN")))
  51     (lambda (how function . optname)
  52       (set! trace:indent 0)
  53       (let ((name (if (null? optname) function (car optname))))
  54         (case how
  55           ((trace)
  56            (lambda args
  57              (cond ((and (not (null? args))
  58                          (eq? (car args) 'debug:untrace-object)
  59                          (null? (cdr args)))
  60                     function)
  61                    ((call-stack-news? name)
  62                     (let ((cs debug:call-stack))
  63                       (set! debug:call-stack
  64                             (if (and (not (null? debug:call-stack))
  65                                      (eq? name (cadar debug:call-stack)))
  66                                 (cons (cons (+ 1 (caar debug:call-stack))
  67                                             (cdar debug:call-stack))
  68                                       (cdr debug:call-stack))
  69                                 (cons (list 1 name) debug:call-stack)))
  70                       (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
  71                       (apply qpn CALL name args)
  72                       (set! trace:indent (modulo (+ 1 trace:indent) 16))
  73                       (let ((ans (apply function args)))
  74                         (set! trace:indent (modulo (+ -1 trace:indent) 16))
  75                         (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
  76                         (qpn RETN name ans)
  77                         (set! debug:call-stack cs)
  78                         ans)))
  79                    (else (apply function args)))))
  80           ((track)
  81            (lambda args
  82              (cond ((and (not (null? args))
  83                          (eq? (car args) 'debug:untrace-object)
  84                          (null? (cdr args)))
  85                     function)
  86                    ((call-stack-news? name)
  87                     (let ((cs debug:call-stack))
  88                       (set! debug:call-stack
  89                             (if (and (not (null? debug:call-stack))
  90                                      (eq? name (cadar debug:call-stack)))
  91                                 (cons (cons (+ 1 (caar debug:call-stack))
  92                                             (cdar debug:call-stack))
  93                                       (cdr debug:call-stack))
  94                                 (cons (cons 1 (cons name args))
  95                                       debug:call-stack)))
  96                       (let ((ans (apply function args)))
  97                         (set! debug:call-stack cs)
  98                         ans)))
  99                    (else (apply function args)))))
 100           ((stack)
 101            (lambda args
 102              (cond ((and (not (null? args))
 103                          (eq? (car args) 'debug:untrace-object)
 104                          (null? (cdr args)))
 105                     function)
 106                    ((call-stack-news? name)
 107                     (let ((cs debug:call-stack))
 108                       (set! debug:call-stack
 109                             (if (and (not (null? debug:call-stack))
 110                                      (eq? name (cadar debug:call-stack)))
 111                                 (cons (cons (+ 1 (caar debug:call-stack))
 112                                             (cdar debug:call-stack))
 113                                       (cdr debug:call-stack))
 114                                 (cons (list 1 name) debug:call-stack)))
 115                       (let ((ans (apply function args)))
 116                         (set! debug:call-stack cs)
 117                         ans)))
 118                    (else (apply function args)))))
 119           (else
 120            (slib:error 'debug:trace-procedure 'unknown 'how '= how)))))))
 121
 122 ;;; The reason I use a symbol for debug:untrace-object is so that
 123 ;;; functions can still be untraced if this file is read in twice.
 124
 125 (define (untracef function)
 126   (set! trace:indent 0)
 127   (function 'debug:untrace-object))
 128
 129 ;;;;The trace: functions wrap around the debug: functions to provide
 130 ;;; niceties like keeping track of traced functions and dealing with
 131 ;;; redefinition.
 132
 133 (require 'alist)
 134 (define trace:adder (alist-associator eq?))
 135 (define trace:deler (alist-remover eq?))
 136
 137 (define *traced-procedures* '())
 138 (define *tracked-procedures* '())
 139 (define *stacked-procedures* '())
 140 (define (trace:trace-procedure how fun sym)
 141   (define cep (current-error-port))
 142   (cond ((not (procedure? fun))
 143          (display "WARNING: not a procedure " cep)
 144          (display sym cep)
 145          (newline cep)
 146          (set! *traced-procedures* (trace:deler *traced-procedures* sym))
 147          (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
 148          (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
 149          fun)
 150         (else
 151          (let ((p (assq sym (case how
 152                               ((trace) *traced-procedures*)
 153                               ((track) *tracked-procedures*)
 154                               ((stack) *stacked-procedures*)))))
 155            (cond ((and p (eq? (cdr p) fun))
 156                   fun)
 157                  (else
 158                   (let ((tfun (debug:trace-procedure how fun sym)))
 159                     (case how
 160                       ((trace)
 161                        (set! *traced-procedures*
 162                              (trace:adder *traced-procedures* sym tfun)))
 163                       ((track)
 164                        (set! *tracked-procedures*
 165                              (trace:adder *tracked-procedures* sym tfun)))
 166                       ((stack)
 167                        (set! *stacked-procedures*
 168                              (trace:adder *stacked-procedures* sym tfun))))
 169                     tfun)))))))
 170
 171 (define (trace:untrace-procedure fun sym)
 172   (define finish
 173     (lambda (p)
 174       (cond ((not (procedure? fun)) fun)
 175             ((eq? (cdr p) fun) (untracef fun))
 176             (else fun))))
 177   (cond ((assq sym *traced-procedures*)
 178          =>
 179          (lambda (p)
 180            (set! *traced-procedures* (trace:deler *traced-procedures* sym))
 181            (finish p)))
 182         ((assq sym *tracked-procedures*)
 183          =>
 184          (lambda (p)
 185            (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
 186            (finish p)))
 187         ((assq sym *stacked-procedures*)
 188          =>
 189          (lambda (p)
 190            (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
 191            (finish p)))
 192         (else fun)))
 193
 194 (define (tracef . args) (apply debug:trace-procedure 'trace args))
 195 (define (trackf . args) (apply debug:trace-procedure 'track args))
 196 (define (stackf . args) (apply debug:trace-procedure 'stack args))
 197
 198 ;;;; Finally, the macros trace and untrace
 199
 200 (defmacro trace xs
 201   (if (null? xs)
 202       `(begin (set! trace:indent 0)
 203               ,@(map (lambda (x)
 204                        `(set! ,x (trace:trace-procedure 'trace ,x ',x)))
 205                      (map car *traced-procedures*))
 206               (map car *traced-procedures*))
 207       `(begin ,@(map (lambda (x)
 208                        `(set! ,x (trace:trace-procedure 'trace ,x ',x))) xs))))
 209 (defmacro track xs
 210   (if (null? xs)
 211       `(begin ,@(map (lambda (x)
 212                        `(set! ,x (trace:trace-procedure 'track ,x ',x)))
 213                      (map car *tracked-procedures*))
 214               (map car *tracked-procedures*))
 215       `(begin ,@(map (lambda (x)
 216                        `(set! ,x (trace:trace-procedure 'track ,x ',x))) xs))))
 217 (defmacro stack xs
 218   (if (null? xs)
 219       `(begin ,@(map (lambda (x)
 220                        `(set! ,x (trace:trace-procedure 'stack ,x ',x)))
 221                      (map car *stacked-procedures*))
 222               (map car *stacked-procedures*))
 223       `(begin ,@(map (lambda (x)
 224                        `(set! ,x (trace:trace-procedure 'stack ,x ',x))) xs))))
 225
 226 (defmacro untrace xs
 227   (if (null? xs)
 228       (slib:eval
 229        `(begin ,@(map (lambda (x)
 230                         `(set! ,x (trace:untrace-procedure ,x ',x)))
 231                       (map car *traced-procedures*))
 232                '',(map car *traced-procedures*)))
 233       `(begin ,@(map (lambda (x)
 234                        `(set! ,x (trace:untrace-procedure ,x ',x))) xs))))
 235
 236 (defmacro untrack xs
 237   (if (null? xs)
 238       (slib:eval
 239        `(begin ,@(map (lambda (x)
 240                         `(set! ,x (track:untrack-procedure ,x ',x)))
 241                       (map car *tracked-procedures*))
 242                '',(map car *tracked-procedures*)))
 243       `(begin ,@(map (lambda (x)
 244                        `(set! ,x (track:untrack-procedure ,x ',x))) xs))))
 245
 246 (defmacro unstack xs
 247   (if (null? xs)
 248       (slib:eval
 249        `(begin ,@(map (lambda (x)
 250                         `(set! ,x (stack:unstack-procedure ,x ',x)))
 251                       (map car *stacked-procedures*))
 252                '',(map car *stacked-procedures*)))
 253       `(begin ,@(map (lambda (x)
 254                        `(set! ,x (stack:unstack-procedure ,x ',x))) xs))))