Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!sun-barr!ccut!s.u-tokyo!is.s.u-tokyo!ken-w
From: ken-w@is.s.u-tokyo.ac.jp (WAKITA Ken)
Newsgroups: comp.lang.scheme
Subject: Re: trace in xscheme
Message-ID: <1526@malta.is.s.u-tokyo.ac.jp>
Date: 31 Oct 90 04:57:44 GMT
References: <28787@boulder.Colorado.EDU> <1520@malta.is.s.u-tokyo.ac.jp>
Sender: news@is.s.u-tokyo.ac.jp
Distribution: comp
Organization: Dept. of Information Science, the Univ. of Tokyo, Japan.
Lines: 314
In-reply-to: ken-w@is.s.u-tokyo.ac.jp's message of 30 Oct 90 18:07:12 JST


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.