mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

remove (ice-9 debugger) and (ice-9 debugging)

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-09-24 18:24:41 +02:00
parent 3b494f511a
commit d2c7e7de40
15 changed files with 0 additions and 3047 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/Makefile.am
View file

@ -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 \

167
module/ice-9/debugger.scm
View file

@ -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.

552
module/ice-9/debugger/command-loop.scm
View file

@ -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)

208
module/ice-9/debugger/commands.scm
View file

@ -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.

47
module/ice-9/debugger/state.scm
View file

@ -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.

63
module/ice-9/debugger/trc.scm
View file

@ -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.

203
module/ice-9/debugger/utils.scm
View file

@ -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)))

414
module/ice-9/debugging/breakpoints.scm
View file

@ -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.

17
module/ice-9/debugging/example-fns.scm
View file

@ -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)

0
module/ice-9/debugging/ice-9-debugger-extensions.scm
View file

33
module/ice-9/debugging/load-hooks.scm
View file

@ -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))

106
module/ice-9/debugging/steps.scm
View file

@ -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.

153
module/ice-9/debugging/trace.scm
View file

@ -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.

1011
module/ice-9/debugging/traps.scm
View file

File diff suppressed because it is too large Load diff

63
module/ice-9/debugging/trc.scm
View file

@ -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.