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 \
+++ /dev/null
-;;;; 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.
+++ /dev/null
-;;;; 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))
-\f
-;;;; 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)))))
-\f
-;;;; 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))
-\f
-(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)))))
-\f
-;;;; 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)))
-\f
-(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))))
-\f
-;;;; 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))
-\f
-;;;; 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))))
-\f
-;;;; 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)
-\f
-(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)
+++ /dev/null
-;;;; (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.
+++ /dev/null
-;;;; (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.
+++ /dev/null
-;;;; (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.
+++ /dev/null
-
-(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)))))
-\f
-(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)))
+++ /dev/null
-;;;; (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.
+++ /dev/null
-(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)
+++ /dev/null
-
-(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))
+++ /dev/null
-;;;; (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.
+++ /dev/null
-;;;; (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.
+++ /dev/null
-;;;; (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.
+++ /dev/null
-;;;; (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.
HCoop / bpt / guile.git / commitdiff