grunwald@foobar.colorado.edu (Dirk Grunwald) (10/27/90)
I'm using xscheme-0.22 for a class in programming languages. There's
no trace facility, so I wrote one. I'm wondering if anyone has written
any other debugging facilities; my students are having a tough time
with debugging xscheme programs.
In case others find it useful, here's the trace package I wrote:
;;
;; Tracing package (of a sorts) by Dirk Grunwald, Oct. 1990
;;
;; (trace list of function names) will trace the execution of those
;; functions.
;;
;; Redefining a function will cause it to loose its tracing information.
;; You can say (trace ...) again to resume tracing of it.
;;
;; (untrace list of function names) will disable tracing for those functions.
;; (untrace) will disable tracing on all functions.
;;
;; Untracing a function will restore the function as it was when you
;; traced it. Thus, you should be leary of untracing things. You should
;; probably just untrace everything, reload your file and then continue.
;;
;; E.g.,, if you execute:
;;
;; (define (foo a b) (+ a b))
;; (trace foo)
;; (define (foo a b) (- a b))
;; (untrace foo)
;; (foo 20 10)
;;
;; The output will be ``30'' not ``10'' as you might expect.
;;
(set! *trace-alist* nil)
(define (*trace-mkassoc* x y alist)
(if (null? alist)
(list (list x y))
(if (eqv? x (caar alist))
;; then
(cons (list x y) (cdr alist))
;; else
(cons (car alist) (*trace-mkassoc* x y (cdr alist)))
)
)
)
(define (*trace-delassoc* x alist)
(if (null? alist)
nil
(if (eqv? x (caar alist))
;; then
(cdr alist)
;; else
(cons (car alist) (*trace-delassoc* x (cdr alist)))
)
)
)
(set! *trace-levels* 0)
(define (*trace-space*)
(let
((i *trace-levels*))
(while (> i 0)
(begin
(display " ")
(set! i (-1+ i))
)
)
)
)
(define (trace-handler form)
(let* (
(fcn (cadr form))
(fcn-assoc (assoc fcn *trace-alist*))
)
(if (not (bound? fcn))
(begin
(display "Can't find function ") (display fcn) (newline)
nil
)
(begin
(set! *trace-alist*
(*trace-mkassoc* fcn (symbol-value fcn) *trace-alist*))
(%expand-macros
`(set! ,fcn
(lambda args
(let ((*value* nil))
(begin
(set! *trace-levels* (+ *trace-levels* 1))
(*trace-space*)
(display "Entering ") (display ',fcn)
(display ": w/args ") (display args) (newline)
(set! *value* (apply ,(symbol-value fcn) args))
(*trace-space*)
(display "Exiting ") (display ',fcn)
(display " w/value ") (display *value*) (newline)
(set! *trace-levels* (- *trace-levels* 1))
*value*
)
)
)
)
)
)
)
)
)
(define (trace-pre-handler form)
(let
((return-value nil))
(cond
((= (length form) 1) (begin
(display "Trace all") (newline)
(set! return-value
(cons 'begin
(map (lambda (x)
(trace-handler
(list 'trace x)))
(map car *trace-alist*))
)
)
)
)
(else (set! return-value (cons
'begin
(map (lambda (x) (trace-handler (list 'trace x)))
(cdr form)
)
)
)
)
)
(display "Now tracing: ")
(display (map car *trace-alist*))
(newline)
return-value
)
)
(compiler-syntax trace trace-pre-handler)
(define (untrace-handler form)
(let* (
(fcn (cadr form))
(fcn-assoc (assoc fcn *trace-alist*))
)
(if (not fcn-assoc)
(begin
(display "Not tracing ") (display fcn) (newline)
nil)
(begin
(set! *trace-alist* (*trace-delassoc* fcn *trace-alist*))
(display "Untracing ") (display fcn) (newline)
`(set! ,fcn ,(cadr fcn-assoc))
)
)
)
)
(define (untrace-pre-handler form)
(let
((return-value nil))
(cond
((= (length form) 1) (begin
(display "Untrace all") (newline)
(set! return-value
(cons 'begin
(map (lambda (x)
(untrace-handler
(list 'untrace x)))
(map car *trace-alist*))
)
)
)
)
(else (set! return-value
(cons 'begin
(map (lambda (x) (untrace-handler (list 'untrace x)))
(cdr form)))
)
)
)
return-value
)
)
(compiler-syntax untrace untrace-pre-handler)
(macro top-level
(lambda ()
(begin
(set! *trace-level* 0)
(reset)
)
)
)ken-w@is.s.u-tokyo.ac.jp (WAKITA Ken) (10/30/90)
In article <28787@boulder.Colorado.EDU> grunwald@foobar.colorado.edu (Dirk Grunwald) writes: > From: grunwald@foobar.colorado.edu (Dirk Grunwald) > Newsgroups: comp.lang.scheme > Date: 27 Oct 90 12:56:05 JST > Sender: news@boulder.Colorado.EDU > Reply-To: grunwald@foobar.colorado.edu > Distribution: comp > Organization: University of Colorado at Boulder > Lines: 205 > > > I'm using xscheme-0.22 for a class in programming languages. There's > no trace facility, so I wrote one. I'm wondering if anyone has written > any other debugging facilities; my students are having a tough time > with debugging xscheme programs. ELK does not provide trace facility. So, I've also written similar, shorter, but a bit dangerous program. Though it contains several known bugs (it can't trace macros and primitive procedures) it is useful. I also have written a toplevel eval-read-print loop to support transcript-on/off facility. An interested reader can request via E-mail to: ken-w@is.s.u-tokyo.ac.jp ---------------------------------------------------------------------- (define trace) (define untrace) (let () (define trace-list '(())) (define (reset-trace) (set! trace-list '(()))) (define-macro (the-trace func) `(let ((the-func (eval ,func)) (result #v)) (if (assoc ',func ,trace-list) (error 'trace "~s already trace on." ,func)) (if (not (compound? ,func)) (error 'trace "wrong argument type ~s (expected compound)" (type ,func))) (set! ,trace-list (cons () (cons (cons ',func the-func) (cdr ,trace-list)))) (set! ,func (lambda param-list (format #t "# Entering ~s~%" (cons ',func param-list)) (set! result (apply the-func param-list)) (format #t "# Exiting ~s ==> ~s~%" (cons ',func param-list) result) result)))) (print (type the-trace)) (define-macro (the-untrace func) `(let ((the-func (assoc ',func ,trace-list))) (define (remove! func) (let ((prev ,trace-list) (here (cdr ,trace-list))) (while (and here (not (eq? func (caar here)))) (set! prev here) (set! here (cdr here))) (if (not here) (error 'remove "item ~s not found." func) (set-cdr! prev (cdr here))))) (if the-func (begin (remove! ',func) (set! ,func (cdr the-func)))))) (print (type the-untrace)) (set! trace the-trace) (set! untrace the-untrace)) ---------------------------------------------------------------------- -- WAKITA Ken (ken-w@is.s.u-tokyo.ac.jp) Masuda Group., Dept. of Info. Sci., Univ. of Tokyo.
ken-w@is.s.u-tokyo.ac.jp (WAKITA Ken) (10/31/90)
In article <1520@malta.is.s.u-tokyo.ac.jp> WAKITA Ken writes: > ELK does not provide trace facility. So, I've also written > similar, shorter, but a bit dangerous program. Though it contains > several known bugs (it can't trace macros and primitive procedures) it > is useful. I also have written a toplevel eval-read-print loop to > support transcript-on/off facility. An interested reader can request > via E-mail to: > > ken-w@is.s.u-tokyo.ac.jp > > ---------------------------------------------------------------------- > (define trace) > (define untrace) ..... ..... > (set! trace the-trace) > (set! untrace the-untrace)) > ---------------------------------------------------------------------- After this post, I found a terrible mistake. The code previously posted does not work at all. Actually, that is an older version that mis-uses macro. Please forgive me. Here is a correct version and sample session. Several people sent me a E-mail asking for transcript-on/off function. So I also provide together. The sample session is produced by transcript-on/off. ---------------------------------------------------------------------- (define trc:trace-list '(())) (define (reset-trace) (set! trc:trace-list '(()))) (define-macro (trace func) `(let ((the-func (eval ,func)) (result #v)) (if (assoc ',func trc:trace-list) (error 'trace "~s already trace on." ,func)) (if (not (compound? ,func)) (error 'trace "wrong argument type ~s (expected compound)" (type ,func))) (set! trc:trace-list (cons () (cons (cons ',func the-func) (cdr trc:trace-list)))) (set! ,func (lambda param-list (format #t "# Entering ~s~%" (cons ',func param-list)) (set! result (apply the-func param-list)) (format #t "# Exiting ~s ==> ~s~%" (cons ',func param-list) result) result)))) (define-macro (untrace func) `(let ((the-func (assoc ',func trc:trace-list))) (define (remove! func) (let ((prev trc:trace-list) (here (cdr trc:trace-list))) (while (and here (not (eq? func (caar here)))) (set! prev here) (set! here (cdr here))) (if (not here) (error 'remove "item ~s not found." func) (set-cdr! prev (cdr here))))) (if the-func (begin (remove! ',func) (set! ,func (cdr the-func)))))) ---------------------------------------------------------------------- ;;; -*-Scheme-*- ;;; ;;; Read-eval-print loop and error handler (define call/cc call-with-current-continuation) (fluid-let ((autoload-notify? #f)) (require 'macros)) ;;; (set! load-noisily? #t) ;(require 'usr:set-load-path (tilde-expand "~/lang/elk/lib/set-load-path.scm")) ;(require 'usr:load-all "load-all.scm") (define ?) (define ??) (define ???) (define !) (define !!) (define !!!) (define &) (define elk:pre-prompt " User name ") (define elk:post-prompt "> ") (define elk:ans-prompt " ==> ") (define transcript-on) (define transcript-off) (define elk:transcript-port #f) (let ((elk:default-transcript-file "scheme.log") (elk:write write) (elk:display display) (elk:write-char write-char) (elk:newline newline) (elk:print print) (elk:format format)) (set! transcript-on (lambda ( . file) (if (output-port? elk:transcript-port) (error 'transcript-on "Transcript file ~s already open" (port-file-name elk:transcript-port))) (set! elk:transcript-port (open-output-file (if (null? file) elk:default-transcript-file (car file)))))) (set! transcript-off (lambda () (if (not (output-port? elk:transcript-port)) (error 'transcript-off "Transcript file not open.")) (close-port elk:transcript-port) (set! elk:transcript-port #f))) (set! write (lambda (obj . port) (if port (elk:write obj (car port)) (begin (elk:write obj) (if elk:transcript-port (elk:write obj elk:transcript-port)) #v)))) (set! display (lambda (obj . port) (if port (elk:display obj (car port)) (begin (elk:display obj) (if elk:transcript-port (elk:display obj elk:transcript-port)) #v)))) (set! write-char (lambda (char . port) (if port (elk:write-char char (car port)) (begin (elk:write-char char) (if elk:transcript-port (elk:write-char char elk:transcript-port)) #v)))) (set! newline (lambda ( . port) (if port (elk:newline (car port)) (begin (elk:newline) (if elk:transcript-port (elk:newline elk:transcript-port)) #v)))) (set! print (lambda (obj . port) (if port (elk:print obj (car port)) (begin (elk:print obj) (if elk:transcript-port (elk:print obj elk:transcript-port)) #v)))) (set! format (lambda (tty fmt . rest) (let ((res (apply elk:format `(#f ,fmt ,@rest)))) (if tty (display res) res))))) (define (rep-loop env) (define input) (define value) (let loop () (set! ??? ??) (set! ?? ?) (set! ? &) ;;; X Windows hack (if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy)) (display-flush-output dpy)) (display elk:pre-prompt) (if (> rep-level 0) (begin (display rep-level) (display " "))) (display elk:post-prompt) (set! input (read)) (set! & input) (if elk:transcript-port (begin (display input elk:transcript-port) (newline elk:transcript-port))) (if (not (eof-object? input)) (begin (set! value (eval input env)) (set! !!! !!) (set! !! !) (set! ! value) (display elk:ans-prompt) (if (void? value) (write "#v") (write value)) (newline) (newline) (loop))))) (define rep-frames) (define rep-level) (set! interrupt-handler (lambda () (display (format #f "~%\7Interrupt!~%")) (let ((next-frame (car rep-frames))) (next-frame #t)))) (define-macro (push-frame control-point) `(begin (set! rep-frames (cons ,control-point rep-frames)) (set! rep-level (1+ rep-level)))) (define-macro (pop-frame) '(begin (set! rep-frames (cdr rep-frames)) (set! rep-level (1- rep-level)))) (define (error-print error-msg) (let ((head (format #f "~s: " (car error-msg))) (tail (apply format `(#f ,@(cdr error-msg))))) (display head) (display tail) (newline))) (set! error-handler (lambda error-msg (error-print error-msg) (let loop ((just-called #t)) (if (call-with-current-continuation (lambda (control-point) (if just-called (push-frame control-point)) (rep-loop (the-environment)) #f)) (loop #f))) (newline) (pop-frame) (let ((next-frame (car rep-frames))) (next-frame #t)))) (define top-level-environment (the-environment)) (define (top-level) (if (not (call-with-current-continuation (lambda (control-point) (set! rep-frames (list control-point)) (set! top-level-control-point control-point) (set! rep-level 0) (rep-loop top-level-environment) #f))) (display (format #f " You can't leave toplevel by `^D'. Use \"(exit)\" instead.~%"))) (top-level)) (define (the-top-level) (top-level)) ;(load "logo.scm") (if (not (bound? 'elk:make-scheme)) (the-top-level)) ---------------------------------------------------------------------- ==> #f Ken > (define (f x) (if (= x 0) 1 (* x (f (- x 1))))) ==> f Ken > (trace f) ==> #[compound f] Ken > (f 5) # Entering (f 5) # Entering (f 4) # Entering (f 3) # Entering (f 2) # Entering (f 1) # Entering (f 0) # Exiting (f 0) ==> 1 # Exiting (f 1) ==> 1 # Exiting (f 2) ==> 2 # Exiting (f 3) ==> 6 # Exiting (f 4) ==> 24 # Exiting (f 5) ==> 120 ==> 120 Ken > (transcript-off) ---------------------------------------------------------------------- -- WAKITA Ken (ken-w@is.s.u-tokyo.ac.jp) Masuda Group., Dept. of Info. Sci., Univ. of Tokyo.