From 8746959cd3078c54a5760dcc7ee1e3451d21e1fd Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 18 Aug 2006 13:41:45 +0000 Subject: [PATCH] * 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 | 4 + configure.in | 1 + ice-9/ChangeLog | 22 + ice-9/Makefile.am | 2 +- ice-9/debugging/Makefile.am | 33 + ice-9/debugging/breakpoints.scm | 415 +++++++ ice-9/debugging/example-fns.scm | 17 + ice-9/debugging/ice-9-debugger-extensions.scm | 154 +++ ice-9/debugging/load-hooks.scm | 33 + ice-9/debugging/steps.scm | 106 ++ ice-9/debugging/trace.scm | 157 +++ ice-9/debugging/traps.scm | 1037 +++++++++++++++++ ice-9/debugging/trc.scm | 63 + 13 files changed, 2043 insertions(+), 1 deletion(-) create mode 100644 ice-9/debugging/Makefile.am create mode 100644 ice-9/debugging/breakpoints.scm create mode 100644 ice-9/debugging/example-fns.scm create mode 100644 ice-9/debugging/ice-9-debugger-extensions.scm create mode 100644 ice-9/debugging/load-hooks.scm create mode 100644 ice-9/debugging/steps.scm create mode 100644 ice-9/debugging/trace.scm create mode 100755 ice-9/debugging/traps.scm create mode 100644 ice-9/debugging/trc.scm diff --git a/ChangeLog b/ChangeLog index 0f32c104a..9739d8e9f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2006-08-18 Neil Jerram + + * configure.in: Generate Makefile for ice-9/debugging. + 2006-06-13 Ludovic Courtès * NEWS: Mentioned the new behavior of `equal?' for structures. diff --git a/configure.in b/configure.in index 1bb3ea7a4..c216c7ef1 100644 --- a/configure.in +++ b/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 diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index dd9f17291..c2ff7715a 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,25 @@ +2006-08-18 Neil Jerram + + * 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 * Makefile.am (ice9_sources): Add new files. diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 412b98945..0eb1ac8f2 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -21,7 +21,7 @@ AUTOMAKE_OPTIONS = gnu -SUBDIRS = debugger +SUBDIRS = debugger debugging # These should be installed and distributed. ice9_sources = \ diff --git a/ice-9/debugging/Makefile.am b/ice-9/debugging/Makefile.am new file mode 100644 index 000000000..5fbe9c6de --- /dev/null +++ b/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) diff --git a/ice-9/debugging/breakpoints.scm b/ice-9/debugging/breakpoints.scm new file mode 100644 index 000000000..132746f17 --- /dev/null +++ b/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 () + ;; 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 ) filename) + *unspecified*) +(define-method (setup-after-load (bp ) filename) + *unspecified*) +(define-method (setup-after-read (bp ) x) + *unspecified*) +(define-method (setup-after-eval (bp ) filename) + *unspecified*) + +;; Call the breakpoint's observer, if it has one. +(define-method (call-observer (bp )) + (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 () + ;; 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 () + ;; 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 )) + (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 + #: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 + #: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 )) + ;; 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 ) . 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 ) + (eq? (slot-ref trap 'expression) x))) + (slot-ref bp 'traps)) + (let ((trap (apply make + #: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 ) filename) + (let ((trap (apply make + #: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 ) 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 ) 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 ) + (eq? (slot-ref trap 'procedure) proc))) + (slot-ref bp 'traps)))) + ;; There is, so install a on it. + (letrec ((trap (apply make + #: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 ) 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. diff --git a/ice-9/debugging/example-fns.scm b/ice-9/debugging/example-fns.scm new file mode 100644 index 000000000..30d412f00 --- /dev/null +++ b/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) diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm new file mode 100644 index 000000000..dc1eb8fc8 --- /dev/null +++ b/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)))))) diff --git a/ice-9/debugging/load-hooks.scm b/ice-9/debugging/load-hooks.scm new file mode 100644 index 000000000..fb869ed23 --- /dev/null +++ b/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)) diff --git a/ice-9/debugging/steps.scm b/ice-9/debugging/steps.scm new file mode 100644 index 000000000..fedbc6a32 --- /dev/null +++ b/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 + #: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 + #: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 + #: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 + #: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. diff --git a/ice-9/debugging/trace.scm b/ice-9/debugging/trace.scm new file mode 100644 index 000000000..ad3015ddf --- /dev/null +++ b/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 #: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. diff --git a/ice-9/debugging/traps.scm b/ice-9/debugging/traps.scm new file mode 100755 index 000000000..080d7bc31 --- /dev/null +++ b/ice-9/debugging/traps.scm @@ -0,0 +1,1037 @@ +;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface + +;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc. +;;; 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 an abstraction around Guile's low level trap +;;; handler interface; its aim is to make the low level trap mechanism +;;; shareable between the debugger and other applications, and to +;;; insulate the rest of the debugger code a bit from changes that may +;;; occur in the low level trap interface in future. + +(define-module (ice-9 debugging traps) + #:use-module (ice-9 regex) + #:use-module (oop goops) + #:use-module (oop goops describe) + #:use-module (ice-9 debugging trc) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:export (tc:type + tc:continuation + tc:expression + tc:return-value + tc:stack + tc:frame + tc:depth + tc:real-depth + tc:exit-depth + tc:fired-traps + ;; Interface for users of subclasses defined in + ;; this module. + add-trapped-stack-id! + remove-trapped-stack-id! + + + + + + + + install-trap + uninstall-trap + all-traps + get-trap + list-traps + trap-ordering + behaviour-ordering + throw->trap-context + on-lazy-handler-dispatch + ;; Interface for authors of new subclasses. + + + trap->behaviour + trap-runnable? + install-apply-frame-trap + install-breakpoint-trap + install-enter-frame-trap + install-exit-frame-trap + install-trace-trap + uninstall-apply-frame-trap + uninstall-breakpoint-trap + uninstall-enter-frame-trap + uninstall-exit-frame-trap + uninstall-trace-trap + frame->source-position + frame-file-name + without-traps + guile-trap-features) + #:re-export (make) + #:export-syntax (trap-here)) + +;; How to debug the debugging infrastructure, when needed. Grep for +;; "(trc " to find other symbols that can be passed to trc-add. +;; (trc-add 'after-gc-hook) + +;; In Guile 1.7 onwards, weak-vector and friends are provided by the +;; (ice-9 weak-vector) module. +(cond ((string>=? (version) "1.7") + (use-modules (ice-9 weak-vector)))) + +;;; The current low level traps interface is as follows. +;;; +;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled +;;; by the `traps' setting of `(evaluator-traps-interface)' but also +;;; (and more relevant in most cases) by the `with-traps' procedure. +;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of +;;; its thunk parameter. +;;; +;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0 +;;; for the duration of the call, to avoid nasty recursive trapping +;;; loops. If a trap handler knows what it is doing, it can override +;;; this by `(trap-enable traps)'. +;;; +;;; The apply-frame handler is called when Guile is about to perform +;;; an application if EITHER the `apply-frame' evaluator trap option +;;; is set, OR the `trace' debug option is set and the procedure to +;;; apply has its `trace' procedure property set. The arguments +;;; passed are: +;;; +;;; - the symbol 'apply-frame +;;; +;;; - a continuation or debug object describing the current stack +;;; +;;; - a boolean indicating whether the application is tail-recursive. +;;; +;;; The enter-frame handler is called when the evaluator begins a new +;;; evaluation frame if EITHER the `enter-frame' evaluator trap option +;;; is set, OR the `breakpoints' debug option is set and the code to +;;; be evaluated has its `breakpoint' source property set. The +;;; arguments passed are: +;;; +;;; - the symbol 'enter-frame +;;; +;;; - a continuation or debug object describing the current stack +;;; +;;; - a boolean indicating whether the application is tail-recursive. +;;; +;;; - an unmemoized copy of the expression to be evaluated. +;;; +;;; If the `enter-frame' evaluator trap option is set, the enter-frame +;;; handler is also called when about to perform an application in +;;; SCM_APPLY, immediately before possibly calling the apply-frame +;;; handler. (I don't totally understand this.) In this case, the +;;; arguments passed are: +;;; +;;; - the symbol 'enter-frame +;;; +;;; - a continuation or debug object describing the current stack. +;;; +;;; The exit-frame handler is called when Guile exits an evaluation +;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if +;;; EITHER the `exit-frame' evaluator trap option is set, OR the +;;; `trace' debug option is set and the frame is marked as having been +;;; traced. The frame will be marked as having been traced if the +;;; apply-frame handler was called for this frame. (This is trickier +;;; than it sounds because of tail recursion: the same debug frame +;;; could have been used for multiple applications, only some of which +;;; were traced - I think.) The arguments passed are: +;;; +;;; - the symbol 'exit-frame +;;; +;;; - a continuation or debug object describing the current stack +;;; +;;; - the result of the evaluation or application. + +;;; {Trap Context} +;;; +;;; A trap context is a GOOPS object that encapsulates all the useful +;;; information about a particular trap. Encapsulating this +;;; information in a single object also allows us: +;;; +;;; - to defer the calculation of information that is time-consuming +;;; to calculate, such as the stack, and to cache such information so +;;; that it is only ever calculated once per trap +;;; +;;; - to pass all interesting information to trap behaviour procedures +;;; in a single parameter, which (i) is convenient and (ii) makes for +;;; a more future-proof interface. +;;; +;;; It also allows us - where very carefully documented! - to pass +;;; information from one behaviour procedure to another. + +(define-class () + ;; Information provided directly by the trap calls from the + ;; evaluator. The "type" slot holds a keyword indicating the type + ;; of the trap: one of #:evaluation, #:application, #:return, + ;; #:error. + (type #:getter tc:type + #:init-keyword #:type) + ;; The "continuation" slot holds the continuation (or debug object, + ;; if "cheap" traps are enabled, which is the default) at the point + ;; of the trap. For an error trap it is #f. + (continuation #:getter tc:continuation + #:init-keyword #:continuation) + ;; The "expression" slot holds the source code expression, for an + ;; evaluation trap. + (expression #:getter tc:expression + #:init-keyword #:expression + #:init-value #f) + ;; The "return-value" slot holds the return value, for a return + ;; trap, or the error args, for an error trap. + (return-value #:getter tc:return-value + #:init-keyword #:return-value + #:init-value #f) + ;; The list of trap objects which fired in this trap context. + (fired-traps #:getter tc:fired-traps + #:init-value '()) + ;; The set of symbols which, if one of them is set in the CAR of the + ;; handler-return-value slot, will cause the CDR of that slot to + ;; have an effect. + (handler-return-syms #:init-value '()) + ;; The value which the trap handler should return to the evaluator. + (handler-return-value #:init-value #f) + ;; Calculated and cached information. "stack" is the stack + ;; (computed from the continuation (or debug object) by make-stack, + ;; or else (in the case of an error trap) by (make-stack #t ...). + (stack #:init-value #f) + (frame #:init-value #f) + (depth #:init-value #f) + (real-depth #:init-value #f) + (exit-depth #:init-value #f)) + +(define-method (tc:stack (ctx )) + (or (slot-ref ctx 'stack) + (let ((stack (make-stack (tc:continuation ctx)))) + (slot-set! ctx 'stack stack) + stack))) + +(define-method (tc:frame (ctx )) + (or (slot-ref ctx 'frame) + (let ((frame (cond ((tc:continuation ctx) => last-stack-frame) + (else (stack-ref (tc:stack ctx) 0))))) + (slot-set! ctx 'frame frame) + frame))) + +(define-method (tc:depth (ctx )) + (or (slot-ref ctx 'depth) + (let ((depth (stack-length (tc:stack ctx)))) + (slot-set! ctx 'depth depth) + depth))) + +(define-method (tc:real-depth (ctx )) + (or (slot-ref ctx 'real-depth) + (let* ((stack (tc:stack ctx)) + (real-depth (apply + + (map (lambda (i) + (if (frame-real? (stack-ref stack i)) + 1 + 0)) + (iota (tc:depth ctx)))))) + (slot-set! ctx 'real-depth real-depth) + real-depth))) + +(define-method (tc:exit-depth (ctx )) + (or (slot-ref ctx 'exit-depth) + (let* ((stack (tc:stack ctx)) + (depth (tc:depth ctx)) + (exit-depth (let loop ((exit-depth depth)) + (if (or (zero? exit-depth) + (frame-real? (stack-ref stack + (- depth + exit-depth)))) + exit-depth + (loop (- exit-depth 1)))))) + (slot-set! ctx 'exit-depth exit-depth) + exit-depth))) + +;;; {Stack IDs} +;;; +;;; Mechanism for limiting trapping to contexts whose stack ID matches +;;; one of a registered set. The default is for traps to fire +;;; regardless of stack ID. + +(define trapped-stack-ids (list #t)) +(define all-stack-ids-trapped? #t) + +(define (add-trapped-stack-id! id) + "Add ID to the set of stack ids for which traps are active. +If `#t' is in this set, traps are active regardless of stack context. +To remove ID again, use `remove-trapped-stack-id!'. If you add the +same ID twice using `add-trapped-stack-id!', you will need to remove +it twice." + (set! trapped-stack-ids (cons id trapped-stack-ids)) + (set! all-stack-ids-trapped? (memq #t trapped-stack-ids))) + +(define (remove-trapped-stack-id! id) + "Remove ID from the set of stack ids for which traps are active." + (set! trapped-stack-ids (delq1! id trapped-stack-ids)) + (set! all-stack-ids-trapped? (memq #t trapped-stack-ids))) + +(define (trap-here? cont) + ;; Return true if the stack id of the specified continuation (or + ;; debug object) is in the set that we should trap for; otherwise + ;; false. + (or all-stack-ids-trapped? + (memq (stack-id cont) trapped-stack-ids))) + +;;; {Global State} +;;; +;;; Variables tracking registered handlers, relevant procedures, and +;;; what's turned on as regards the evaluator's debugging options. + +(define enter-frame-traps '()) +(define apply-frame-traps '()) +(define exit-frame-traps '()) +(define breakpoint-traps '()) +(define trace-traps '()) + +(define (non-null? hook) + (not (null? hook))) + +;; The low level frame handlers must all be initialized to something +;; harmless. Otherwise we hit a problem immediately when trying to +;; enable one of these handlers. +(trap-set! enter-frame-handler noop) +(trap-set! apply-frame-handler noop) +(trap-set! exit-frame-handler noop) + +(define set-debug-and-trap-options + (let ((dopts (debug-options)) + (topts (evaluator-traps-interface)) + (setting (lambda (key opts) + (let ((l (memq key opts))) + (and l + (not (null? (cdr l))) + (cadr l))))) + (debug-set-boolean! (lambda (key value) + ((if value debug-enable debug-disable) key))) + (trap-set-boolean! (lambda (key value) + ((if value trap-enable trap-disable) key)))) + (let ((save-debug (memq 'debug dopts)) + (save-trace (memq 'trace dopts)) + (save-breakpoints (memq 'breakpoints dopts)) + (save-enter-frame (memq 'enter-frame topts)) + (save-apply-frame (memq 'apply-frame topts)) + (save-exit-frame (memq 'exit-frame topts)) + (save-enter-frame-handler (setting 'enter-frame-handler topts)) + (save-apply-frame-handler (setting 'apply-frame-handler topts)) + (save-exit-frame-handler (setting 'exit-frame-handler topts))) + (lambda () + (let ((need-trace (non-null? trace-traps)) + (need-breakpoints (non-null? breakpoint-traps)) + (need-enter-frame (non-null? enter-frame-traps)) + (need-apply-frame (non-null? apply-frame-traps)) + (need-exit-frame (non-null? exit-frame-traps))) + (debug-set-boolean! 'debug + (or need-trace + need-breakpoints + need-enter-frame + need-apply-frame + need-exit-frame + save-debug)) + (debug-set-boolean! 'trace + (or need-trace + save-trace)) + (debug-set-boolean! 'breakpoints + (or need-breakpoints + save-breakpoints)) + (trap-set-boolean! 'enter-frame + (or need-enter-frame + save-enter-frame)) + (trap-set-boolean! 'apply-frame + (or need-apply-frame + save-apply-frame)) + (trap-set-boolean! 'exit-frame + (or need-exit-frame + save-exit-frame)) + (trap-set! enter-frame-handler + (cond ((or need-breakpoints + need-enter-frame) + enter-frame-handler) + (else save-enter-frame-handler))) + (trap-set! apply-frame-handler + (cond ((or need-trace + need-apply-frame) + apply-frame-handler) + (else save-apply-frame-handler))) + (trap-set! exit-frame-handler + (cond ((or need-exit-frame) + exit-frame-handler) + (else save-exit-frame-handler)))) + ;;(write (evaluator-traps-interface)) + *unspecified*)))) + +(define (enter-frame-handler key cont . args) + ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an + ;; unmemoized copy of the source expression. For an application + ;; entry, ARGS is empty. + (if (trap-here? cont) + (let* ((application-entry? (null? args)) + (trap-context (make + #:type #:evaluation + #:continuation cont + #:expression (if application-entry? + #f + (cadr args))))) + (trc 'enter-frame-handler) + (if (and (not application-entry?) + (memq 'tweaking guile-trap-features)) + (slot-set! trap-context 'handler-return-syms '(instead))) + (run-traps (if application-entry? + enter-frame-traps + (append enter-frame-traps breakpoint-traps)) + trap-context) + (slot-ref trap-context 'handler-return-value)))) + +(define (apply-frame-handler key cont tail?) + (if (trap-here? cont) + (let ((trap-context (make + #:type #:application + #:continuation cont))) + (trc 'apply-frame-handler tail?) + (run-traps (append apply-frame-traps trace-traps) trap-context) + (slot-ref trap-context 'handler-return-value)))) + +(define (exit-frame-handler key cont retval) + (if (trap-here? cont) + (let ((trap-context (make + #:type #:return + #:continuation cont + #:return-value retval))) + (trc 'exit-frame-handler retval (tc:depth trap-context)) + (if (memq 'tweaking guile-trap-features) + (slot-set! trap-context 'handler-return-syms '(instead))) + (run-traps exit-frame-traps trap-context) + (slot-ref trap-context 'handler-return-value)))) + +(define-macro (trap-installer trap-list) + `(lambda (trap) + (set! ,trap-list (cons trap ,trap-list)) + (set-debug-and-trap-options))) + +(define install-enter-frame-trap (trap-installer enter-frame-traps)) +(define install-apply-frame-trap (trap-installer apply-frame-traps)) +(define install-exit-frame-trap (trap-installer exit-frame-traps)) +(define install-breakpoint-trap (trap-installer breakpoint-traps)) +(define install-trace-trap (trap-installer trace-traps)) + +(define-macro (trap-uninstaller trap-list) + `(lambda (trap) + (or (memq trap ,trap-list) + (error "Trap list does not include the specified trap")) + (set! ,trap-list (delq1! trap ,trap-list)) + (set-debug-and-trap-options))) + +(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps)) +(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps)) +(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps)) +(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps)) +(define uninstall-trace-trap (trap-uninstaller trace-traps)) + +(define trap-ordering (make-object-property)) +(define behaviour-ordering (make-object-property)) + +(define (run-traps traps trap-context) + (let ((behaviours (apply append + (map (lambda (trap) + (trap->behaviour trap trap-context)) + (sort traps + (lambda (t1 t2) + (< (or (trap-ordering t1) 0) + (or (trap-ordering t2) 0)))))))) + (for-each (lambda (proc) + (proc trap-context)) + (sort (delete-duplicates behaviours) + (lambda (b1 b2) + (< (or (behaviour-ordering b1) 0) + (or (behaviour-ordering b2) 0))))))) + +;;; {Pseudo-Traps for Non-Trap Events} + +;;; Once there is a body of code to do with responding to (debugging, +;;; tracing, etc.) traps, it makes sense to be able to leverage that +;;; same code for certain events that are trap-like, but not actually +;;; traps in the sense of the calls made by libguile's evaluator. + +;;; The main example of this is when an error is signalled. Guile +;;; doesn't yet have a 100% reliable way of hooking into errors, but +;;; in practice most errors go through a lazy-catch whose handler is +;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn +;;; calls default-lazy-handler. So we can present most errors as +;;; pseudo-traps by modifying default-lazy-handler. + +(define default-default-lazy-handler default-lazy-handler) + +(define (throw->trap-context key args . stack-args) + (let ((ctx (make + #:type #:error + #:continuation #f + #:return-value (cons key args)))) + (slot-set! ctx 'stack + (let ((caller-stack (and (= (length stack-args) 1) + (car stack-args)))) + (if (stack? caller-stack) + caller-stack + (apply make-stack #t stack-args)))) + ctx)) + +(define (on-lazy-handler-dispatch behaviour . ignored-keys) + (set! default-lazy-handler + (if behaviour + (lambda (key . args) + (or (memq key ignored-keys) + (behaviour (throw->trap-context key + args + lazy-handler-dispatch))) + (apply default-default-lazy-handler key args)) + default-default-lazy-handler))) + +;;; {Trap Classes} + +;;; Class: +;;; +;;; is the base class for traps. Any actual trap should be an +;;; instance of a class derived from , not of itself, +;;; because there is no base class method for the install-trap, +;;; trap-runnable? and uninstall-trap GFs. +(define-class () + ;; "number" slot: the number of this trap (assigned automatically). + (number) + ;; "installed" slot: whether this trap is installed. + (installed #:init-value #f) + ;; "condition" slot: if non-#f, this is a thunk which is called when + ;; the trap fires, to determine whether trap processing should + ;; proceed any further. + (condition #:init-value #f #:init-keyword #:condition) + ;; "skip-count" slot: a count of valid (after "condition" + ;; processing) firings of this trap to skip. + (skip-count #:init-value 0 #:init-keyword #:skip-count) + ;; "single-shot" slot: if non-#f, this trap is removed after it has + ;; successfully fired (after "condition" and "skip-count" + ;; processing) for the first time. + (single-shot #:init-value #f #:init-keyword #:single-shot) + ;; "behaviour" slot: procedure or list of procedures to call + ;; (passing the trap context as parameter) if we finally decide + ;; (after "condition" and "skip-count" processing) to run this + ;; trap's behaviour. + (behaviour #:init-value '() #:init-keyword #:behaviour) + ;; "repeat-identical-behaviour" slot: normally, if multiple + ;; objects are triggered by the same low level trap, and they + ;; request the same behaviour, it's only useful to do that behaviour + ;; once (per low level trap); so by default multiple requests for + ;; the same behaviour are coalesced. If this slot is non-#f, the + ;; contents of the "behaviour" slot are uniquified so that they + ;; avoid being coalesced in this way. + (repeat-identical-behaviour #:init-value #f + #:init-keyword #:repeat-identical-behaviour) + ;; "observer" slot: this is a procedure that is called with one + ;; EVENT argument when the trap status changes in certain + ;; interesting ways, currently the following. (1) When the trap is + ;; uninstalled because of the target becoming inaccessible; EVENT in + ;; this case is 'target-gone. + (observer #:init-value #f #:init-keyword #:observer)) + +(define last-assigned-trap-number 0) +(define all-traps (make-weak-value-hash-table 7)) + +(define-method (initialize (trap ) initargs) + (next-method) + ;; Assign a trap number, and store in the hash of all traps. + (set! last-assigned-trap-number (+ last-assigned-trap-number 1)) + (slot-set! trap 'number last-assigned-trap-number) + (hash-set! all-traps last-assigned-trap-number trap) + ;; Listify the behaviour slot, if not a list already. + (let ((behaviour (slot-ref trap 'behaviour))) + (if (procedure? behaviour) + (slot-set! trap 'behaviour (list behaviour))))) + +(define-generic install-trap) ; provided mostly by subclasses +(define-generic uninstall-trap) ; provided mostly by subclasses +(define-generic trap->behaviour) ; provided by +(define-generic trap-runnable?) ; provided by subclasses + +(define-method (install-trap (trap )) + (if (slot-ref trap 'installed) + (error "Trap is already installed")) + (slot-set! trap 'installed #t)) + +(define-method (uninstall-trap (trap )) + (or (slot-ref trap 'installed) + (error "Trap is not installed")) + (slot-set! trap 'installed #f)) + +;;; uniquify-behaviour +;;; +;;; Uniquify BEHAVIOUR by wrapping it in a new lambda. +(define (uniquify-behaviour behaviour) + (lambda (trap-context) + (behaviour trap-context))) + +;;; trap->behaviour +;;; +;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of +;;; behaviour procs to call with TRAP-CONTEXT as a parameter. +;;; Otherwise return the empty list. +(define-method (trap->behaviour (trap ) (trap-context )) + (if (and + ;; Check that the trap is runnable. Runnability is implemented + ;; by the subclass and allows us to check, for example, that + ;; the procedure being applied in an apply-frame trap matches + ;; this trap's procedure. + (trap-runnable? trap trap-context) + ;; Check the additional condition, if specified. + (let ((condition (slot-ref trap 'condition))) + (or (not condition) + ((condition)))) + ;; Check for a skip count. + (let ((skip-count (slot-ref trap 'skip-count))) + (if (zero? skip-count) + #t + (begin + (slot-set! trap 'skip-count (- skip-count 1)) + #f)))) + ;; All checks passed, so we will return the contents of this + ;; trap's behaviour slot. + (begin + ;; First, though, remove this trap if its single-shot slot + ;; indicates that it should fire only once. + (if (slot-ref trap 'single-shot) + (uninstall-trap trap)) + ;; Add this trap object to the context's list of traps which + ;; fired here. + (slot-set! trap-context 'fired-traps + (cons trap (tc:fired-traps trap-context))) + ;; Return trap behaviour, uniquified if necessary. + (if (slot-ref trap 'repeat-identical-behaviour) + (map uniquify-behaviour (slot-ref trap 'behaviour)) + (slot-ref trap 'behaviour))) + '())) + +;;; Class: +;;; +;;; An installed instance of triggers on invocation +;;; of a specific procedure. +(define-class () + ;; "procedure" slot: the procedure to trap on. This is implemented + ;; virtually, using the following weak vector slot, so as to avoid + ;; this trap preventing the GC of the target procedure. + (procedure #:init-keyword #:procedure + #:allocation #:virtual + #:slot-ref + (lambda (trap) + (vector-ref (slot-ref trap 'procedure-wv) 0)) + #:slot-set! + (lambda (trap proc) + (if (slot-bound? trap 'procedure-wv) + (vector-set! (slot-ref trap 'procedure-wv) 0 proc) + (slot-set! trap 'procedure-wv (weak-vector proc))))) + (procedure-wv)) + +;; Customization of the initialize method: set up to handle what +;; should happen when the procedure is GC'd. +(define-method (initialize (trap ) initargs) + (next-method) + (let* ((proc (slot-ref trap 'procedure)) + (existing-traps (volatile-target-traps proc))) + ;; If this is the target's first trap, give the target procedure + ;; to the volatile-target-guardian, so we can find out if it + ;; becomes inaccessible. + (or existing-traps (volatile-target-guardian proc)) + ;; Add this trap to the target procedure's list of traps. + (set! (volatile-target-traps proc) + (cons trap (or existing-traps '()))))) + +(define procedure-trace-count (make-object-property)) + +(define-method (install-trap (trap )) + (next-method) + (let* ((proc (slot-ref trap 'procedure)) + (trace-count (or (procedure-trace-count proc) 0))) + (set-procedure-property! proc 'trace #t) + (set! (procedure-trace-count proc) (+ trace-count 1))) + (install-trace-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (let* ((proc (slot-ref trap 'procedure)) + (trace-count (or (procedure-trace-count proc) 0))) + (if (= trace-count 1) + (set-procedure-property! proc 'trace #f)) + (set! (procedure-trace-count proc) (- trace-count 1))) + (uninstall-trace-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (eq? (slot-ref trap 'procedure) + (frame-procedure (tc:frame trap-context)))) + +;;; Class: +;;; +;;; An installed instance of triggers on stack frame exit +;;; past a specified stack depth. +(define-class () + ;; "depth" slot: the reference depth for the trap. + (depth #:init-keyword #:depth)) + +(define-method (install-trap (trap )) + (next-method) + (install-exit-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-exit-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (<= (tc:exit-depth trap-context) + (slot-ref trap 'depth))) + +;;; Class: +;;; +;;; An installed instance of triggers on any frame entry. +(define-class ()) + +(define-method (install-trap (trap )) + (next-method) + (install-enter-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-enter-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + #t) + +;;; Class: +;;; +;;; An installed instance of triggers on any procedure +;;; application. +(define-class ()) + +(define-method (install-trap (trap )) + (next-method) + (install-apply-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-apply-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + #t) + +;;; Class: +;;; +;;; An installed instance of triggers on the next frame +;;; entry, exit or application, optionally with source location inside +;;; a specified file. +(define-class () + ;; "file-name" slot: if non-#f, indicates that this trap should + ;; trigger only for steps in source code from the specified file. + (file-name #:init-value #f #:init-keyword #:file-name) + ;; "exit-depth" slot: when non-#f, indicates that the next step may + ;; be a frame exit past this depth; otherwise, indicates that the + ;; next step must be an application or a frame entry. + (exit-depth #:init-value #f #:init-keyword #:exit-depth)) + +(define-method (initialize (trap ) initargs) + (next-method) + (slot-set! trap 'depth (slot-ref trap 'exit-depth))) + +(define-method (install-trap (trap )) + (next-method) + (install-enter-frame-trap trap) + (install-apply-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-enter-frame-trap trap) + (uninstall-apply-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (if (eq? (tc:type trap-context) #:return) + ;; We're in the context of an exit-frame trap. Trap should only + ;; be run if exit-depth is set and this exit-frame has returned + ;; past the set depth. + (and (slot-ref trap 'exit-depth) + (next-method) + ;; OK to run the trap here, but we should first reset the + ;; exit-depth slot to indicate that the step after this one + ;; must be an application or frame entry. + (begin + (slot-set! trap 'exit-depth #f) + #t)) + ;; We're in the context of an application or frame entry trap. + ;; Check whether trap is limited to a specified file. + (let ((file-name (slot-ref trap 'file-name))) + (and (or (not file-name) + (equal? (frame-file-name (tc:frame trap-context)) file-name)) + ;; Trap should run here, but we should also set exit-depth to + ;; the current stack length, so that - if we don't stop at any + ;; other steps first - the next step shows the return value of + ;; the current application or evaluation. + (begin + (slot-set! trap 'exit-depth (tc:depth trap-context)) + (slot-set! trap 'depth (tc:depth trap-context)) + #t))))) + +(define (frame->source-position frame) + (let ((source (if (frame-procedure? frame) + (or (frame-source frame) + (let ((proc (frame-procedure frame))) + (and proc + (procedure? proc) + (procedure-source proc)))) + (frame-source frame)))) + (and source + (string? (source-property source 'filename)) + (list (source-property source 'filename) + (source-property source 'line) + (source-property source 'column))))) + +(define (frame-file-name frame) + (cond ((frame->source-position frame) => car) + (else #f))) + +;;; Class: +;;; +;;; An installed instance of triggers upon evaluation of +;;; a specified source expression. +(define-class () + ;; "expression" slot: the expression to trap on. This is + ;; implemented virtually, using the following weak vector slot, so + ;; as to avoid this trap preventing the GC of the target source + ;; code. + (expression #:init-keyword #:expression + #:allocation #:virtual + #:slot-ref + (lambda (trap) + (vector-ref (slot-ref trap 'expression-wv) 0)) + #:slot-set! + (lambda (trap expr) + (if (slot-bound? trap 'expression-wv) + (vector-set! (slot-ref trap 'expression-wv) 0 expr) + (slot-set! trap 'expression-wv (weak-vector expr))))) + (expression-wv) + ;; source property slots - for internal use only + (filename) + (line) + (column)) + +;; Customization of the initialize method: get and save the +;; expression's source properties, or signal an error if it doesn't +;; have the necessary properties. +(define-method (initialize (trap ) initargs) + (next-method) + (let* ((expr (slot-ref trap 'expression)) + (filename (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column)) + (existing-traps (volatile-target-traps expr))) + (or (and filename line column) + (error "Specified source does not have the necessary properties" + filename line column)) + (slot-set! trap 'filename filename) + (slot-set! trap 'line line) + (slot-set! trap 'column column) + ;; If this is the target's first trap, give the target expression + ;; to the volatile-target-guardian, so we can find out if it + ;; becomes inaccessible. + (or existing-traps (volatile-target-guardian expr)) + ;; Add this trap to the target expression's list of traps. + (set! (volatile-target-traps expr) + (cons trap (or existing-traps '()))))) + +;; Just in case more than one trap is installed on the same source +;; expression ... so that we can still get the setting and resetting +;; of the 'breakpoint source property correct. +(define source-breakpoint-count (make-object-property)) + +(define-method (install-trap (trap )) + (next-method) + (let* ((expr (slot-ref trap 'expression)) + (breakpoint-count (or (source-breakpoint-count expr) 0))) + (set-source-property! expr 'breakpoint #t) + (set! (source-breakpoint-count expr) (+ breakpoint-count 1))) + (install-breakpoint-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (let* ((expr (slot-ref trap 'expression)) + (breakpoint-count (or (source-breakpoint-count expr) 0))) + (if (= breakpoint-count 1) + (set-source-property! expr 'breakpoint #f)) + (set! (source-breakpoint-count expr) (- breakpoint-count 1))) + (uninstall-breakpoint-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (or (eq? (slot-ref trap 'expression) + (tc:expression trap-context)) + (let ((trap-location (frame->source-position (tc:frame trap-context)))) + (and trap-location + (string=? (car trap-location) (slot-ref trap 'filename)) + (= (cadr trap-location) (slot-ref trap 'line)) + (= (caddr trap-location) (slot-ref trap 'column)))))) + +;; (trap-here EXPRESSION . OPTIONS) +(define trap-here + (procedure->memoizing-macro + (lambda (expr env) + (let ((trap (apply make + + #:expression expr + (local-eval `(list ,@(cddr expr)) + env)))) + (install-trap trap) + (set-car! expr 'begin) + (set-cdr! (cdr expr) '()) + expr)))) + +;;; Class: +;;; +;;; An installed instance of triggers on entry to a +;;; frame with a more-or-less precisely specified source location. +(define-class () + ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to + ;; trap in. + (file-regexp #:init-keyword #:file-regexp) + ;; "line" and "column" slots: position to trap at (0-based). + (line #:init-value #f #:init-keyword #:line) + (column #:init-value #f #:init-keyword #:column) + ;; "compiled-regexp" slot - self explanatory, internal use only + (compiled-regexp)) + +(define-method (initialize (trap ) initargs) + (next-method) + (slot-set! trap 'compiled-regexp + (make-regexp (slot-ref trap 'file-regexp)))) + +(define-method (install-trap (trap )) + (next-method) + (install-enter-frame-trap trap)) + +(define-method (uninstall-trap (trap )) + (next-method) + (uninstall-enter-frame-trap trap)) + +(define-method (trap-runnable? (trap ) + (trap-context )) + (and-let* ((trap-location (frame->source-position (tc:frame trap-context))) + (tcline (cadr trap-location)) + (tccolumn (caddr trap-location))) + (and (= tcline (slot-ref trap 'line)) + (= tccolumn (slot-ref trap 'column)) + (regexp-exec (slot-ref trap 'compiled-regexp) + (car trap-location) 0)))) + +;;; {Misc Trap Utilities} + +(define (get-trap number) + (hash-ref all-traps number)) + +(define (list-traps) + (for-each describe + (map cdr (sort (hash-fold acons '() all-traps) + (lambda (x y) (< (car x) (car y))))))) + +;;; {Volatile Traps} +;;; +;;; Some traps are associated with Scheme objects that are likely to +;;; be GC'd, such as procedures and read expressions. When those +;;; objects are GC'd, we want to allow their traps to evaporate as +;;; well, or at least not to prevent them from doing so because they +;;; are (now pointlessly) included on the various installed trap +;;; lists. + +;; An object property that maps each volatile target to the list of +;; traps that are installed on it. +(define volatile-target-traps (make-object-property)) + +;; A guardian that tells us when a volatile target is no longer +;; accessible. +(define volatile-target-guardian (make-guardian)) + +;; An after GC hook that checks for newly inaccessible targets. +(add-hook! after-gc-hook + (lambda () + (trc 'after-gc-hook) + (let loop ((target (volatile-target-guardian))) + (if target + ;; We have a target which is now inaccessible. Get + ;; the list of traps installed on it. + (begin + (trc 'after-gc-hook "got target") + ;; Uninstall all the traps that are installed on + ;; this target. + (for-each (lambda (trap) + (trc 'after-gc-hook "got trap") + ;; If the trap is still installed, + ;; uninstall it. + (if (slot-ref trap 'installed) + (uninstall-trap trap)) + ;; If the trap has an observer, tell + ;; it that the target has gone. + (cond ((slot-ref trap 'observer) + => + (lambda (proc) + (trc 'after-gc-hook "call obs") + (proc 'target-gone))))) + (or (volatile-target-traps target) '())) + ;; Check for any more inaccessible targets. + (loop (volatile-target-guardian))))))) + +(define (without-traps thunk) + (with-traps (lambda () + (trap-disable 'traps) + (thunk)))) + +(define guile-trap-features + ;; Helper procedure, to test whether a specific possible Guile + ;; feature is supported. + (let ((supported? + (lambda (test-feature) + (case test-feature + ((tweaking) + ;; Tweaking is supported if the description of the cheap + ;; traps option includes the word "obsolete", or if the + ;; option isn't there any more. + (and (string>=? (version) "1.7") + (let ((cheap-opt-desc + (assq 'cheap (debug-options-interface 'help)))) + (or (not cheap-opt-desc) + (string-match "obsolete" (caddr cheap-opt-desc)))))) + (else + (error "Unexpected feature name:" test-feature)))))) + ;; Compile the list of actually supported features from all + ;; possible features. + (let loop ((possible-features '(tweaking)) + (actual-features '())) + (if (null? possible-features) + (reverse! actual-features) + (let ((test-feature (car possible-features))) + (loop (cdr possible-features) + (if (supported? test-feature) + (cons test-feature actual-features) + actual-features))))))) + +;; Make sure that traps are enabled. +(trap-enable 'traps) + +;;; (ice-9 debugging traps) ends here. diff --git a/ice-9/debugging/trc.scm b/ice-9/debugging/trc.scm new file mode 100644 index 000000000..9e95d7e5c --- /dev/null +++ b/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.