diff options
Diffstat (limited to 'trace.scm')
| -rw-r--r-- | trace.scm | 254 |
1 files changed, 199 insertions, 55 deletions
@@ -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)))) |