* configure.in: Generate Makefile for ice-9/debugging.

* debugging/trc.scm: New file.

* debugging/traps.scm: New file.

* debugging/trace.scm: New file.

* debugging/steps.scm: New file.

* debugging/load-hooks.scm: New file.

* debugging/ice-9-debugger-extensions.scm: New file.

* debugging/example-fns.scm: New file.

* debugging/breakpoints.scm: New file.

* debugging/Makefile.am: New.

* Makefile.am (SUBDIRS): Add debugging.

ChangeLog

@@ -1,3 +1,7 @@
+2006-08-18  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* configure.in: Generate Makefile for ice-9/debugging.
+
 2006-06-13  Ludovic Courtès  <ludovic.courtes@laas.fr>
 
 	* NEWS: Mentioned the new behavior of `equal?' for structures.

configure.in

@@ -1231,6 +1231,7 @@ AC_CONFIG_FILES([
   guile-config/Makefile
   ice-9/Makefile
   ice-9/debugger/Makefile
+  ice-9/debugging/Makefile
   lang/Makefile
   lang/elisp/Makefile
   lang/elisp/internals/Makefile

ice-9/ChangeLog

@@ -1,3 +1,25 @@
+2006-08-18  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* debugging/trc.scm: New file.
+
+	* debugging/traps.scm: New file.
+
+	* debugging/trace.scm: New file.
+
+	* debugging/steps.scm: New file.
+
+	* debugging/load-hooks.scm: New file.
+
+	* debugging/ice-9-debugger-extensions.scm: New file.
+
+	* debugging/example-fns.scm: New file.
+
+	* debugging/breakpoints.scm: New file.
+
+	* debugging/Makefile.am: New.
+
+	* Makefile.am (SUBDIRS): Add debugging.
+
 2006-06-19  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* Makefile.am (ice9_sources): Add new files.

ice-9/Makefile.am

@@ -21,7 +21,7 @@
 
 AUTOMAKE_OPTIONS = gnu
 
-SUBDIRS = debugger
+SUBDIRS = debugger debugging
 
 # These should be installed and distributed.
 ice9_sources =								   \

ice-9/debugging/Makefile.am

@@ -0,0 +1,33 @@
+## Process this file with automake to produce Makefile.in.
+##
+##  	Copyright (C) 2006 Free Software Foundation, Inc.
+##
+##   This file is part of GUILE.
+##
+##   GUILE is free software; you can redistribute it and/or modify
+##   it under the terms of the GNU General Public License as
+##   published by the Free Software Foundation; either version 2, or
+##   (at your option) any later version.
+##
+##   GUILE is distributed in the hope that it will be useful, but
+##   WITHOUT ANY WARRANTY; without even the implied warranty of
+##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+##   GNU General Public License for more details.
+##
+##   You should have received a copy of the GNU General Public
+##   License along with GUILE; see the file COPYING.  If not, write
+##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+##   Floor, Boston, MA 02110-1301 USA
+
+AUTOMAKE_OPTIONS = gnu
+
+# These should be installed and distributed.
+ice9_debugging_sources = breakpoints.scm example-fns.scm \
+               ice-9-debugger-extensions.scm load-hooks.scm \
+               steps.scm trace.scm traps.scm trc.scm
+
+subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging
+subpkgdata_DATA = $(ice9_debugging_sources)
+TAGS_FILES = $(subpkgdata_DATA)
+
+EXTRA_DIST = $(ice9_debugging_sources)

ice-9/debugging/breakpoints.scm

@@ -0,0 +1,415 @@
+;;;; (ice-9 debugging breakpoints) -- practical breakpoints
+
+;;; Copyright (C) 2005 Neil Jerram
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;;; This module provides a practical interface for setting and
+;;; manipulating breakpoints.
+
+(define-module (ice-9 debugging breakpoints)
+  #:use-module (ice-9 debugger)
+  #:use-module (ice-9 ls)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 regex)
+  #:use-module (oop goops)
+  #:use-module (ice-9 debugging ice-9-debugger-extensions)
+  #:use-module (ice-9 debugging traps)
+  #:use-module (ice-9 debugging trc)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:export (break-in
+	    break-at
+	    default-breakpoint-behaviour
+	    delete-breakpoint
+	    for-each-breakpoint
+	    setup-before-load
+	    setup-after-load
+	    setup-after-read
+	    setup-after-eval))
+
+;; If the running Guile does not provide before- and after- load hooks
+;; itself, install them using the (ice-9 debugging load-hooks) module.
+(or (defined? 'after-load-hook)
+    (begin
+      (use-modules (ice-9 debugging load-hooks))
+      (install-load-hooks)))
+
+;; Getter/setter for default breakpoint behaviour.
+(define default-breakpoint-behaviour
+  (let ((behaviour debug-trap))
+    (make-procedure-with-setter
+     ;; Getter: return current default behaviour.
+     (lambda ()
+       behaviour)
+     ;; Setter: set default behaviour to given procedure.
+     (lambda (new-behaviour)
+       (set! behaviour new-behaviour)))))
+
+;; Base class for breakpoints.  (We don't need to use GOOPS to
+;; represent breakpoints, but it's a nice way to describe a composite
+;; object.)
+(define-class <breakpoint> ()
+  ;; This breakpoint's trap options, which include its behaviour.
+  (trap-options #:init-keyword #:trap-options)
+  ;; All the traps relating to this breakpoint.
+  (traps #:init-value '())
+  ;; Observer.  This is a procedure that is called when the breakpoint
+  ;; trap list changes.
+  (observer #:init-value #f))
+
+;; Noop base class definitions of all the possible setup methods.
+(define-method (setup-before-load (bp <breakpoint>) filename)
+  *unspecified*)
+(define-method (setup-after-load (bp <breakpoint>) filename)
+  *unspecified*)
+(define-method (setup-after-read (bp <breakpoint>) x)
+  *unspecified*)
+(define-method (setup-after-eval (bp <breakpoint>) filename)
+  *unspecified*)
+
+;; Call the breakpoint's observer, if it has one.
+(define-method (call-observer (bp <breakpoint>))
+  (cond ((slot-ref bp 'observer)
+	 =>
+	 (lambda (proc)
+	   (proc)))))
+
+;; Delete a breakpoint.
+(define (delete-breakpoint bp)
+  ;; Remove this breakpoint from the global list.
+  (set! breakpoints (delq! bp breakpoints))
+  ;; Uninstall and discard all its traps.
+  (for-each uninstall-trap (slot-ref bp 'traps))
+  (slot-set! bp 'traps '()))
+
+;; Class for `break-in' breakpoints.
+(define-class <break-in> (<breakpoint>)
+  ;; The name of the procedure to break in.
+  (procedure-name #:init-keyword #:procedure-name)
+  ;; The name of the module or file that the procedure is defined in.
+  ;; A module name is a list of symbols that exactly names the
+  ;; relevant module.  A file name is a string, which can in fact be
+  ;; any substring of the relevant full file name.
+  (module-or-file-name #:init-keyword #:module-or-file-name))
+
+;; Class for `break-at' breakpoints.
+(define-class <break-at> (<breakpoint>)
+  ;; The name of the file to break in.  This is a string, which can in
+  ;; fact be any substring of the relevant full file name.
+  (file-name #:init-keyword #:file-name)
+  ;; Line and column number to break at.
+  (line #:init-keyword #:line)
+  (column #:init-keyword #:column))
+
+;; Global list of non-deleted breakpoints.
+(define breakpoints '())
+
+;; Add to the above list.
+(define-method (add-to-global-breakpoint-list (bp <breakpoint>))
+  (set! breakpoints (append! breakpoints (list bp))))
+
+;; break-in: create a `break-in' breakpoint.
+(define (break-in procedure-name . options)
+  ;; Sort out the optional args.
+  (let* ((module-or-file-name+options
+	  (cond ((and (not (null? options))
+		      (or (string? (car options))
+			  (list? (car options))))
+		 options)
+		(else
+		 (cons (module-name (current-module)) options))))
+	 (module-or-file-name (car module-or-file-name+options))
+	 (trap-options (cdr module-or-file-name+options))
+	 ;; Create the new breakpoint object.
+	 (bp (make <break-in>
+	       #:procedure-name procedure-name
+	       #:module-or-file-name module-or-file-name
+	       #:trap-options (if (memq #:behaviour trap-options)
+				  trap-options
+				  (cons* #:behaviour
+					 (default-breakpoint-behaviour)
+					 trap-options)))))
+    ;; Add it to the global breakpoint list.
+    (add-to-global-breakpoint-list bp)
+    ;; Set the new breakpoint, if possible, in already loaded code.
+    (set-in-existing-code bp)
+    ;; Return the breakpoint object to our caller.
+    bp))
+
+;; break-at: create a `break-at' breakpoint.
+(define (break-at file-name line column . trap-options)
+  ;; Create the new breakpoint object.
+  (let* ((bp (make <break-at>
+	       #:file-name file-name
+	       #:line line
+	       #:column column
+	       #:trap-options (if (memq #:behaviour trap-options)
+				  trap-options
+				  (cons* #:behaviour
+					 (default-breakpoint-behaviour)
+					 trap-options)))))
+    ;; Add it to the global breakpoint list.
+    (add-to-global-breakpoint-list bp)
+    ;; Set the new breakpoint, if possible, in already loaded code.
+    (set-in-existing-code bp)
+    ;; Return the breakpoint object to our caller.
+    bp))
+
+;; Set a `break-in' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-in>))
+  ;; Get the module or file name that was specified for this
+  ;; breakpoint.
+  (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+    ;; Handling is simpler for a module name.
+    (cond ((list? module-or-file-name)
+	   ;; See if the named module exists yet.
+	   (let ((m (module-if-already-loaded module-or-file-name)))
+	     (maybe-break-in-module-proc m bp)))
+	  ((string? module-or-file-name)
+	   ;; Try all loaded modules.
+	   (or-map (lambda (m)
+		     (maybe-break-in-module-proc m bp))
+		   (all-loaded-modules)))
+	  (else
+	   (error "Bad module-or-file-name:" module-or-file-name)))))
+
+(define (make-observer bp trap)
+  (lambda (event)
+    (trap-target-gone bp trap)))
+
+;; Set a `break-at' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-at>) . code)
+  ;; Procedure to install a source trap on each expression that we
+  ;; find matching this breakpoint.
+  (define (install-source-trap x)
+    (or (or-map (lambda (trap)
+		  (and (is-a? trap <source-trap>)
+		       (eq? (slot-ref trap 'expression) x)))
+		(slot-ref bp 'traps))
+	(let ((trap (apply make <source-trap>
+			   #:expression x
+			   (slot-ref bp 'trap-options))))
+	  (slot-set! trap 'observer (make-observer bp trap))
+	  (install-trap trap)
+	  (trc 'install-source-trap (object-address trap) (object-address x))
+	  (trap-installed bp trap #t))))
+  ;; Scan the source whash, and install a trap on all code matching
+  ;; this breakpoint.
+  (trc 'set-in-existing-code (length code))
+  (if (null? code)
+      (scan-source-whash (slot-ref bp 'file-name)
+			 (slot-ref bp 'line)
+			 (slot-ref bp 'column)
+			 install-source-trap)
+      (scan-code (car code)
+		 (slot-ref bp 'file-name)
+		 (slot-ref bp 'line)
+		 (slot-ref bp 'column)
+		 install-source-trap)))
+
+;; Temporary implementation of scan-source-whash - this _really_ needs
+;; to be implemented in C.
+(define (scan-source-whash file-name line column proc)
+  ;; Procedure to call for each source expression in the whash.
+  (define (folder x props acc)
+    (if (and (= line (source-property x 'line))
+	     (= column (source-property x 'column))
+	     (let ((fn (source-property x 'filename)))
+	       (trc 'scan-source-whash fn)
+	       (and (string? fn)
+		    (string-contains fn file-name))))
+	(proc x)))
+  ;; Tracing.
+  (trc 'scan-source-whash file-name line column)
+  ;; Apply this procedure to the whash.
+  (hash-fold folder 0 source-whash))
+
+(define (scan-code x file-name line column proc)
+  (trc 'scan-code file-name line column)
+  (if (pair? x)
+      (begin
+	(if (and (eq? line (source-property x 'line))
+		 (eq? column (source-property x 'column))
+		 (let ((fn (source-property x 'filename)))
+		   (trc 'scan-code fn)
+		   (and (string? fn)
+			(string-contains fn file-name))))
+	    (proc x))
+	(scan-code (car x) file-name line column proc)
+	(scan-code (cdr x) file-name line column proc))))
+
+;; If a module named MODULE-NAME has been loaded, return its module
+;; object; otherwise return #f.
+(define (module-if-already-loaded module-name)
+  (nested-ref the-root-module (append '(app modules) module-name)))
+
+;; Construct and return a list of all loaded modules.
+(define (all-loaded-modules)
+  ;; This is the list that accumulates known modules.  It has to be
+  ;; defined outside the following functions, and accumulated using
+  ;; set!, so as to avoid infinite loops - because of the fact that
+  ;; all non-pure modules have a variable `app'.
+  (define known-modules '())
+  ;; Return an alist of submodules of the given PARENT-MODULE-NAME.
+  ;; Each element of the alist is (NAME . MODULE), where NAME is the
+  ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and
+  ;; MODULE is the module object.  By a "submodule of a parent
+  ;; module", we mean any module value that is bound to a symbol in
+  ;; the parent module, and which is not an interface module.
+  (define (direct-submodules parent-module-name)
+    (filter (lambda (name+value)
+	      (and (module? (cdr name+value))
+		   (not (eq? (module-kind (cdr name+value)) 'interface))))
+	    (map (lambda (name)
+		   (cons name (local-ref (append parent-module-name
+						 (list name)))))
+		 (cdar (lls parent-module-name)))))
+  ;; Add all submodules (direct and indirect) of the module named
+  ;; PARENT-MODULE-NAME to `known-modules', if not already there.
+  (define (add-submodules-of parent-module-name)
+    (let ((ds (direct-submodules parent-module-name)))
+      (for-each
+       (lambda (name+module)
+         (or (memq (cdr name+module) known-modules)
+             (begin
+               (set! known-modules (cons (cdr name+module) known-modules))
+               (add-submodules-of (append parent-module-name
+                                          (list (car name+module)))))))
+       ds)))
+  ;; Add submodules recursively, starting from the root of all
+  ;; modules.
+  (add-submodules-of '(app modules))
+  ;; Return the result.
+  known-modules)
+
+;; Before-load setup for `break-at' breakpoints.
+(define-method (setup-before-load (bp <break-at>) filename)
+  (let ((trap (apply make <location-trap>
+		     #:file-regexp (regexp-quote (slot-ref bp 'file-name))
+		     #:line (slot-ref bp 'line)
+		     #:column (slot-ref bp 'column)
+		     (slot-ref bp 'trap-options))))
+    (install-trap trap)
+    (trap-installed bp trap #f)
+    (letrec ((uninstaller
+	      (lambda (file-name)
+		(uninstall-trap trap)
+		(remove-hook! after-load-hook uninstaller))))
+      (add-hook! after-load-hook uninstaller))))
+
+;; After-load setup for `break-in' breakpoints.
+(define-method (setup-after-load (bp <break-in>) filename)
+  ;; Get the module that the loaded file created or was loaded into,
+  ;; and the module or file name that were specified for this
+  ;; breakpoint.
+  (let ((m (current-module))
+	(module-or-file-name (slot-ref bp 'module-or-file-name)))
+    ;; Decide whether the breakpoint spec matches this load.
+    (if (or (and (string? module-or-file-name)
+		 (string-contains filename module-or-file-name))
+	    (and (list? module-or-file-name)
+		 (equal? (module-name (current-module)) module-or-file-name)))
+	;; It does, so try to install the breakpoint.
+	(maybe-break-in-module-proc m bp))))
+
+;; After-load setup for `break-at' breakpoints.
+(define-method (setup-after-load (bp <break-at>) filename)
+  (if (string-contains filename (slot-ref bp 'file-name))
+      (set-in-existing-code bp)))
+
+(define (maybe-break-in-module-proc m bp)
+  "If module M defines a procedure matching the specification of
+breakpoint BP, install a trap on it."
+  (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f)))
+    (if (and proc
+	     (procedure? proc)
+	     (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+	       (if (string? module-or-file-name)
+		   (source-file-matches (procedure-source proc)
+					module-or-file-name)
+		   #t))
+	     (not (or-map (lambda (trap)
+			    (and (is-a? trap <procedure-trap>)
+				 (eq? (slot-ref trap 'procedure) proc)))
+			  (slot-ref bp 'traps))))
+	;; There is, so install a <procedure-trap> on it.
+	(letrec ((trap (apply make <procedure-trap>
+			      #:procedure proc
+			      (slot-ref bp 'trap-options))))
+	  (slot-set! trap 'observer (make-observer bp trap))
+	  (install-trap trap)
+	  (trap-installed bp trap #t)
+	  ;; Tell caller that we installed a trap.
+	  #t)
+	;; Tell caller that we did not install a trap.
+	#f)))
+
+;; After-read setup for `break-at' breakpoints.
+(define-method (setup-after-read (bp <break-at>) x)
+  (set-in-existing-code bp x))
+
+;; Common code for associating a newly created and installed trap with
+;; a breakpoint object.
+(define (trap-installed bp trap record?)
+  (if record?
+      ;; Remember this trap in the breakpoint object.
+      (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap))))
+  ;; Update the breakpoint status.
+  (call-observer bp))
+
+;; Common code for handling when the target of one of a breakpoint's
+;; traps is being GC'd.
+(define (trap-target-gone bp trap)
+  (trc 'trap-target-gone (object-address trap))
+  ;; Remove this trap from the breakpoint's list.
+  (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps)))
+  ;; Update the breakpoint status.
+  (call-observer bp))
+
+(define (source-file-matches source file-name)
+  "Return #t if any of the expressions in SOURCE have a 'filename
+source property that includes FILE-NAME; otherwise return #f."
+  (and (pair? source)
+       (or (let ((source-file-name (source-property source 'filename)))
+	     (and source-file-name
+		  (string? source-file-name)
+		  (string-contains source-file-name file-name)))
+	   (let loop ((source source))
+	     (and (pair? source)
+		  (or (source-file-matches (car source) file-name)
+		      (loop (cdr source))))))))
+
+;; Install load hook functions.
+(add-hook! before-load-hook
+	   (lambda (fn)
+	     (for-each-breakpoint setup-before-load fn)))
+
+(add-hook! after-load-hook
+	   (lambda (fn)
+	     (for-each-breakpoint setup-after-load fn)))
+
+;;; Apply generic function GF to each breakpoint, passing the
+;;; breakpoint object and ARGS as args on each call.
+(define (for-each-breakpoint gf . args)
+  (for-each (lambda (bp)
+	      (apply gf bp args))
+	    breakpoints))
+
+;; Make sure that recording of source positions is enabled.  Without
+;; this break-at breakpoints will obviously not work.
+(read-enable 'positions)
+
+;;; (ice-9 debugging breakpoints) ends here.

ice-9/debugging/example-fns.scm

@@ -0,0 +1,17 @@
+(define-module (ice-9 debugging example-fns)
+  #:export (fact1 fact2 facti))
+
+(define (fact1 n)
+  (if (= n 0)
+      1
+      (* n (fact1 (- n 1)))))
+
+(define (facti n a)
+  (if (= n 0)
+      a
+      (facti (- n 1) (* a n))))
+
+(define (fact2 n)
+  (facti n 1))
+
+; Test: (fact2 3)

ice-9/debugging/ice-9-debugger-extensions.scm

@@ -0,0 +1,154 @@
+
+(define-module (ice-9 debugging ice-9-debugger-extensions)
+  #:use-module (ice-9 debugger))
+
+;;; Upgrade the debugger state object so that it can carry a flag
+;;; indicating whether the debugging session is continuable.
+
+(cond ((string>=? (version) "1.7")
+       (use-modules (ice-9 debugger state))
+       (define-module (ice-9 debugger state)))
+      (else
+       (define-module (ice-9 debugger))))
+
+(set! state-rtd (make-record-type "debugger-state" '(stack index flags)))
+(set! state? (record-predicate state-rtd))
+(set! make-state
+  (let ((make-state-internal (record-constructor state-rtd
+						 '(stack index flags))))
+    (lambda (stack index . flags)
+      (make-state-internal stack index flags))))
+(set! state-stack (record-accessor state-rtd 'stack))
+(set! state-index (record-accessor state-rtd 'index))
+
+(define state-flags (record-accessor state-rtd 'flags))
+
+;;; Add commands that (ice-9 debugger) doesn't currently have, for
+;;; continuing or single stepping program execution.
+
+(cond ((string>=? (version) "1.7")
+       (use-modules (ice-9 debugger command-loop))
+       (define-module (ice-9 debugger command-loop))
+       (define new-define-command define-command)
+       (set! define-command
+	     (lambda (name argument-template documentation procedure)
+	       (new-define-command name argument-template procedure))))
+      (else
+       (define-module (ice-9 debugger))))
+
+(use-modules (ice-9 debugging steps))
+
+(define (assert-continuable state)
+  ;; Check that debugger is in a state where `continuing' makes sense.
+  ;; If not, signal an error.
+  (or (memq #:continuable (state-flags state))
+      (user-error "This debug session is not continuable.")))
+
+(define (debugger:continue state)
+  "Continue program execution."
+  (assert-continuable state)
+  (throw 'exit-debugger))
+
+(define (debugger:finish state)
+  "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+  (assert-continuable state)
+  (at-exit (- (stack-length (state-stack state))
+	      (state-index state))
+	   (list trace-trap debug-trap))
+  (debugger:continue state))
+
+(define (debugger:step state n)
+  "Continue until entry to @var{n}th next frame."
+  (assert-continuable state)
+  (at-step debug-trap (or n 1))
+  (debugger:continue state))
+
+(define (debugger:next state n)
+  "Continue until entry to @var{n}th next frame in same file."
+  (assert-continuable state)
+  (at-step debug-trap
+	   (or n 1)
+	   (frame-file-name (stack-ref (state-stack state)
+				       (state-index state)))
+	   (if (memq #:return (state-flags state))
+	       #f
+	       (- (stack-length (state-stack state)) (state-index state))))
+  (debugger:continue state))
+
+(define-command "continue" '()
+  "Continue program execution."
+  debugger:continue)
+
+(define-command "finish" '()
+  "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+  debugger:finish)
+
+(define-command "step" '('optional exact-integer)
+  "Continue until entry to @var{n}th next frame."
+  debugger:step)
+
+(define-command "next" '('optional exact-integer)
+  "Continue until entry to @var{n}th next frame in same file."
+  debugger:next)
+
+;;; Export a couple of procedures for use by (ice-9 debugging trace).
+
+(cond ((string>=? (version) "1.7"))
+      (else
+       (define-module (ice-9 debugger))
+       (export write-frame-short/expression
+	       write-frame-short/application)))
+
+;;; Provide a `debug-trap' entry point in (ice-9 debugger).  This is
+;;; designed so that it can be called to explore the stack at a
+;;; breakpoint, and to single step from the breakpoint.
+
+(define-module (ice-9 debugger))
+
+(use-modules (ice-9 debugging traps))
+
+(define *not-yet-introduced* #t)
+
+(define-public (debug-trap trap-context)
+  "Invoke the Guile debugger to explore the stack at the specified @var{trap}."
+  (start-stack 'debugger
+	       (let* ((stack (tc:stack trap-context))
+		      (flags1 (let ((trap-type (tc:type trap-context)))
+				(case trap-type
+				  ((#:return #:error)
+				   (list trap-type
+					 (tc:return-value trap-context)))
+				  (else
+				   (list trap-type)))))
+		      (flags (if (tc:continuation trap-context)
+				 (cons #:continuable flags1)
+				 flags1))
+		      (state (apply make-state stack 0 flags)))
+		 (if *not-yet-introduced*
+		     (let ((ssize (stack-length stack)))
+		       (display "This is the Guile debugger -- for help, type `help'.\n")
+		       (set! *not-yet-introduced* #f)
+		       (if (= ssize 1)
+			   (display "There is 1 frame on the stack.\n\n")
+			   (format #t "There are ~A frames on the stack.\n\n" ssize))))
+		 (write-state-short-with-source-location state)
+		 (read-and-dispatch-commands state (current-input-port)))))
+
+(define write-state-short-with-source-location
+  (cond ((string>=? (version) "1.7")
+	 write-state-short)
+	(else
+	 (lambda (state)
+	   (let* ((frame (stack-ref (state-stack state) (state-index state)))
+		  (source (frame-source frame))
+		  (position (and source (source-position source))))
+	     (format #t "Frame ~A at " (frame-number frame))
+	     (if position
+		 (display-position position)
+		 (display "unknown source location"))
+	     (newline)
+	     (write-char #\tab)
+	     (write-frame-short frame)
+	     (newline))))))

ice-9/debugging/load-hooks.scm

@@ -0,0 +1,33 @@
+
+(define-module (ice-9 debugging load-hooks)
+  #:export (before-load-hook
+            after-load-hook
+            install-load-hooks
+            uninstall-load-hooks))
+
+;; real-primitive-load: holds the real (C-implemented) definition of
+;; primitive-load, when the load hooks are installed.
+(define real-primitive-load #f)
+
+;; The load hooks themselves.  These are called with one argument, the
+;; name of the file concerned.
+(define before-load-hook (make-hook 1))
+(define after-load-hook (make-hook 1))
+
+;; primitive-load-with-hooks: our new definition for primitive-load.
+(define (primitive-load-with-hooks filename)
+  (run-hook before-load-hook filename)
+  (real-primitive-load filename)
+  (run-hook after-load-hook filename))
+
+(define (install-load-hooks)
+  (if real-primitive-load
+      (error "load hooks are already installed"))
+  (set! real-primitive-load primitive-load)
+  (set! primitive-load primitive-load-with-hooks))
+
+(define (uninstall-load-hooks)
+  (or real-primitive-load
+      (error "load hooks are not installed"))
+  (set! primitive-load real-primitive-load)
+  (set! real-primitive-load #f))

ice-9/debugging/steps.scm

@@ -0,0 +1,106 @@
+;;;; (ice-9 debugging steps) -- stepping through code from the debugger
+
+;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 debugging steps)
+  #:use-module (ice-9 debugging traps)
+  #:use-module (ice-9 and-let-star)
+  #:use-module (ice-9 debugger)
+  #:use-module (ice-9 optargs)
+  #:export (at-exit
+	    at-entry
+	    at-apply
+	    at-step
+	    at-next))
+
+;;; at-exit DEPTH BEHAVIOUR
+;;;
+;;; Install a behaviour to run when we exit the current frame.
+
+(define (at-exit depth behaviour)
+  (install-trap (make <exit-trap>
+		  #:depth depth
+		  #:single-shot #t
+		  #:behaviour behaviour)))
+
+;;; at-entry BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next frame
+;;; entry.  COUNT defaults to 1.
+
+(define* (at-entry behaviour #:optional (count 1))
+  (install-trap (make <entry-trap>
+		  #:skip-count (- count 1)
+		  #:single-shot #t
+		  #:behaviour behaviour)))
+
+;;; at-apply BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next
+;;; application.  COUNT defaults to 1.
+
+(define* (at-apply behaviour #:optional (count 1))
+  (install-trap (make <apply-trap>
+		  #:skip-count (- count 1)
+		  #:single-shot #t
+		  #:behaviour behaviour)))
+
+;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]]
+;;;
+;;; Install BEHAVIOUR to run on the COUNT'th next application, frame
+;;; entry or frame exit.  COUNT defaults to 1.  If FILENAME is
+;;; specified and not #f, only frames that begin in the named file are
+;;; counted.
+
+(define* (at-step behaviour #:optional (count 1) filename (depth 1000))
+  (install-trap (make <step-trap>
+		  #:file-name filename
+		  #:exit-depth depth
+		  #:skip-count (- count 1)
+		  #:single-shot #t
+		  #:behaviour behaviour)))
+
+;;  (or count (set! count 1))
+;;  (letrec ((proc (lambda (trap-context)
+;;		   ;; Behaviour whenever we enter or exit a frame.
+;;		   (set! count (- count 1))
+;;		   (if (= count 0)
+;;		       (begin
+;;			 (remove-enter-frame-hook! step)
+;;			 (remove-apply-frame-hook! step)
+;;			 (behaviour trap-context)))))
+;;	   (step (lambda (trap-context)
+;;		   ;; Behaviour on frame entry: both execute the above
+;;		   ;; and install it as an exit hook.
+;;		   (if (or (not filename)
+;;			   (equal? (frame-file-name (tc:frame trap-context))
+;;                                   filename))
+;;		       (begin
+;;			 (proc trap-context)
+;;			 (at-exit (tc:depth trap-context) proc))))))
+;;    (at-exit depth proc)
+;;    (add-enter-frame-hook! step)
+;;    (add-apply-frame-hook! step)))
+
+;;; at-next BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next frame
+;;; entry in the same source file as the current location.  COUNT
+;;; defaults to 1.  If the current location has no filename, fall back
+;;; silently to `at-entry' behaviour.
+
+;;; (ice-9 debugging steps) ends here.

ice-9/debugging/trace.scm

@@ -0,0 +1,157 @@
+;;;; (ice-9 debugging trace) -- breakpoint trace behaviour
+
+;;; Copyright (C) 2002 Free Software Foundation, Inc.
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 debugging trace)
+  #:use-module (ice-9 debug)
+  #:use-module (ice-9 debugger)
+  #:use-module (ice-9 debugging ice-9-debugger-extensions)
+  #:use-module (ice-9 debugging steps)
+  #:use-module (ice-9 debugging traps)
+  #:export (trace-trap
+	    trace-port
+	    set-trace-layout
+            trace/pid
+            trace/stack-id
+            trace/stack-depth
+            trace/stack-real-depth
+            trace/stack
+            trace/source-file-name
+            trace/source-line
+            trace/source-column
+            trace/source
+            trace/type
+            trace/real?
+            trace/info
+	    trace-at-exit
+	    trace-until-exit))
+
+(cond ((string>=? (version) "1.7")
+       (use-modules (ice-9 debugger utils))))
+
+(define trace-format-string #f)
+(define trace-arg-procs #f)
+
+(define (set-trace-layout format-string . arg-procs)
+  (set! trace-format-string format-string)
+  (set! trace-arg-procs arg-procs))
+
+(define (trace/pid trap-context)
+  (getpid))
+
+(define (trace/stack-id trap-context)
+  (stack-id (tc:stack trap-context)))
+
+(define (trace/stack-depth trap-context)
+  (tc:depth trap-context))
+
+(define (trace/stack-real-depth trap-context)
+  (tc:real-depth trap-context))
+
+(define (trace/stack trap-context)
+  (format #f "~a:~a+~a"
+	  (stack-id (tc:stack trap-context))
+	  (tc:real-depth trap-context)
+	  (- (tc:depth trap-context) (tc:real-depth trap-context))))
+
+(define (trace/source-file-name trap-context)
+  (cond ((frame->source-position (tc:frame trap-context)) => car)
+	(else "")))
+
+(define (trace/source-line trap-context)
+  (cond ((frame->source-position (tc:frame trap-context)) => cadr)
+	(else 0)))
+
+(define (trace/source-column trap-context)
+  (cond ((frame->source-position (tc:frame trap-context)) => caddr)
+	(else 0)))
+
+(define (trace/source trap-context)
+  (cond ((frame->source-position (tc:frame trap-context))
+	 =>
+	 (lambda (pos)
+	   (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
+	(else "")))
+
+(define (trace/type trap-context)
+  (case (tc:type trap-context)
+    ((#:application) "APP")
+    ((#:evaluation) "EVA")
+    ((#:return) "RET")
+    ((#:error) "ERR")
+    (else "???")))
+
+(define (trace/real? trap-context)
+  (if (frame-real? (tc:frame trap-context)) " " "t"))
+
+(define (trace/info trap-context)
+  (with-output-to-string
+    (lambda ()
+      (if (memq (tc:type trap-context) '(#:application #:evaluation))
+	  ((if (tc:expression trap-context)
+	       write-frame-short/expression
+	       write-frame-short/application) (tc:frame trap-context))
+	  (begin
+	    (display "=>")
+	    (write (tc:return-value trap-context)))))))
+
+(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info)
+
+;;; trace-trap
+;;;
+;;; Trace the current location, and install a hook to trace the return
+;;; value when we exit the current frame.
+
+(define (trace-trap trap-context)
+  (apply format
+	 (trace-port)
+	 trace-format-string
+	 (map (lambda (arg-proc)
+		(arg-proc trap-context))
+	      trace-arg-procs)))
+
+(set! (behaviour-ordering trace-trap) 50)
+
+;;; trace-port
+;;;
+;;; The port to which trace information is printed.
+
+(define trace-port
+  (let ((port (current-output-port)))
+    (make-procedure-with-setter
+     (lambda () port)
+     (lambda (new) (set! port new)))))
+
+;;; trace-at-exit
+;;;
+;;; Trace return value on exit from the current frame.
+
+(define (trace-at-exit trap-context)
+  (at-exit (tc:depth trap-context) trace-trap))
+
+;;; trace-until-exit
+;;;
+;;; Trace absolutely everything until exit from the current frame.
+
+(define (trace-until-exit trap-context)
+  (let ((step-trap (make <step-trap> #:behaviour trace-trap)))
+    (install-trap step-trap)
+    (at-exit (tc:depth trap-context)
+	     (lambda (trap-context)
+	       (uninstall-trap step-trap)))))
+
+;;; (ice-9 debugging trace) ends here.

ice-9/debugging/trc.scm

@@ -0,0 +1,63 @@
+;;;; (ice-9 debugging trc) -- tracing for Guile debugger code
+
+;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 debugging trc)
+  #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
+
+(define *syms* #f)
+
+(define (trc-set! syms)
+  (set! *syms* syms))
+
+(define (trc-syms . syms)
+  (trc-set! syms))
+
+(define (trc-all)
+  (trc-set! #f))
+
+(define (trc-none)
+  (trc-set! '()))
+
+(define (trc-add sym)
+  (trc-set! (cons sym *syms*)))
+
+(define (trc-remove sym)
+  (trc-set! (delq1! sym *syms*)))
+
+(define (trc sym . args)
+  (if (or (not *syms*)
+	  (memq sym *syms*))
+      (let ((port (trc-port)))
+	(write sym port)
+	(display ":" port)
+	(for-each (lambda (arg)
+		    (display " " port)
+		    (write arg port))
+		  args)
+	(newline port))))
+
+(define trc-port
+  (let ((port (current-error-port)))
+    (make-procedure-with-setter
+     (lambda () port)
+     (lambda (p) (set! port p)))))
+
+;; Default to no tracing.
+(trc-none)
+
+;;; (ice-9 debugging trc) ends here.