summaryrefslogtreecommitdiffstats
path: root/trace.scm
diff options
context:
space:
mode:
Diffstat (limited to 'trace.scm')
-rw-r--r--trace.scm254
1 files changed, 199 insertions, 55 deletions
diff --git a/trace.scm b/trace.scm
index 3476548..aa2c3d7 100644
--- a/trace.scm
+++ b/trace.scm
@@ -1,9 +1,9 @@
;;;; "trace.scm" Utility macros for tracing in Scheme.
-;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
+;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000 Aubrey Jaffer
;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -18,40 +18,112 @@
;each case.
(require 'qp) ;for the qp printer.
-(define debug:indent 0)
+(define trace:indent 0)
+(define debug:call-stack '()) ;keeps track of call stack.
+(define debug:max-count 5)
-(define debug:tracef
- (let ((null? null?) ;These bindings are so that
- (not not) ;tracef will not trace parts
- (car car) (cdr cdr) ;of itself.
+;;Formats for call-stack elements:
+;; (procedure-count name . args) ;for debug:track procedure
+;; (procedure-count name) ;for debug:stack procedure
+;;Traced functions also stack.
+
+(define print-call-stack
+ (let ((car car) (null? null?) (current-error-port current-error-port)
+ (qpn qpn) (for-each for-each))
+ (lambda cep
+ (set! cep (if (null? cep) (current-error-port) (car cep)))
+ (for-each qpn debug:call-stack))))
+
+(define (call-stack-news? name)
+ (or (null? debug:call-stack)
+ (not (eq? name (cadar debug:call-stack)))
+ (< (caar debug:call-stack) debug:max-count)))
+
+(define debug:trace-procedure
+ (let ((null? null?) (not not) ;These bindings are so that
+ (cdar cdar) (cadar cadar) ;trace will not trace parts
+ (car car) (cdr cdr) (caar caar) ;of itself.
(eq? eq?) (+ +) (zero? zero?) (modulo modulo)
- (apply apply) (display display) (qpn qpn)
+ (apply apply) (display display) (qpn qpn) (list list) (cons cons)
(CALL (string->symbol "CALL"))
(RETN (string->symbol "RETN")))
- (lambda (function . optname)
- (set! debug:indent 0)
+ (lambda (how function . optname)
+ (set! trace:indent 0)
(let ((name (if (null? optname) function (car optname))))
- (lambda args
- (cond ((and (not (null? args))
- (eq? (car args) 'debug:untrace-object)
- (null? (cdr args)))
- function)
- (else
- (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
- (apply qpn CALL name args)
- (set! debug:indent (modulo (+ 1 debug:indent) 16))
- (let ((ans (apply function args)))
- (set! debug:indent (modulo (+ -1 debug:indent) 16))
- (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
- (qpn RETN name ans)
- ans))))))))
-
-;;; the reason I use a symbol for debug:untrace-object is so
-;;; that functions can still be untraced if this file is read in twice.
-
-(define (debug:untracef function)
- (set! debug:indent 0)
+ (case how
+ ((trace)
+ (lambda args
+ (cond ((and (not (null? args))
+ (eq? (car args) 'debug:untrace-object)
+ (null? (cdr args)))
+ function)
+ ((call-stack-news? name)
+ (let ((cs debug:call-stack))
+ (set! debug:call-stack
+ (if (and (not (null? debug:call-stack))
+ (eq? name (cadar debug:call-stack)))
+ (cons (cons (+ 1 (caar debug:call-stack))
+ (cdar debug:call-stack))
+ (cdr debug:call-stack))
+ (cons (list 1 name) debug:call-stack)))
+ (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
+ (apply qpn CALL name args)
+ (set! trace:indent (modulo (+ 1 trace:indent) 16))
+ (let ((ans (apply function args)))
+ (set! trace:indent (modulo (+ -1 trace:indent) 16))
+ (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
+ (qpn RETN name ans)
+ (set! debug:call-stack cs)
+ ans)))
+ (else (apply function args)))))
+ ((track)
+ (lambda args
+ (cond ((and (not (null? args))
+ (eq? (car args) 'debug:untrace-object)
+ (null? (cdr args)))
+ function)
+ ((call-stack-news? name)
+ (let ((cs debug:call-stack))
+ (set! debug:call-stack
+ (if (and (not (null? debug:call-stack))
+ (eq? name (cadar debug:call-stack)))
+ (cons (cons (+ 1 (caar debug:call-stack))
+ (cdar debug:call-stack))
+ (cdr debug:call-stack))
+ (cons (cons 1 (cons name args))
+ debug:call-stack)))
+ (let ((ans (apply function args)))
+ (set! debug:call-stack cs)
+ ans)))
+ (else (apply function args)))))
+ ((stack)
+ (lambda args
+ (cond ((and (not (null? args))
+ (eq? (car args) 'debug:untrace-object)
+ (null? (cdr args)))
+ function)
+ ((call-stack-news? name)
+ (let ((cs debug:call-stack))
+ (set! debug:call-stack
+ (if (and (not (null? debug:call-stack))
+ (eq? name (cadar debug:call-stack)))
+ (cons (cons (+ 1 (caar debug:call-stack))
+ (cdar debug:call-stack))
+ (cdr debug:call-stack))
+ (cons (list 1 name) debug:call-stack)))
+ (let ((ans (apply function args)))
+ (set! debug:call-stack cs)
+ ans)))
+ (else (apply function args)))))
+ (else
+ (slib:error 'debug:trace-procedure 'unknown 'how '= how)))))))
+
+;;; The reason I use a symbol for debug:untrace-object is so that
+;;; functions can still be untraced if this file is read in twice.
+
+(define (untracef function)
+ (set! trace:indent 0)
(function 'debug:untrace-object))
;;;;The trace: functions wrap around the debug: functions to provide
@@ -63,48 +135,120 @@
(define trace:deler (alist-remover eq?))
(define *traced-procedures* '())
-(define (trace:tracef fun sym)
+(define *tracked-procedures* '())
+(define *stacked-procedures* '())
+(define (trace:trace-procedure how fun sym)
+ (define cep (current-error-port))
(cond ((not (procedure? fun))
- (display "WARNING: not a procedure " (current-error-port))
- (display sym (current-error-port))
- (newline (current-error-port))
+ (display "WARNING: not a procedure " cep)
+ (display sym cep)
+ (newline cep)
(set! *traced-procedures* (trace:deler *traced-procedures* sym))
+ (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
+ (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
fun)
(else
- (let ((p (assq sym *traced-procedures*)))
+ (let ((p (assq sym (case how
+ ((trace) *traced-procedures*)
+ ((track) *tracked-procedures*)
+ ((stack) *stacked-procedures*)))))
(cond ((and p (eq? (cdr p) fun))
fun)
(else
- (let ((tfun (debug:tracef fun sym)))
- (set! *traced-procedures*
- (trace:adder *traced-procedures* sym tfun))
+ (let ((tfun (debug:trace-procedure how fun sym)))
+ (case how
+ ((trace)
+ (set! *traced-procedures*
+ (trace:adder *traced-procedures* sym tfun)))
+ ((track)
+ (set! *tracked-procedures*
+ (trace:adder *tracked-procedures* sym tfun)))
+ ((stack)
+ (set! *stacked-procedures*
+ (trace:adder *stacked-procedures* sym tfun))))
tfun)))))))
-(define (trace:untracef fun sym)
- (let ((p (assq sym *traced-procedures*)))
- (set! *traced-procedures* (trace:deler *traced-procedures* sym))
- (cond ((not (procedure? fun)) fun)
- ((not p) fun)
- ((eq? (cdr p) fun)
- (debug:untracef fun))
- (else fun))))
+(define (trace:untrace-procedure fun sym)
+ (define finish
+ (lambda (p)
+ (cond ((not (procedure? fun)) fun)
+ ((eq? (cdr p) fun) (untracef fun))
+ (else fun))))
+ (cond ((assq sym *traced-procedures*)
+ =>
+ (lambda (p)
+ (set! *traced-procedures* (trace:deler *traced-procedures* sym))
+ (finish p)))
+ ((assq sym *tracked-procedures*)
+ =>
+ (lambda (p)
+ (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
+ (finish p)))
+ ((assq sym *stacked-procedures*)
+ =>
+ (lambda (p)
+ (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
+ (finish p)))
+ (else fun)))
-(define tracef debug:tracef)
-(define untracef debug:untracef)
+(define (tracef . args) (apply debug:trace-procedure 'trace args))
+(define (trackf . args) (apply debug:trace-procedure 'track args))
+(define (stackf . args) (apply debug:trace-procedure 'stack args))
;;;; Finally, the macros trace and untrace
(defmacro trace xs
(if (null? xs)
- `(begin (set! debug:indent 0)
- ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x)))
+ `(begin (set! trace:indent 0)
+ ,@(map (lambda (x)
+ `(set! ,x (trace:trace-procedure 'trace ,x ',x)))
(map car *traced-procedures*))
(map car *traced-procedures*))
- `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) xs))))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:trace-procedure 'trace ,x ',x))) xs))))
+(defmacro track xs
+ (if (null? xs)
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:trace-procedure 'track ,x ',x)))
+ (map car *tracked-procedures*))
+ (map car *tracked-procedures*))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:trace-procedure 'track ,x ',x))) xs))))
+(defmacro stack xs
+ (if (null? xs)
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:trace-procedure 'stack ,x ',x)))
+ (map car *stacked-procedures*))
+ (map car *stacked-procedures*))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:trace-procedure 'stack ,x ',x))) xs))))
+
(defmacro untrace xs
(if (null? xs)
(slib:eval
- `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x)))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:untrace-procedure ,x ',x)))
(map car *traced-procedures*))
'',(map car *traced-procedures*)))
- `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) xs))))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (trace:untrace-procedure ,x ',x))) xs))))
+
+(defmacro untrack xs
+ (if (null? xs)
+ (slib:eval
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (track:untrack-procedure ,x ',x)))
+ (map car *tracked-procedures*))
+ '',(map car *tracked-procedures*)))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (track:untrack-procedure ,x ',x))) xs))))
+
+(defmacro unstack xs
+ (if (null? xs)
+ (slib:eval
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (stack:unstack-procedure ,x ',x)))
+ (map car *stacked-procedures*))
+ '',(map car *stacked-procedures*)))
+ `(begin ,@(map (lambda (x)
+ `(set! ,x (stack:unstack-procedure ,x ',x))) xs))))