diff options
author | Andy Wingo <wingo@pobox.com> | 2010-09-24 18:24:41 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-09-24 18:24:41 +0200 |
commit | d2c7e7de405682c043c8e4f2d7285824aafca71f (patch) | |
tree | 2c6bc22745508ac218aca29b6abcb6c60da40fb8 | |
parent | 3b494f511ad6966acfa5bad751e27b152254fad5 (diff) | |
download | guile-d2c7e7de405682c043c8e4f2d7285824aafca71f.tar.gz |
remove (ice-9 debugger) and (ice-9 debugging)
* module/ice-9/debugger.scm:
* module/ice-9/debugger/command-loop.scm:
* module/ice-9/debugger/commands.scm:
* module/ice-9/debugger/state.scm:
* module/ice-9/debugger/trc.scm:
* module/ice-9/debugger/utils.scm:
* module/ice-9/debugging/breakpoints.scm:
* module/ice-9/debugging/example-fns.scm:
* module/ice-9/debugging/ice-9-debugger-extensions.scm:
* module/ice-9/debugging/load-hooks.scm:
* module/ice-9/debugging/steps.scm:
* module/ice-9/debugging/trace.scm:
* module/ice-9/debugging/traps.scm:
* module/ice-9/debugging/trc.scm: Remove these files, as we will favor
the REPL's implementation of a debugger, and (system vm traps) and
(system vm trap-state). But these old files will continue to inspire
the rest of the new debugger interface.
-rw-r--r-- | module/Makefile.am | 10 | ||||
-rw-r--r-- | module/ice-9/debugger.scm | 167 | ||||
-rw-r--r-- | module/ice-9/debugger/command-loop.scm | 552 | ||||
-rw-r--r-- | module/ice-9/debugger/commands.scm | 208 | ||||
-rw-r--r-- | module/ice-9/debugger/state.scm | 47 | ||||
-rw-r--r-- | module/ice-9/debugger/trc.scm | 63 | ||||
-rw-r--r-- | module/ice-9/debugger/utils.scm | 203 | ||||
-rw-r--r-- | module/ice-9/debugging/breakpoints.scm | 414 | ||||
-rw-r--r-- | module/ice-9/debugging/example-fns.scm | 17 | ||||
-rw-r--r-- | module/ice-9/debugging/ice-9-debugger-extensions.scm | 0 | ||||
-rw-r--r-- | module/ice-9/debugging/load-hooks.scm | 33 | ||||
-rw-r--r-- | module/ice-9/debugging/steps.scm | 106 | ||||
-rw-r--r-- | module/ice-9/debugging/trace.scm | 153 | ||||
-rwxr-xr-x | module/ice-9/debugging/traps.scm | 1011 | ||||
-rw-r--r-- | module/ice-9/debugging/trc.scm | 63 |
15 files changed, 0 insertions, 3047 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 1202e2010..0e50b7119 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -353,16 +353,6 @@ NOCOMP_SOURCES = \ ice-9/quasisyntax.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ - ice-9/debugger/command-loop.scm \ - ice-9/debugger/commands.scm \ - ice-9/debugger/state.scm \ - ice-9/debugger/trc.scm \ - ice-9/debugger/utils.scm \ - ice-9/debugging/example-fns.scm \ - ice-9/debugging/steps.scm \ - ice-9/debugging/trace.scm \ - ice-9/debugging/traps.scm \ - ice-9/debugging/trc.scm \ sxml/sxml-match.ss \ sxml/upstream/SSAX.scm \ sxml/upstream/SXML-tree-trans.scm \ diff --git a/module/ice-9/debugger.scm b/module/ice-9/debugger.scm deleted file mode 100644 index 9a5e4af87..000000000 --- a/module/ice-9/debugger.scm +++ /dev/null @@ -1,167 +0,0 @@ -;;;; Guile Debugger - -;;; Copyright (C) 1999, 2001, 2002, 2006, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugger) - #:use-module (ice-9 debugger command-loop) - #:use-module (ice-9 debugger state) - #:use-module (ice-9 debugger utils) - #:use-module (ice-9 debugging traps) - #:use-module (ice-9 scm-style-repl) - #:use-module (ice-9 save-stack) - #:use-module (ice-9 format) - #:export (debug-stack - debug - debug-last-error - debugger-error - debugger-quit - debugger-input-port - debugger-output-port - debug-on-error) - #:no-backtrace) - -;;; The old (ice-9 debugger) has been factored into its constituent -;;; parts: -;;; -;;; (ice-9 debugger) - public interface to all of the following -;;; -;;; (... commands) - procedures implementing the guts of the commands -;;; provided by the interactive debugger -;;; -;;; (... command-loop) - binding these commands into the interactive -;;; debugger command loop -;;; -;;; (... state) - implementation of an object that tracks current -;;; debugger state -;;; -;;; (... utils) - utilities for printing out frame and stack -;;; information in various formats -;;; -;;; The division between (... commands) and (... command-loop) exists -;;; because I (NJ) have another generic command loop implementation -;;; under development, and I want to be able to switch easily between -;;; that and the command loop implementation here. Thus the -;;; procedures in this file delegate to a debugger command loop -;;; implementation via the `debugger-command-loop-*' interface. The -;;; (ice-9 debugger command-loop) implementation can be replaced by -;;; any other that implements the `debugger-command-loop-*' interface -;;; simply by changing the relevant #:use-module line above. -;;; -;;; - Neil Jerram <neil@ossau.uklinux.net> 2002-10-26, updated 2005-07-09 - -(define *not-yet-introduced* #t) - -(define (debug-stack stack . flags) - "Invoke the Guile debugger to explore the specified @var{stack}. - -@var{flags}, if present, are keywords indicating characteristics of -the debugging session: the valid keywords are as follows. - -@table @code -@item #:continuable -Indicates that the debugger is being invoked from a context (such as -an evaluator trap handler) where it is possible to return from the -debugger and continue normal code execution. This enables the -@dfn{continuing execution} commands, for example @code{continue} and -@code{step}. - -@item #:with-introduction -Indicates that the debugger should display an introductory message. -@end table" - (start-stack 'debugger - (let ((state (apply make-state stack 0 flags))) - (with-input-from-port (debugger-input-port) - (lambda () - (with-output-to-port (debugger-output-port) - (lambda () - (if (or *not-yet-introduced* - (memq #:with-introduction flags)) - (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 state) - (debugger-command-loop state)))))))) - -(define (debug) - "Invoke the Guile debugger to explore the context of the last error." - (let ((stack (fluid-ref the-last-stack))) - (if stack - (debug-stack stack) - (display "Nothing to debug.\n")))) - -(define debug-last-error debug) - -(define (debugger-error message) - "Signal a debugger usage error with message @var{message}." - (debugger-command-loop-error message)) - -(define (debugger-quit) - "Exit the debugger." - (debugger-command-loop-quit)) - -;;; {Debugger Input and Output Ports} - -(define debugger-input-port - (let ((input-port (current-input-port))) - (make-procedure-with-setter - (lambda () input-port) - (lambda (port) (set! input-port port))))) - -(define debugger-output-port - (let ((output-port (current-output-port))) - (make-procedure-with-setter - (lambda () output-port) - (lambda (port) (set! output-port port))))) - -;;; {Debug on Error} - -(define (debug-on-error syms) - "Enable or disable debug on error." - (set! default-pre-unwind-handler - (if syms - (lambda (key . args) - (if (memq key syms) - (begin - (debug-stack (make-stack #t default-pre-unwind-handler) - #:with-introduction - #:continuable) - (throw 'abort key))) - (apply default-pre-unwind-handler key args)) - default-pre-unwind-handler))) - -;;; Also provide a `debug-trap' entry point. This maps from a -;;; trap-context to a debug-stack call. - -(define-public (debug-trap trap-context) - "Invoke the Guile debugger to explore the stack at the specified @var{trap-context}." - (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))) - (apply debug-stack stack flags))) - -;;; (ice-9 debugger) ends here. diff --git a/module/ice-9/debugger/command-loop.scm b/module/ice-9/debugger/command-loop.scm deleted file mode 100644 index b58952dcd..000000000 --- a/module/ice-9/debugger/command-loop.scm +++ /dev/null @@ -1,552 +0,0 @@ -;;;; Guile Debugger command loop - -;;; Copyright (C) 1999, 2001, 2002, 2003, 2006, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugger command-loop) - #:use-module ((ice-9 debugger commands) :prefix debugger:) - #:use-module (ice-9 debugger) - #:use-module (ice-9 debugger state) - #:use-module (ice-9 debugging traps) - #:use-module (ice-9 save-stack) - #:export (debugger-command-loop - debugger-command-loop-error - debugger-command-loop-quit) - #:no-backtrace) - -;;; {Interface used by (ice-9 debugger).} - -(define (debugger-command-loop state) - (read-and-dispatch-commands state (current-input-port))) - -(define (debugger-command-loop-error message) - (user-error message)) - -(define (debugger-command-loop-quit) - (throw 'exit-debugger)) - -;;; {Implementation.} - -(define debugger-prompt "debug> ") - -(define (debugger-handler key . args) - (case key - ((exit-debugger) #f) - ((signal) - (apply display-error #f (current-error-port) args)) - (else - (display "Internal debugger error:\n") - (save-stack debugger-handler) - (apply throw key args))) - (throw 'exit-debugger)) ;Pop the stack - -(define (read-and-dispatch-commands state port) - (catch 'exit-debugger - (lambda () - (lazy-catch #t - (lambda () - (with-fluids ((last-command #f)) - (let loop () - (read-and-dispatch-command state port) - (loop)))) - debugger-handler)) - (lambda args - *unspecified*))) - -(define set-readline-prompt! #f) - -(define (read-and-dispatch-command state port) - (if (using-readline?) - (begin - ;; Import set-readline-prompt! if we haven't already. - (or set-readline-prompt! - (set! set-readline-prompt! - (module-ref (resolve-module '(ice-9 readline)) - 'set-readline-prompt!))) - (set-readline-prompt! debugger-prompt debugger-prompt)) - (display debugger-prompt)) - (force-output) ;This should not be necessary... - (let ((token (read-token port))) - (cond ((eof-object? token) - (throw 'exit-debugger)) - ((not token) - (discard-rest-of-line port) - (catch-user-errors port (lambda () (run-last-command state)))) - (else - (catch-user-errors port - (lambda () - (dispatch-command token command-table state port))))))) - -(define (run-last-command state) - (let ((procedure (fluid-ref last-command))) - (if procedure - (procedure state)))) - -(define (catch-user-errors port thunk) - (catch 'debugger-user-error - thunk - (lambda (key . objects) - (apply user-warning objects) - (discard-rest-of-line port)))) - -(define last-command (make-fluid)) - -(define (user-warning . objects) - (for-each (lambda (object) - (display object)) - objects) - (newline)) - -(define (user-error . objects) - (apply throw 'debugger-user-error objects)) - -;;;; Command dispatch - -(define (dispatch-command string table state port) - (let ((value (command-table-value table string))) - (if value - (dispatch-command/value value state port) - (user-error "Unknown command: " string)))) - -(define (dispatch-command/value value state port) - (cond ((command? value) - (dispatch-command/command value state port)) - ((command-table? value) - (dispatch-command/table value state port)) - ((list? value) - (dispatch-command/name value state port)) - (else - (error "Unrecognized command-table value: " value)))) - -(define (dispatch-command/command command state port) - (let ((procedure (command-procedure command)) - (arguments ((command-parser command) port))) - (let ((procedure (lambda (state) (apply procedure state arguments)))) - (warn-about-extra-args port) - (fluid-set! last-command procedure) - (procedure state)))) - -(define (warn-about-extra-args port) - ;; **** modify this to show the arguments. - (let ((char (skip-whitespace port))) - (cond ((eof-object? char) #f) - ((char=? #\newline char) (read-char port)) - (else - (user-warning "Extra arguments at end of line: " - (read-rest-of-line port)))))) - -(define (dispatch-command/table table state port) - (let ((token (read-token port))) - (if (or (eof-object? token) - (not token)) - (user-error "Command name too short.") - (dispatch-command token table state port)))) - -(define (dispatch-command/name name state port) - (let ((value (lookup-command name))) - (cond ((not value) - (apply user-error "Unknown command name: " name)) - ((command-table? value) - (apply user-error "Partial command name: " name)) - (else - (dispatch-command/value value state port))))) - -;;;; Command definition - -(define (define-command name argument-template procedure) - (let ((name (canonicalize-command-name name))) - (add-command name - (make-command name - (argument-template->parser argument-template) - (procedure-documentation procedure) - procedure) - command-table) - name)) - -(define (define-command-alias name1 name2) - (let ((name1 (canonicalize-command-name name1))) - (add-command name1 (canonicalize-command-name name2) command-table) - name1)) - -(define (argument-template->parser template) - ;; Deliberately handles only cases that occur in "commands.scm". - (cond ((eq? 'tokens template) - (lambda (port) - (let loop ((tokens '())) - (let ((token (read-token port))) - (if (or (eof-object? token) - (not token)) - (list (reverse! tokens)) - (loop (cons token tokens))))))) - ((null? template) - (lambda (port) - '())) - ((and (pair? template) - (null? (cdr template)) - (eq? 'object (car template))) - (lambda (port) - (list (read port)))) - ((and (pair? template) - (equal? ''optional (car template)) - (pair? (cdr template)) - (null? (cddr template))) - (case (cadr template) - ((token) - (lambda (port) - (let ((token (read-token port))) - (if (or (eof-object? token) - (not token)) - (list #f) - (list token))))) - ((exact-integer) - (lambda (port) - (list (parse-optional-exact-integer port)))) - ((exact-nonnegative-integer) - (lambda (port) - (list (parse-optional-exact-nonnegative-integer port)))) - ((object) - (lambda (port) - (list (parse-optional-object port)))) - (else - (error "Malformed argument template: " template)))) - (else - (error "Malformed argument template: " template)))) - -(define (parse-optional-exact-integer port) - (let ((object (parse-optional-object port))) - (if (or (not object) - (and (integer? object) - (exact? object))) - object - (user-error "Argument not an exact integer: " object)))) - -(define (parse-optional-exact-nonnegative-integer port) - (let ((object (parse-optional-object port))) - (if (or (not object) - (and (integer? object) - (exact? object) - (not (negative? object)))) - object - (user-error "Argument not an exact non-negative integer: " object)))) - -(define (parse-optional-object port) - (let ((terminator (skip-whitespace port))) - (if (or (eof-object? terminator) - (eq? #\newline terminator)) - #f - (let ((object (read port))) - (if (eof-object? object) - #f - object))))) - -;;;; Command tables - -(define (lookup-command name) - (let loop ((table command-table) (strings name)) - (let ((value (command-table-value table (car strings)))) - (cond ((or (not value) (null? (cdr strings))) value) - ((command-table? value) (loop value (cdr strings))) - (else #f))))) - -(define (command-table-value table string) - (let ((entry (command-table-entry table string))) - (and entry - (caddr entry)))) - -(define (command-table-entry table string) - (let loop ((entries (command-table-entries table))) - (and (not (null? entries)) - (let ((entry (car entries))) - (if (and (<= (cadr entry) - (string-length string) - (string-length (car entry))) - (= (string-length string) - (match-strings (car entry) string))) - entry - (loop (cdr entries))))))) - -(define (match-strings s1 s2) - (let ((n (min (string-length s1) (string-length s2)))) - (let loop ((i 0)) - (cond ((= i n) i) - ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1))) - (else i))))) - -(define (write-command-name name) - (display (car name)) - (for-each (lambda (string) - (write-char #\space) - (display string)) - (cdr name))) - -(define (add-command name value table) - (let loop ((strings name) (table table)) - (let ((entry - (or (let loop ((entries (command-table-entries table))) - (and (not (null? entries)) - (if (string=? (car strings) (caar entries)) - (car entries) - (loop (cdr entries))))) - (let ((entry (list (car strings) #f #f))) - (let ((entries - (let ((entries (command-table-entries table))) - (if (or (null? entries) - (string<? (car strings) (caar entries))) - (cons entry entries) - (begin - (let loop ((prev entries) (this (cdr entries))) - (if (or (null? this) - (string<? (car strings) (caar this))) - (set-cdr! prev (cons entry this)) - (loop this (cdr this)))) - entries))))) - (compute-string-abbreviations! entries) - (set-command-table-entries! table entries)) - entry)))) - (if (null? (cdr strings)) - (set-car! (cddr entry) value) - (loop (cdr strings) - (if (command-table? (caddr entry)) - (caddr entry) - (let ((table (make-command-table '()))) - (set-car! (cddr entry) table) - table))))))) - -(define (canonicalize-command-name name) - (cond ((and (string? name) - (not (string-null? name))) - (list name)) - ((let loop ((name name)) - (and (pair? name) - (string? (car name)) - (not (string-null? (car name))) - (or (null? (cdr name)) - (loop (cdr name))))) - name) - (else - (error "Illegal command name: " name)))) - -(define (compute-string-abbreviations! entries) - (let loop ((entries entries) (index 0)) - (let ((groups '())) - (for-each - (lambda (entry) - (let* ((char (string-ref (car entry) index)) - (group (assv char groups))) - (if group - (set-cdr! group (cons entry (cdr group))) - (set! groups - (cons (list char entry) - groups))))) - entries) - (for-each - (lambda (group) - (let ((index (+ index 1))) - (if (null? (cddr group)) - (set-car! (cdadr group) index) - (loop (let ((entry - (let loop ((entries (cdr group))) - (and (not (null? entries)) - (if (= index (string-length (caar entries))) - (car entries) - (loop (cdr entries))))))) - (if entry - (begin - (set-car! (cdr entry) index) - (delq entry (cdr group))) - (cdr group))) - index)))) - groups)))) - -;;;; Data structures - -(define command-table-rtd (make-record-type "command-table" '(entries))) -(define make-command-table (record-constructor command-table-rtd '(entries))) -(define command-table? (record-predicate command-table-rtd)) -(define command-table-entries (record-accessor command-table-rtd 'entries)) -(define set-command-table-entries! - (record-modifier command-table-rtd 'entries)) - -(define command-rtd - (make-record-type "command" - '(name parser documentation procedure))) - -(define make-command - (record-constructor command-rtd - '(name parser documentation procedure))) - -(define command? (record-predicate command-rtd)) -(define command-name (record-accessor command-rtd 'name)) -(define command-parser (record-accessor command-rtd 'parser)) -(define command-documentation (record-accessor command-rtd 'documentation)) -(define command-procedure (record-accessor command-rtd 'procedure)) - -;;;; Character parsing - -(define (read-token port) - (letrec - ((loop - (lambda (chars) - (let ((char (peek-char port))) - (cond ((eof-object? char) - (do-eof char chars)) - ((char=? #\newline char) - (do-eot chars)) - ((char-whitespace? char) - (do-eot chars)) - ((char=? #\# char) - (read-char port) - (let ((terminator (skip-comment port))) - (if (eof-object? char) - (do-eof char chars) - (do-eot chars)))) - (else - (read-char port) - (loop (cons char chars))))))) - (do-eof - (lambda (eof chars) - (if (null? chars) - eof - (do-eot chars)))) - (do-eot - (lambda (chars) - (if (null? chars) - #f - (list->string (reverse! chars)))))) - (skip-whitespace port) - (loop '()))) - -(define (skip-whitespace port) - (let ((char (peek-char port))) - (cond ((or (eof-object? char) - (char=? #\newline char)) - char) - ((char-whitespace? char) - (read-char port) - (skip-whitespace port)) - ((char=? #\# char) - (read-char port) - (skip-comment port)) - (else char)))) - -(define (skip-comment port) - (let ((char (peek-char port))) - (if (or (eof-object? char) - (char=? #\newline char)) - char - (begin - (read-char port) - (skip-comment port))))) - -(define (read-rest-of-line port) - (let loop ((chars '())) - (let ((char (read-char port))) - (if (or (eof-object? char) - (char=? #\newline char)) - (list->string (reverse! chars)) - (loop (cons char chars)))))) - -(define (discard-rest-of-line port) - (let loop () - (if (not (let ((char (read-char port))) - (or (eof-object? char) - (char=? #\newline char)))) - (loop)))) - -;;;; Commands - -(define command-table (make-command-table '())) - -(define-command "help" 'tokens - (lambda (state tokens) - "Type \"help\" followed by a command name for full documentation." - (let loop ((name (if (null? tokens) '("help") tokens))) - (let ((value (lookup-command name))) - (cond ((not value) - (write-command-name name) - (display " is not a known command name.") - (newline)) - ((command? value) - (display (command-documentation value)) - (newline) - (if (equal? '("help") (command-name value)) - (begin - (display "Available commands are:") - (newline) - (for-each (lambda (entry) - (if (not (list? (caddr entry))) - (begin - (display " ") - (display (car entry)) - (newline)))) - (command-table-entries command-table))))) - ((command-table? value) - (display "The \"") - (write-command-name name) - (display "\" command requires a subcommand.") - (newline) - (display "Available subcommands are:") - (newline) - (for-each (lambda (entry) - (if (not (list? (caddr entry))) - (begin - (display " ") - (write-command-name name) - (write-char #\space) - (display (car entry)) - (newline)))) - (command-table-entries value))) - ((list? value) - (loop value)) - (else - (error "Unknown value from lookup-command:" value))))) - state)) - -(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame) - -(define-command "position" '() debugger:position) - -(define-command "up" '('optional exact-integer) debugger:up) - -(define-command "down" '('optional exact-integer) debugger:down) - -(define-command "backtrace" '('optional exact-integer) debugger:backtrace) - -(define-command "evaluate" '(object) debugger:evaluate) - -(define-command '("info" "args") '() debugger:info-args) - -(define-command '("info" "frame") '() debugger:info-frame) - -(define-command "quit" '() - (lambda (state) - "Exit the debugger." - (debugger-command-loop-quit))) - -(define-command-alias "f" "frame") -(define-command-alias '("info" "f") '("info" "frame")) -(define-command-alias "bt" "backtrace") -(define-command-alias "where" "backtrace") -(define-command-alias "p" "evaluate") -(define-command-alias '("info" "stack") "backtrace") - -(define-command "continue" '() debugger:continue) - -(define-command "finish" '() debugger:finish) - -(define-command "step" '('optional exact-integer) debugger:step) - -(define-command "next" '('optional exact-integer) debugger:next) diff --git a/module/ice-9/debugger/commands.scm b/module/ice-9/debugger/commands.scm deleted file mode 100644 index eece990fb..000000000 --- a/module/ice-9/debugger/commands.scm +++ /dev/null @@ -1,208 +0,0 @@ -;;;; (ice-9 debugger commands) -- debugger commands - -;;; Copyright (C) 2002, 2006, 2009, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugger commands) - #:use-module ((ice-9 scm-style-repl) #:select (bad-throw)) - #:use-module (ice-9 debugger) - #:use-module (ice-9 debugger state) - #:use-module (ice-9 debugger utils) - #:use-module (ice-9 debugging steps) - #:export (backtrace - evaluate - info-args - info-frame - position - up - down - frame - continue - finish - step - next)) - -(define (backtrace state n-frames) - "Print backtrace of all stack frames, or innermost COUNT frames. -With a negative argument, print outermost -COUNT frames. -If the number of frames isn't explicitly given, the debug option -`depth' determines the maximum number of frames printed." - (let ((stack (state-stack state))) - ;; Kludge around lack of call-with-values. - (let ((values - (lambda (start end) - (display-backtrace stack - (current-output-port) - (if (memq 'backwards (debug-options)) - start - (- end 1)) - (- end start)) - ))) - (let ((end (stack-length stack))) - (cond ((not n-frames) ;(>= (abs n-frames) end)) - (values 0 (min end (cadr (memq 'depth (debug-options)))))) - ((>= n-frames 0) - (values 0 n-frames)) - (else - (values (+ end n-frames) end))))))) - -(define (eval-handler key . args) - (let ((stack (make-stack #t eval-handler))) - (if (= (length args) 4) - (apply display-error stack (current-error-port) args) - ;; We want display-error to be the "final common pathway" - (catch #t - (lambda () - (apply bad-throw key args)) - (lambda (key . args) - (apply display-error stack (current-error-port) args))))) - (throw 'continue)) - -;; FIXME: no longer working due to no more local-eval -(define (evaluate state expression) - "Evaluate an expression in the environment of the selected stack frame. -The expression must appear on the same line as the command, however it -may be continued over multiple lines." - (let ((source (frame-source (stack-ref (state-stack state) - (state-index state))))) - (if (not source) - (display "No environment for this frame.\n") - (catch 'continue - (lambda () - (lazy-catch #t - (lambda () - (let* ((expr - ;; We assume that no one will - ;; really want to evaluate a - ;; string (since it is - ;; self-evaluating); so if we - ;; have a string here, read the - ;; expression to evaluate from - ;; it. - (if (string? expression) - (with-input-from-string expression - read) - expression)) - (env (memoized-environment source)) - (value (local-eval expr env))) - (write expr) - (display " => ") - (write value) - (newline))) - eval-handler)) - (lambda args args))))) - -(define (info-args state) - "Display the argument variables of the current stack frame. -Arguments can also be seen in the backtrace, but are presented more -clearly by this command." - (let ((index (state-index state))) - (let ((frame (stack-ref (state-stack state) index))) - (write-frame-index-long frame) - (write-frame-args-long frame)))) - -(define (info-frame state) - "Display a verbose description of the selected frame. The -information that this command provides is equivalent to what can be -deduced from the one line summary for the frame that appears in a -backtrace, but is presented and explained more clearly." - (write-state-long state)) - -(define (position state) - "Display the name of the source file that the current expression -comes from, and the line and column number of the expression's opening -parenthesis within that file. This information is only available when -the 'positions read option is enabled." - (let* ((frame (stack-ref (state-stack state) (state-index state))) - (source (frame-source frame))) - (if (not source) - (display "No source available for this frame.") - (let ((position (source-position source))) - (if (not position) - (display "No position information available for this frame.") - (display-position position))))) - (newline)) - -(define (up state n) - "Move @var{n} frames up the stack. For positive @var{n}, this -advances toward the outermost frame, to lower frame numbers, to -frames that have existed longer. @var{n} defaults to one." - (set-stack-index! state (+ (state-index state) (or n 1))) - (write-state-short state)) - -(define (down state n) - "Move @var{n} frames down the stack. For positive @var{n}, this -advances toward the innermost frame, to higher frame numbers, to frames -that were created more recently. @var{n} defaults to one." - (set-stack-index! state (- (state-index state) (or n 1))) - (write-state-short state)) - -(define (frame state n) - "Select and print a stack frame. -With no argument, print the selected stack frame. (See also \"info frame\"). -An argument specifies the frame to select; it must be a stack-frame number." - (if n (set-stack-index! state (frame-number->index n (state-stack state)))) - (write-state-short state)) - -(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 (continue state) - "Tell the program being debugged to continue running. (In fact this is -the same as the @code{quit} command, because it exits the debugger -command loop and so allows whatever code it was that invoked the -debugger to continue.)" - (assert-continuable state) - (throw 'exit-debugger)) - -(define (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)) - (continue state)) - -(define (step state n) - "Tell the debugged program to do @var{n} more steps from its current -position. One @dfn{step} means executing until the next frame entry -or exit of any kind. @var{n} defaults to 1." - (assert-continuable state) - (at-step debug-trap (or n 1)) - (continue state)) - -(define (next state n) - "Tell the debugged program to do @var{n} more steps from its current -position, but only counting frame entries and exits where the -corresponding source code comes from the same file as the current -stack frame. (See @ref{Step Traps} for the details of how this -works.) If the current stack frame has no source code, the effect of -this command is the same as of @code{step}. @var{n} defaults to 1." - (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)))) - (continue state)) - -;;; (ice-9 debugger commands) ends here. diff --git a/module/ice-9/debugger/state.scm b/module/ice-9/debugger/state.scm deleted file mode 100644 index 0bda0fad5..000000000 --- a/module/ice-9/debugger/state.scm +++ /dev/null @@ -1,47 +0,0 @@ -;;;; (ice-9 debugger state) -- debugger state representation - -;;; Copyright (C) 2002, 2006 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugger state) - #:export (make-state - state-stack - state-index - state-flags - set-stack-index!)) - -(define state-rtd (make-record-type "debugger-state" '(stack index flags))) -(define state? (record-predicate state-rtd)) -(define make-state - (let ((make-state-internal (record-constructor state-rtd - '(stack index flags)))) - (lambda (stack index . flags) - (make-state-internal stack index flags)))) -(define state-stack (record-accessor state-rtd 'stack)) -(define state-index (record-accessor state-rtd 'index)) -(define state-flags (record-accessor state-rtd 'flags)) - -(define set-state-index! (record-modifier state-rtd 'index)) - -(define (set-stack-index! state index) - (let* ((stack (state-stack state)) - (ssize (stack-length stack))) - (set-state-index! state - (cond ((< index 0) 0) - ((>= index ssize) (- ssize 1)) - (else index))))) - -;;; (ice-9 debugger state) ends here. diff --git a/module/ice-9/debugger/trc.scm b/module/ice-9/debugger/trc.scm deleted file mode 100644 index 3e7e2f359..000000000 --- a/module/ice-9/debugger/trc.scm +++ /dev/null @@ -1,63 +0,0 @@ -;;;; (ice-9 debugger trc) -- tracing for Guile debugger code - -;;; Copyright (C) 2002, 2006 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugger 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 debugger trc) ends here. diff --git a/module/ice-9/debugger/utils.scm b/module/ice-9/debugger/utils.scm deleted file mode 100644 index dfef25b1f..000000000 --- a/module/ice-9/debugger/utils.scm +++ /dev/null @@ -1,203 +0,0 @@ - -(define-module (ice-9 debugger utils) - #:use-module (ice-9 debugger state) - #:export (display-position - source-position - write-frame-args-long - write-frame-index-long - write-frame-short/expression - write-frame-short/application - write-frame-long - write-state-long - write-state-short)) - -;;; Procedures in this module print information about a stack frame. -;;; The available information is as follows. -;;; -;;; * Source code location. -;;; -;;; For an evaluation frame, this is the location recorded at the time -;;; that the expression being evaluated was read, if the 'positions -;;; read option was enabled at that time. -;;; -;;; For an application frame, I'm not yet sure. Some applications -;;; seem to have associated source expressions. -;;; -;;; * Whether frame is still evaluating its arguments. -;;; -;;; Only applies to an application frame. For example, an expression -;;; like `(+ (* 2 3) 4)' goes through the following stages of -;;; evaluation. -;;; -;;; (+ (* 2 3) 4) -- evaluation -;;; [+ ... -- application; the car of the evaluation -;;; has been evaluated and found to be a -;;; procedure; before this procedure can -;;; be applied, its arguments must be evaluated -;;; [+ 6 ... -- same application after evaluating the -;;; first argument -;;; [+ 6 4] -- same application after evaluating all -;;; arguments -;;; 10 -- result -;;; -;;; * Whether frame is real or tail-recursive. -;;; -;;; If a frame is tail-recursive, its containing frame as shown by the -;;; debugger backtrace doesn't really exist as far as the Guile -;;; evaluator is concerned. The effect of this is that when a -;;; tail-recursive frame returns, it looks as though its containing -;;; frame returns at the same time. (And if the containing frame is -;;; also tail-recursive, _its_ containing frame returns at that time -;;; also, and so on ...) -;;; -;;; A `real' frame is one that is not tail-recursive. - - -(define (write-state-short 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))) - -(define (write-state-short* stack index) - (write-frame-index-short stack index) - (write-char #\space) - (write-frame-short (stack-ref stack index)) - (newline)) - -(define (write-frame-index-short stack index) - (let ((s (number->string (frame-number (stack-ref stack index))))) - (display s) - (write-char #\:) - (write-chars #\space (- 4 (string-length s))))) - -(define (write-frame-short frame) - (if (frame-procedure? frame) - (write-frame-short/application frame) - (write-frame-short/expression frame))) - -(define (write-frame-short/application frame) - (write-char #\[) - (write (let ((procedure (frame-procedure frame))) - (or (and (procedure? procedure) - (procedure-name procedure)) - procedure))) - (if (frame-evaluating-args? frame) - (display " ...") - (begin - (for-each (lambda (argument) - (write-char #\space) - (write argument)) - (frame-arguments frame)) - (write-char #\])))) - -;;; Use builtin function instead: -(set! write-frame-short/application - (lambda (frame) - (display-application frame (current-output-port) 12))) - -(define (write-frame-short/expression frame) - (write (let* ((source (frame-source frame)) - (copy (source-property source 'copy))) - (if (pair? copy) - copy - (unmemoize-expr source))))) - -(define (write-state-long state) - (let ((index (state-index state))) - (let ((frame (stack-ref (state-stack state) index))) - (write-frame-index-long frame) - (write-frame-long frame)))) - -(define (write-frame-index-long frame) - (display "Stack frame: ") - (write (frame-number frame)) - (if (frame-real? frame) - (display " (real)")) - (newline)) - -(define (write-frame-long frame) - (if (frame-procedure? frame) - (write-frame-long/application frame) - (write-frame-long/expression frame))) - -(define (write-frame-long/application frame) - (display "This frame is an application.") - (newline) - (if (frame-source frame) - (begin - (display "The corresponding expression is:") - (newline) - (display-source frame) - (newline))) - (display "The procedure being applied is: ") - (write (let ((procedure (frame-procedure frame))) - (or (and (procedure? procedure) - (procedure-name procedure)) - procedure))) - (newline) - (display "The procedure's arguments are") - (if (frame-evaluating-args? frame) - (display " being evaluated.") - (begin - (display ": ") - (write (frame-arguments frame)))) - (newline)) - -(define (display-source frame) - (let* ((source (frame-source frame)) - (copy (source-property source 'copy))) - (cond ((source-position source) - => (lambda (p) (display-position p) (display ":\n")))) - (display " ") - (write (or copy (unmemoize-expr source))))) - -(define (source-position source) - (let ((fname (source-property source 'filename)) - (line (source-property source 'line)) - (column (source-property source 'column))) - (and fname - (list fname line column)))) - -(define (display-position pos) - (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos)))) - -(define (write-frame-long/expression frame) - (display "This frame is an evaluation.") - (newline) - (display "The expression being evaluated is:") - (newline) - (display-source frame) - (newline)) - -(define (write-frame-args-long frame) - (if (frame-procedure? frame) - (let ((arguments (frame-arguments frame))) - (let ((n (length arguments))) - (display "This frame has ") - (write n) - (display " argument") - (if (not (= n 1)) - (display "s")) - (write-char (if (null? arguments) #\. #\:)) - (newline)) - (for-each (lambda (argument) - (display " ") - (write argument) - (newline)) - arguments)) - (begin - (display "This frame is an evaluation frame; it has no arguments.") - (newline)))) - -(define (write-chars char n) - (do ((i 0 (+ i 1))) - ((>= i n)) - (write-char char))) diff --git a/module/ice-9/debugging/breakpoints.scm b/module/ice-9/debugging/breakpoints.scm deleted file mode 100644 index 7293c8e66..000000000 --- a/module/ice-9/debugging/breakpoints.scm +++ /dev/null @@ -1,414 +0,0 @@ -;;;; (ice-9 debugging breakpoints) -- practical breakpoints - -;;; Copyright (C) 2005, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 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. diff --git a/module/ice-9/debugging/example-fns.scm b/module/ice-9/debugging/example-fns.scm deleted file mode 100644 index 30d412f00..000000000 --- a/module/ice-9/debugging/example-fns.scm +++ /dev/null @@ -1,17 +0,0 @@ -(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/module/ice-9/debugging/ice-9-debugger-extensions.scm b/module/ice-9/debugging/ice-9-debugger-extensions.scm deleted file mode 100644 index e69de29bb..000000000 --- a/module/ice-9/debugging/ice-9-debugger-extensions.scm +++ /dev/null diff --git a/module/ice-9/debugging/load-hooks.scm b/module/ice-9/debugging/load-hooks.scm deleted file mode 100644 index fb869ed23..000000000 --- a/module/ice-9/debugging/load-hooks.scm +++ /dev/null @@ -1,33 +0,0 @@ - -(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/module/ice-9/debugging/steps.scm b/module/ice-9/debugging/steps.scm deleted file mode 100644 index cd328bd7d..000000000 --- a/module/ice-9/debugging/steps.scm +++ /dev/null @@ -1,106 +0,0 @@ -;;;; (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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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. diff --git a/module/ice-9/debugging/trace.scm b/module/ice-9/debugging/trace.scm deleted file mode 100644 index c8d24d09e..000000000 --- a/module/ice-9/debugging/trace.scm +++ /dev/null @@ -1,153 +0,0 @@ -;;;; (ice-9 debugging trace) -- breakpoint trace behaviour - -;;; Copyright (C) 2002, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugging trace) - #:use-module (ice-9 debugger) - #:use-module (ice-9 debugger utils) - #: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)) - -(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. diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm deleted file mode 100755 index 5557cb3ea..000000000 --- a/module/ice-9/debugging/traps.scm +++ /dev/null @@ -1,1011 +0,0 @@ -;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface - -;;; Copyright (C) 2002, 2004, 2009, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 (ice-9 weak-vector) - #:use-module (ice-9 scm-style-repl) - #: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 <trap> subclasses defined in - ;; this module. - add-trapped-stack-id! - remove-trapped-stack-id! - <procedure-trap> - <exit-trap> - <entry-trap> - <apply-trap> - <step-trap> - <source-trap> - <location-trap> - install-trap - uninstall-trap - all-traps - get-trap - list-traps - trap-ordering - behaviour-ordering - throw->trap-context - on-pre-unwind-handler-dispatch - ;; Interface for authors of new <trap> subclasses. - <trap-context> - <trap> - 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) - ;; FIXME: see below - ;; #: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) - -;;; 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 <trap-context> () - ;; 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 <trap-context>)) - (or (slot-ref ctx 'stack) - (let ((stack (make-stack (tc:continuation ctx)))) - (slot-set! ctx 'stack stack) - stack))) - -(define-method (tc:frame (ctx <trap-context>)) - (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 <trap-context>)) - (or (slot-ref ctx 'depth) - (let ((depth (stack-length (tc:stack ctx)))) - (slot-set! ctx 'depth depth) - depth))) - -(define-method (tc:real-depth (ctx <trap-context>)) - (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 <trap-context>)) - (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 <trap-context> - #: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 <trap-context> - #: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 <trap-context> - #: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 catch whose pre-unwind handler is -;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in -;;; turn calls default-pre-unwind-handler. So we can present most errors -;;; as pseudo-traps by modifying default-pre-unwind-handler. - -(define default-default-pre-unwind-handler default-pre-unwind-handler) - -(define (throw->trap-context key args . stack-args) - (let ((ctx (make <trap-context> - #: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-pre-unwind-handler-dispatch behaviour . ignored-keys) - (set! default-pre-unwind-handler - (if behaviour - (lambda (key . args) - (or (memq key ignored-keys) - (behaviour (throw->trap-context key - args - default-pre-unwind-handler))) - (apply default-default-pre-unwind-handler key args)) - default-default-pre-unwind-handler))) - -;;; {Trap Classes} - -;;; Class: <trap> -;;; -;;; <trap> is the base class for traps. Any actual trap should be an -;;; instance of a class derived from <trap>, not of <trap> itself, -;;; because there is no base class method for the install-trap, -;;; trap-runnable? and uninstall-trap GFs. -(define-class <trap> () - ;; "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 <trap> - ;; 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 <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 <trap> -(define-generic trap-runnable?) ; provided by subclasses - -(define-method (install-trap (trap <trap>)) - (if (slot-ref trap 'installed) - (error "Trap is already installed")) - (slot-set! trap 'installed #t)) - -(define-method (uninstall-trap (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>) (trap-context <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: <procedure-trap> -;;; -;;; An installed instance of <procedure-trap> triggers on invocation -;;; of a specific procedure. -(define-class <procedure-trap> (<trap>) - ;; "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 <procedure-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 <procedure-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 <procedure-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 <procedure-trap>) - (trap-context <trap-context>)) - (eq? (slot-ref trap 'procedure) - (frame-procedure (tc:frame trap-context)))) - -;;; Class: <exit-trap> -;;; -;;; An installed instance of <exit-trap> triggers on stack frame exit -;;; past a specified stack depth. -(define-class <exit-trap> (<trap>) - ;; "depth" slot: the reference depth for the trap. - (depth #:init-keyword #:depth)) - -(define-method (install-trap (trap <exit-trap>)) - (next-method) - (install-exit-frame-trap trap)) - -(define-method (uninstall-trap (trap <exit-trap>)) - (next-method) - (uninstall-exit-frame-trap trap)) - -(define-method (trap-runnable? (trap <exit-trap>) - (trap-context <trap-context>)) - (<= (tc:exit-depth trap-context) - (slot-ref trap 'depth))) - -;;; Class: <entry-trap> -;;; -;;; An installed instance of <entry-trap> triggers on any frame entry. -(define-class <entry-trap> (<trap>)) - -(define-method (install-trap (trap <entry-trap>)) - (next-method) - (install-enter-frame-trap trap)) - -(define-method (uninstall-trap (trap <entry-trap>)) - (next-method) - (uninstall-enter-frame-trap trap)) - -(define-method (trap-runnable? (trap <entry-trap>) - (trap-context <trap-context>)) - #t) - -;;; Class: <apply-trap> -;;; -;;; An installed instance of <apply-trap> triggers on any procedure -;;; application. -(define-class <apply-trap> (<trap>)) - -(define-method (install-trap (trap <apply-trap>)) - (next-method) - (install-apply-frame-trap trap)) - -(define-method (uninstall-trap (trap <apply-trap>)) - (next-method) - (uninstall-apply-frame-trap trap)) - -(define-method (trap-runnable? (trap <apply-trap>) - (trap-context <trap-context>)) - #t) - -;;; Class: <step-trap> -;;; -;;; An installed instance of <step-trap> triggers on the next frame -;;; entry, exit or application, optionally with source location inside -;;; a specified file. -(define-class <step-trap> (<exit-trap>) - ;; "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 <step-trap>) initargs) - (next-method) - (slot-set! trap 'depth (slot-ref trap 'exit-depth))) - -(define-method (install-trap (trap <step-trap>)) - (next-method) - (install-enter-frame-trap trap) - (install-apply-frame-trap trap)) - -(define-method (uninstall-trap (trap <step-trap>)) - (next-method) - (uninstall-enter-frame-trap trap) - (uninstall-apply-frame-trap trap)) - -(define-method (trap-runnable? (trap <step-trap>) - (trap-context <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: <source-trap> -;;; -;;; An installed instance of <source-trap> triggers upon evaluation of -;;; a specified source expression. -(define-class <source-trap> (<trap>) - ;; "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 <source-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 <source-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 <source-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 <source-trap>) - (trap-context <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) -;; FIXME: no longer working due to no mmacros, no local-eval -#; -(define trap-here - (procedure->memoizing-macro - (lambda (expr env) - (let ((trap (apply make - <source-trap> - #:expression expr - (local-eval `(list ,@(cddr expr)) - env)))) - (install-trap trap) - (set-car! expr 'begin) - (set-cdr! (cdr expr) '()) - expr)))) - -;;; Class: <location-trap> -;;; -;;; An installed instance of <location-trap> triggers on entry to a -;;; frame with a more-or-less precisely specified source location. -(define-class <location-trap> (<trap>) - ;; "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 <location-trap>) initargs) - (next-method) - (slot-set! trap 'compiled-regexp - (make-regexp (slot-ref trap 'file-regexp)))) - -(define-method (install-trap (trap <location-trap>)) - (next-method) - (install-enter-frame-trap trap)) - -(define-method (uninstall-trap (trap <location-trap>)) - (next-method) - (uninstall-enter-frame-trap trap)) - -(define-method (trap-runnable? (trap <location-trap>) - (trap-context <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 '(tweaking)) - -;; Make sure that traps are enabled. -(trap-enable 'traps) - -;;; (ice-9 debugging traps) ends here. diff --git a/module/ice-9/debugging/trc.scm b/module/ice-9/debugging/trc.scm deleted file mode 100644 index face227d6..000000000 --- a/module/ice-9/debugging/trc.scm +++ /dev/null @@ -1,63 +0,0 @@ -;;;; (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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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. |