* * debug.scm: *Warning* This feature is a bit premature. I add

it anyway because 1. it is very useful, and, 2. you can start
	making it less premature by complaining to me and by modifying
	the source! :-)
	(trace): Given one or more procedure objects, trace each one.
	Given no arguments, show all traced procedures.
	(untrace): Given one or more procedure objects, untrace each one.
	Given no arguments, untrace all traced procedures.  The tracing in
	Guile have an advantage to most other systems: We don't create new
	procedure objects, but mark the procedure objects themselves.
	This means that also anonymous and internal procedures can be
	traced.

	* boot-9.scm (error-catching-loop): Added handling of apply-frame
	and exit-frame exceptions.

*	* boot-9.scm (assert-repl-prompt, the-prompt-string): Removed.
	(set-repl-prompt!): Setter for repl prompt.
	(scm-style-repl): If prompt is #f, don't prompt; if prompt is a
	string, display it; if prompt is a thunk, call it and display its
	result; otherwise display "> ".
	(Change suggested by Roland Orre <orre@nada.kth.se>.)

ice-9/ChangeLog

@@ -1,4 +1,27 @@
-Fri Feb 28 00:00:50 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+Sat Mar  1 00:10:38 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+
+*	* debug.scm: *Warning* This feature is a bit premature.  I add
+ 	it anyway because 1. it is very useful, and, 2. you can start
+	making it less premature by complaining to me and by modifying
+	the source! :-)
+	(trace): Given one or more procedure objects, trace each one.
+  	Given no arguments, show all traced procedures.
+	(untrace): Given one or more procedure objects, untrace each one.
+  	Given no arguments, untrace all traced procedures.  The tracing in
+ 	Guile have an advantage to most other systems: We don't create new
+ 	procedure objects, but mark the procedure objects themselves.
+  	This means that also anonymous and internal procedures can be
+ 	traced.
+
+	* boot-9.scm (error-catching-loop): Added handling of apply-frame
+	and exit-frame exceptions.
+	
+*	* boot-9.scm (assert-repl-prompt, the-prompt-string): Removed.
+	(set-repl-prompt!): Setter for repl prompt.
+	(scm-style-repl): If prompt is #f, don't prompt; if prompt is a
+ 	string, display it; if prompt is a thunk, call it and display its
+ 	result; otherwise display "> ".
+  	(Change suggested by Roland Orre <orre@nada.kth.se>.)
 
 	* r4rs.scm (%load-verbosely): Reverted change to
  	`module-defined?', since the module system isn't bootstrapped when

ice-9/boot-9.scm

@@ -2139,10 +2139,12 @@
 (define scm-repl-verbose #f)
 (define (assert-repl-verbosity v) (set! scm-repl-verbose v))
 
-(define scm-repl-prompt #t)
+(define scm-repl-prompt "guile> ")
-(define (assert-repl-prompt v) (set! scm-repl-prompt v))
 
-(define the-prompt-string "guile> ")
+(define (set-repl-prompt! v) (set! scm-repl-prompt v))
+
+(define apply-frame-handler #f)
+(define exit-frame-handler #f)
 
 (define (error-catching-loop thunk)
   (define (loop first)
@@ -2165,9 +2167,16 @@
 		      #f)
 		    (lambda () (mask-signals))))
 
-		 (lambda args
+		 (lambda (key . args)
-		   (save-stack 1)
+		   (cond ((eq? key 'apply-frame)
-		   (apply throw args))))
+			  (and apply-frame-handler
+			       (apply apply-frame-handler key args)))
+			 ((eq? key 'exit-frame)
+			  (and exit-frame-handler
+			       (apply exit-frame-handler key args)))
+			 (else
+			  (save-stack 2)
+			  (apply throw key args))))))
 	     
 	     (lambda (key . args)
 	       (case key
@@ -2224,7 +2233,7 @@
 		 ((tk-stack)
 		  (apply make-stack #t save-stack tk-stack-mark narrowing))
 		 ((#t)
-		  (apply make-stack #t save-stack narrowing))
+		  (apply make-stack #t save-stack 0 1 narrowing))
 		 (else (let ((id (stack-id #t)))
 			 (and (procedure? id)
 			      (apply make-stack #t save-stack id narrowing))))))
@@ -2303,7 +2312,11 @@
 	   (-read (lambda ()
 		    (if scm-repl-prompt
 			(begin
-			  (display the-prompt-string)
+			  (display (cond ((string? scm-repl-prompt)
+					  scm-repl-prompt)
+					 ((thunk? scm-repl-prompt)
+					  (scm-repl-prompt))
+					 (else "> ")))
 			  (force-output)
 			  (repl-report-reset)))
 		    (and before-read-hook (before-read-hook))

ice-9/debug.scm

@@ -116,5 +116,99 @@
 ;;;
 (variable-set! (builtin-variable 'debug-options) debug-options)
 
+
+
+;;; {Trace}
+;;;
+(define traced-procedures '())
+
+(define-public (trace . args)
+  (if (null? args)
+      (nameify traced-procedures)
+      (begin
+	(for-each (lambda (proc)
+		    (set-procedure-property! proc 'trace #t)
+		    (if (not (memq proc traced-procedures))
+			(set! traced-procedures
+			      (cons proc traced-procedures))))
+		  args)
+	(set! apply-frame-handler trace-entry)
+	(set! exit-frame-handler trace-exit)
+	(set! trace-level 0)
+	(debug-enable 'trace)
+	(nameify args))))
+
+(define-public (untrace . args)
+  (if (and (null? args)
+	   (not (null? traced-procedures)))
+      (apply untrace traced-procedures)
+      (begin
+	(for-each (lambda (proc)
+		    (set-procedure-property! proc 'trace #f)
+		    (set! traced-procedures (delq! proc traced-procedures)))
+		  args)
+	(if (null? traced-procedures)
+	    (debug-disable 'trace))
+	(nameify args))))
+
+(define (nameify ls)
+  (map (lambda (proc)
+	 (let ((name (procedure-name proc)))
+	   (or name proc)))
+       ls))
+
+(define trace-level 0)
+
+(define (trace-entry key cont tail)
+  (dynamic-wind
+   (lambda ()
+     ;; We have to protect ourselves against the case that the user
+     ;; has chosen to trace a procedure used in the trace handler.
+     ;; Note that debug-disable is a very slow operation.
+     ;; This is not an ideal solution. *fixme*
+     (debug-disable 'trace))
+   (lambda ()
+     (let ((cep (current-error-port))
+	   (frame (last-stack-frame cont)))
+       (if (not tail)
+	   (set! trace-level (+ trace-level 1)))
+       (let indent ((n trace-level))
+	 (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
+       (display-application frame cep)
+       (newline cep)
+       ;; It's not necessary to call the continuation since
+       ;; execution will continue if the handler returns
+       ;(cont #f)
+       ))
+   (lambda ()
+     (debug-enable 'trace))))
+
+(define (trace-exit key cont retval)
+  (dynamic-wind
+   (lambda ()
+     (debug-disable 'trace))
+   (lambda ()
+     (let ((cep (current-error-port)))
+       (set! trace-level (- trace-level 1))
+       (let indent ((n trace-level))
+	 (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
+       (write retval cep)
+       (newline cep)))
+   (lambda ()
+     (debug-enable 'trace))))
+
+(define (display-application frame port)
+  (display #\[ port)
+  (display (car (unmemoize (frame-source frame))) port)
+  (let loop ((args (frame-arguments frame)))
+    (if (not (null? args))
+	(begin
+	  (display #\space port)
+	  (write (car args) port)
+	  (loop (cdr args)))))
+  (display #\] port))
+
+
+
 (debug-enable 'debug)
 (read-enable 'positions)