mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

The FSF has a new address.

Browse source
This commit is contained in:
Marius Vollmer 2005-05-23 19:57:22 +00:00
parent 5ae1bd9109
commit 92205699d0
506 changed files with 642 additions and 4585 deletions
Download patch file Download diff file Expand all files Collapse all files

4
Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = 1.5

4
am/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

4
am/maintainer-dirs
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
## Commentary:

4
am/pre-inst-guile
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
## Commentary:

4
benchmark-suite/guile-benchmark
View file

@ -19,8 +19,8 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; Usage: [guile -e main -s] guile-benchmark [OPTIONS] [BENCHMARK ...]

4
benchmark-suite/lib.scm
View file

@ -13,8 +13,8 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
(define-module (benchmark-suite lib)
:export (

4
configure.in
View file

@ -20,8 +20,8 @@ General Public License for more details.
You should have received a copy of the GNU General Public License
along with GUILE; see the file COPYING. If not, write to the
Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.
]])

4
doc/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

4
doc/example-smob/image-type.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*/
#include <stdlib.h>

4
doc/example-smob/myguile.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*/
#include <libguile.h>

4
doc/goops/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

4
doc/groupings.alist
View file

@ -14,8 +14,8 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA
;;; Commentary:

4
doc/maint/docstring.el
View file

@ -16,8 +16,8 @@
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Emacs; see the file COPYING. If not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307, USA.
;;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02110-1301, USA.
;;; Commentary:

4
doc/oldfmt.c
View file

@ -12,8 +12,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.

4
doc/r5rs/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

4
doc/ref/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

2
doc/ref/fdl.texi
View file

@ -7,7 +7,7 @@
@display
Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.

4
doc/tutorial/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

38
emacs/Makefile.am
View file

@ -1,38 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2003, 2004 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
AUTOMAKE_OPTIONS = gnu
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/emacs
subpkgdata_DATA = gds-client.scm gds-server.scm
lisp_LISP = gds.el
# Suppress byte compilation for now, but only because I haven't tested
# it yet, so have no idea whether a byte compiled version would work.
ELCFILES =
info_TEXINFOS = gds.texi
TEXINFO_TEX = ../doc/ref/texinfo.tex
TAGS_FILES = $(subpkgdata_DATA) $(lisp_LISP)
EXTRA_DIST = $(subpkgdata_DATA) $(lisp_LISP) gds-tutorial.txt gds-problems.txt

726
emacs/gds-client.scm
View file

@ -1,726 +0,0 @@
;;;; Guile Debugger UI client
;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (emacs gds-client)
#:use-module (ice-9 debugger)
#:use-module (ice-9 debugger behaviour)
#:use-module (ice-9 debugger breakpoints)
#:use-module (ice-9 debugger breakpoints procedural)
#:use-module (ice-9 debugger breakpoints source)
#:use-module (ice-9 debugger state)
#:use-module (ice-9 debugger trap-hooks)
#:use-module (ice-9 debugger utils)
#:use-module (ice-9 optargs)
#:use-module (ice-9 regex)
#:use-module (ice-9 session)
#:use-module (ice-9 string-fun)
#:use-module (ice-9 threads)
#:export (gds-port-number
gds-connected?
gds-connect
gds-command-loop
gds-server-died-hook)
#:no-backtrace)
;;;; {Internal Tracing and Debugging}
;; Some of this module's thread and mutex code is quite tricky and
;; includes `trc' statements to trace out useful information if the
;; environment variable GDS_TRC is defined.
(define trc
(if (getenv "GDS_TRC")
(let ((port (open-output-file "/home/neil/gds-client.log"))
(trc-mutex (make-mutex)))
(lambda args
(with-mutex trc-mutex
(write args port)
(newline port)
(force-output port))))
noop))
(define-macro (assert expr)
`(or ,expr
(error "Assertion failed" expr)))
;;;; {TCP Connection}
;; Communication between this module (running in the application being
;; debugged) and the GDS server and UI code (running in/under Emacs)
;; is through a TCP connection. `gds-port-number' is the TCP port
;; number where the server listens for application connections.
(define gds-port-number 8333)
;; Once connected, the TCP socket port to the server.
(define gds-port #f)
;; Public procedure to discover whether there is a GDS connection yet.
(define (gds-connected?)
"Return @code{#t} if a UI server connected has been made; else @code{#f}."
(not (not gds-port)))
;; Public procedure to create the connection to the GDS server.
(define* (gds-connect name #:optional host)
"Connect to the GDS server as @var{name}, a string that should be
sufficient to describe the calling application to the GDS frontend
user. The optional @var{host} arg specifies the hostname or dotted
decimal IP address where the UI server is running; default is
127.0.0.1."
(if (gds-connected?)
(error "Already connected to UI server!"))
;; Connect to debug server.
(set! gds-port
(let ((s (socket PF_INET SOCK_STREAM 0))
(SOL_TCP 6)
(TCP_NODELAY 1))
(setsockopt s SOL_TCP TCP_NODELAY 1)
(connect s AF_INET (inet-aton (or host "127.0.0.1")) gds-port-number)
s))
;; Set debugger-output-port so that messages written to it are not
;; displayed on the application's stdout, but instead accumulated
;; for sending to the GDS frontend.
(set! (debugger-output-port)
(make-soft-port (vector accumulate-output
accumulate-output
#f #f #f #f)
"w"))
;; Announce ourselves to the server.
(write-form (list 'name name (getpid)))
(add-trapped-stack-id! 'gds-eval-stack)
;; Start the UI read thread.
(set! ui-read-thread (make-thread ui-read-thread-proc)))
(define accumulated-output '())
(define (accumulate-output obj)
(set! accumulated-output
(cons (if (string? obj) obj (make-string 1 obj))
accumulated-output)))
(define (get-accumulated-output)
(let ((s (apply string-append (reverse! accumulated-output))))
(set! accumulated-output '())
s))
;;;; {UI Read Thread}
;; Except when the application enters the debugger, communication with
;; the GDS server and frontend is managed by a dedicated thread for
;; this purpose. This design avoids having to modify application code
;; at the expense of requiring a Guile with threads support.
(define (ui-read-thread-proc)
(write-status 'running)
(let ((eval-thread-needed? #t))
;; Start up the default eval thread.
(make-thread eval-thread 1 (lambda () (not eval-thread-needed?)))
(with-mutex ui-read-mutex
(catch 'server-died
;; Protected thunk: loop reading either protocol input from
;; the server, or an indication (through ui-read-switch-pipe)
;; that a thread in the debugger wants to take over the
;; interaction with the server.
(lambda ()
(let loop ((avail '()))
(write-note 'startloop)
(cond ((not gds-port)) ; exit loop
((null? avail)
(write-status 'ready-for-input)
(loop (without-mutex ui-read-mutex
(car (select (list gds-port
(car ui-read-switch-pipe))
'() '())))))
(else
(write-note 'sthg-to-read)
(let ((port (car avail)))
(if (eq? port gds-port)
(handle-instruction #f (read gds-port))
(begin
(write-note 'debugger-takeover)
;; Notification from debugger that it wants
;; to take over. Read the notification
;; char.
(read-char (car ui-read-switch-pipe))
;; Wait on ui-read-switch variable - this
;; allows the debugger thread to grab the
;; mutex.
(write-note 'cond-wait)
(signal-condition-variable ui-read-switch)
(wait-condition-variable ui-read-switch
ui-read-mutex)))
;; Loop.
(loop '()))))
(write-note 'loopexited)))
;; Catch handler.
(lambda args #f)))
;; Tell the eval thread that it can exit.
(with-mutex eval-work-mutex
(set! eval-thread-needed? #f)
(broadcast-condition-variable eval-work-changed))))
;; It's useful to keep a note of the UI thread's id.
(define ui-read-thread #f)
;; Mutex used to control which thread is currently reading the TCP
;; connection to the server/UI.
(define ui-read-mutex (make-mutex))
;; Condition variable used by threads interested in reading the TCP
;; connection to signal changes in their state.
(define ui-read-switch (make-condition-variable))
;; Pipe used by application threads that enter the debugger to tell
;; the UI read thread that they'd like to take over reading the TCP
;; connection.
(define ui-read-switch-pipe (pipe))
;;;; {Debugger Integration}
;; When a thread enters the Guile debugger and a GDS connection is
;; present, the debugger calls `gds-command-loop' instead of entering
;; its usual command loop.
(define (gds-command-loop state)
"Interact with the UI frontend."
(or (gds-connected?)
(error "Not connected to UI server."))
;; Take over server/UI interaction from the normal UI read thread.
(with-mutex ui-read-mutex
(write-char #\x (cdr ui-read-switch-pipe))
(force-output (cdr ui-read-switch-pipe))
(write-note 'char-written)
(wait-condition-variable ui-read-switch ui-read-mutex)
;; We now "have the com", as they say on Star Trek.
(catch #t ; Only expect here 'exit-debugger or 'server-died.
(lambda ()
(let loop ((state state))
;; Write accumulated debugger output.
(write-form (list 'output (sans-surrounding-whitespace
(get-accumulated-output))))
;; Write current state to the frontend.
(if state (write-stack state))
;; Tell the frontend that we're waiting for input.
(write-status 'waiting-for-input)
;; Read next instruction, act on it, and loop with updated
;; state.
(loop (handle-instruction state (read gds-port)))))
(lambda args *unspecified*))
(write-note 'cond-signal)
;; Tell the UI read thread that it can take control again.
(signal-condition-variable ui-read-switch)))
;;;; {General Output to Server/UI}
(define write-form
(let ((protocol-mutex (make-mutex)))
(lambda (form)
;; Write any form FORM to UI frontend.
(with-mutex protocol-mutex
(write form gds-port)
(newline gds-port)
(force-output gds-port)))))
(define (write-note note)
;; Write a note (for debugging this code) to UI frontend.
(false-if-exception (write-form `(note ,note))))
(define (write-status status)
(write-form (list 'current-module
(format #f "~S" (module-name (current-module)))))
(write-form (list 'status status)))
;;;; {Stack Output to Server/UI}
(define (write-stack state)
;; Write Emacs-readable representation of current state to UI
;; frontend.
(let ((frames (stack->emacs-readable (state-stack state)))
(index (index->emacs-readable (state-index state)))
(flags (flags->emacs-readable (state-flags state))))
(if (memq 'backwards (debug-options))
(write-form (list 'stack
frames
index
flags))
;; Calculate (length frames) here because `reverse!' will make
;; the original `frames' invalid.
(let ((nframes (length frames)))
(write-form (list 'stack
(reverse! frames)
(- nframes index 1)
flags))))))
(define (stack->emacs-readable stack)
;; Return Emacs-readable representation of STACK.
(map (lambda (index)
(frame->emacs-readable (stack-ref stack index)))
(iota (min (stack-length stack)
(cadr (memq 'depth (debug-options)))))))
(define (frame->emacs-readable frame)
;; Return Emacs-readable representation of FRAME.
(if (frame-procedure? frame)
(list 'application
(with-output-to-string
(lambda ()
(display (if (frame-real? frame) " " "t "))
(write-frame-short/application frame)))
(source->emacs-readable (or (frame-source frame)
(let ((proc (frame-procedure frame)))
(and proc
(procedure-source proc))))))
(list 'evaluation
(with-output-to-string
(lambda ()
(display (if (frame-real? frame) " " "t "))
(write-frame-short/expression frame)))
(source->emacs-readable (frame-source frame)))))
(define (source->emacs-readable source)
;; Return Emacs-readable representation of the filename, line and
;; column source properties of SOURCE.
(if (and source
(string? (source-property source 'filename)))
(list (source-property source 'filename)
(source-property source 'line)
(source-property source 'column))
'nil))
(define (index->emacs-readable index)
;; Return Emacs-readable representation of INDEX (the current stack
;; index).
index)
(define (flags->emacs-readable flags)
;; Return Emacs-readable representation of FLAGS passed to
;; debug-stack.
(map (lambda (flag)
(if (keyword? flag)
(keyword->symbol flag)
(format #f "~S" flag)))
flags))
;;;; {Handling GDS Protocol Instructions}
;; Instructions from the server/UI always come through here. If
;; `state' is non-#f, we are in the debugger; otherwise, not.
(define (handle-instruction state ins)
(if (eof-object? ins)
(server-died)
(catch #t
(lambda ()
(lazy-catch #t
(lambda ()
(handle-instruction-1 state ins))
(lambda (key . args)
(set! internal-error-stack (make-stack #t))
(apply throw key args))))
(lambda (key . args)
(case key
((exit-debugger)
(apply throw key args))
(else
(write-form
`(eval-results (error . "")
"GDS Internal Error\n"
,(list (with-output-to-string
(lambda ()
(write key)
(display ": ")
(write args)
(newline)
(display-backtrace internal-error-stack
(current-output-port)))))))))
state))))
(define (server-died)
(get-accumulated-output)
(close-port gds-port)
(set! gds-port #f)
(run-hook gds-server-died-hook)
(throw 'server-died))
(define internal-error-stack #f)
(define gds-server-died-hook (make-hook))
(define (handle-instruction-1 state ins)
;; Read the newline that always follows an instruction.
(read-char gds-port)
;; Handle instruction from the UI frontend, and return updated state.
(case (car ins)
((query-modules)
(write-form (cons 'modules (map module-name (loaded-modules))))
state)
((query-module)
(let ((name (cadr ins)))
(write-form `(module ,name
,(or (loaded-module-source name) "(no source file)")
,@(sort (module-map (lambda (key value)
(symbol->string key))
(resolve-module-from-root name))
string<?))))
state)
((debugger-command)
(or state (error "Not currently in debugger!"))
(write-status 'running)
(let ((name (cadr ins))
(args (cddr ins)))
(let ((proc (module-ref the-ice-9-debugger-commands-module name)))
(if proc
(apply proc state args)
(throw 'internal-error proc name args))))
state)
((set-breakpoint)
(set-breakpoint! (case (cadddr ins)
((debug-here) debug-here)
((trace-here) trace-here)
((trace-subtree) trace-subtree)
(else
(lambda ()
(display "Don't know `")
(display (cadddr ins))
(display "' behaviour; doing `debug-here' instead.\n")
(debug-here))))
(module-ref (resolve-module-from-root (cadr ins)) (caddr ins)))
state)
((eval)
(apply (lambda (correlator module port-name line column bpinfo code)
(with-input-from-string code
(lambda ()
(set-port-filename! (current-input-port) port-name)
(set-port-line! (current-input-port) line)
(set-port-column! (current-input-port) column)
(let ((m (and module (resolve-module-from-root module))))
(catch 'read-error
(lambda ()
(let loop ((exprs '()) (x (read)))
(if (eof-object? x)
;; Expressions to be evaluated have all
;; been read. Now hand them off to an
;; eval-thread for the actual
;; evaluation.
(with-mutex eval-work-mutex
(trc 'protocol-thread
"evaluation work available")
(set! eval-work
(cons* correlator m (reverse! exprs)))
(set! eval-work-available #t)
(broadcast-condition-variable eval-work-changed)
(wait-condition-variable eval-work-taken
eval-work-mutex)
(assert (not eval-work-available))
(trc 'protocol-thread
"evaluation work underway"))
;; Another complete expression read.
;; Set breakpoints in the read code as
;; specified by bpinfo, and add it to
;; the list.
(begin
(install-breakpoints x bpinfo)
(loop (cons x exprs) (read))))))
(lambda (key . args)
(write-form `(eval-results
,correlator
,(with-output-to-string
(lambda ()
(display ";;; Reading expressions")
(display " to evaluate\n")
(apply display-error #f
(current-output-port) args)))
("error-in-read")))))))))
(cdr ins))
state)
((complete)
(let ((matches (apropos-internal
(string-append "^" (regexp-quote (cadr ins))))))
(cond ((null? matches)
(write-form '(completion-result nil)))
(else
;;(write matches (current-error-port))
;;(newline (current-error-port))
(let ((match
(let loop ((match (symbol->string (car matches)))
(matches (cdr matches)))
;;(write match (current-error-port))
;;(newline (current-error-port))
;;(write matches (current-error-port))
;;(newline (current-error-port))
(if (null? matches)
match
(if (string-prefix=? match
(symbol->string (car matches)))
(loop match (cdr matches))
(loop (substring match 0
(- (string-length match) 1))
matches))))))
(if (string=? match (cadr ins))
(write-form `(completion-result
,(map symbol->string matches)))
(write-form `(completion-result
,match)))))))
state)
((async-break)
(let ((thread (car (delq ui-read-thread (all-threads)))))
(write (cons 'target-thread thread))
(newline)
(write (cons 'ui-read-thread ui-read-thread))
(newline)
(system-async-mark (lambda ()
(debug-stack (make-stack #t 3) #:continuable))
thread))
state)
((interrupt-eval)
(let ((thread (hash-ref eval-thread-table (cadr ins))))
(system-async-mark (lambda ()
(debug-stack (make-stack #t 3) #:continuable))
thread))
state)
(else state)))
(define the-ice-9-debugger-commands-module
(resolve-module '(ice-9 debugger commands)))
(define (resolve-module-from-root name)
(save-module-excursion
(lambda ()
(set-current-module the-root-module)
(resolve-module name))))
;;;; {Module Browsing}
(define (loaded-module-source module-name)
;; Return the file name that (ice-9 boot-9) probably loaded the
;; named module from. (The `probably' is because `%load-path' might
;; have changed since the module was loaded.)
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
(string-append (symbol->string elt) "/"))
dir-hint-module-name))))
(%search-load-path (in-vicinity dir-hint name))))
(define (loaded-modules)
;; Return list of all loaded modules sorted by name.
(sort (apropos-fold-all (lambda (module acc) (cons module acc)) '())
(lambda (m1 m2)
(symlist<? (module-name m1) (module-name m2)))))
(define (symlist<? l1 l2)
;; Return #t if symbol list L1 is alphabetically less than L2.
(cond ((null? l1) #t)
((null? l2) #f)
((eq? (car l1) (car l2)) (symlist<? (cdr l1) (cdr l2)))
(else (string<? (symbol->string (car l1)) (symbol->string (car l2))))))
;;;; {Source Breakpoint Installation}
(define (install-breakpoints x bpinfo)
(define (install-recursive x)
(if (and (list? x) (not (null? x)))
(begin
;; Check source properties of x itself.
(let* ((infokey (cons (source-property x 'line)
(source-property x 'column)))
(bpentry (assoc infokey bpinfo)))
(if bpentry
(let ((bp (set-breakpoint! debug-here x x)))
;; FIXME: Here should transfer properties from the
;; old breakpoint with index (cdr bpentry) to the
;; new breakpoint. (Or else provide an alternative
;; to set-breakpoint! that reuses the same
;; breakpoint.)
(write-form (list 'breakpoint-set
(source-property x 'filename)
(car infokey)
(cdr infokey)
(bp-number bp))))))
;; Check each of x's elements.
(for-each install-recursive x))))
(install-recursive x))
;;;; {Evaluation}
;; Evaluation threads are unleashed by two possible triggers. One is
;; a boolean variable, specific to each thread, that tells the thread
;; to exit when set to #t. The other is another boolean variable, but
;; global, indicating that there is an evaluation to perform:
(define eval-work-available #f)
;; This variable, which is only valid when `eval-work-available' is
;; #t, holds the evaluation to perform:
(define eval-work #f)
;; A mutex protects against concurrent access to these variables.
(define eval-work-mutex (make-mutex))
;; Changes in these variables are signaled by broadcasting the
;; following condition variable.
(define eval-work-changed (make-condition-variable))
;; When an evaluation thread takes some work, it tells the main GDS
;; thread by signaling this condition variable.
(define eval-work-taken (make-condition-variable))
(define-macro (without-mutex m . body)
`(dynamic-wind
(lambda () (unlock-mutex ,m))
(lambda () (begin ,@body))
(lambda () (lock-mutex ,m))))
(define next-thread-number
(let ((count 0))
(lambda ()
(set! count (+ count 1))
count)))
(define eval-thread-table (make-hash-table 3))
(define (eval-thread depth thread-should-exit-thunk)
;; Acquire mutex to check trigger variables.
(with-mutex eval-work-mutex
(let ((thread-number (next-thread-number)))
;; Add this thread to global hash, so we can correlate back to
;; this thread from the ID used by the GDS front end.
(hash-set! eval-thread-table thread-number (current-thread))
(trc 'eval-thread depth thread-number "entering loop")
(let loop ()
;; Tell the front end this thread is ready.
(write-form `(thread-status eval ,thread-number ready))
(cond ((thread-should-exit-thunk)
;; Allow thread to exit.
)
(eval-work-available
;; Take a local copy of the work, reset global
;; variables, then do the work with mutex released.
(trc 'eval-thread depth thread-number "starting work")
(let* ((work eval-work)
(subthread-needed? #t)
(correlator (car work)))
;; Tell the front end this thread is busy.
(write-form `(thread-status eval ,thread-number busy ,correlator))
(set! eval-work-available #f)
(signal-condition-variable eval-work-taken)
(without-mutex eval-work-mutex
;; Before starting evaluation, create another eval
;; thread like this one, so that it can take over
;; if another evaluation is requested before this
;; one is finished.
(make-thread eval-thread (+ depth 1)
(lambda () (not subthread-needed?)))
;; Do the evaluation(s).
(let loop2 ((m (cadr work))
(exprs (cddr work))
(results '())
(n 1))
(if (null? exprs)
(write-form `(eval-results ,correlator ,@results))
(loop2 m
(cdr exprs)
(append results (gds-eval (car exprs) m
(if (and (null? (cdr exprs))
(= n 1))
#f n)))
(+ n 1)))))
(trc 'eval-thread depth thread-number "work done")
;; Tell the subthread that it should now exit.
(set! subthread-needed? #f)
(broadcast-condition-variable eval-work-changed)
;; Loop for more work for this thread.
(loop)))
(else
;; Wait for something to change, then loop to check
;; trigger variables again.
(trc 'eval-thread depth thread-number "wait")
(wait-condition-variable eval-work-changed eval-work-mutex)
(trc 'eval-thread depth thread-number "wait done")
(loop))))
(trc 'eval-thread depth thread-number "exiting")
;; Tell the front end this thread is ready.
(write-form `(thread-status eval ,thread-number exiting)))))
(define (gds-eval x m part)
;; Consumer to accept possibly multiple values and present them for
;; Emacs as a list of strings.
(define (value-consumer . values)
(if (unspecified? (car values))
'()
(map (lambda (value)
(with-output-to-string (lambda () (write value))))
values)))
;; Now do evaluation.
(let ((intro (if part
(format #f ";;; Evaluating subexpression ~A" part)
";;; Evaluating"))
(value #f))
(let* ((do-eval (if m
(lambda ()
(display intro)
(display " in module ")
(write (module-name m))
(newline)
(set! value
(call-with-values (lambda ()
(start-stack 'gds-eval-stack
(eval x m)))
value-consumer)))
(lambda ()
(display intro)
(display " in current module ")
(write (module-name (current-module)))
(newline)
(set! value
(call-with-values (lambda ()
(start-stack 'gds-eval-stack
(primitive-eval x)))
value-consumer)))))
(output
(with-output-to-string
(lambda ()
(catch #t
do-eval
(lambda (key . args)
(case key
((misc-error signal unbound-variable
numerical-overflow)
(apply display-error #f
(current-output-port) args)
(set! value '("error-in-evaluation")))
(else
(display "EXCEPTION: ")
(display key)
(display " ")
(write args)
(newline)
(set! value
'("unhandled-exception-in-evaluation"))))))))))
(list output value))))
;;; (emacs gds-client) ends here.

98
emacs/gds-server.scm
View file

@ -1,98 +0,0 @@
;;;; Guile Debugger UI server
;;; Copyright (C) 2003 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (emacs gds-server)
#:use-module (emacs gds-client)
#:export (run-server))
;; UI is normally via a pipe to Emacs, so make sure to flush output
;; every time we write.
(define (write-to-ui form)
(write form)
(newline)
(force-output))
(define (trc . args)
(write-to-ui (cons '* args)))
(define (with-error->eof proc port)
(catch #t
(lambda () (proc port))
(lambda args the-eof-object)))
(define (run-server . ignored-args)
(let ((server (socket PF_INET SOCK_STREAM 0)))
;; Initialize server socket.
(setsockopt server SOL_SOCKET SO_REUSEADDR 1)
(bind server AF_INET INADDR_ANY gds-port-number)
(listen server 5)
(let loop ((clients '()) (readable-sockets '()))
(define (do-read port)
(cond ((eq? port (current-input-port))
(do-read-from-ui))
((eq? port server)
(accept-new-client))
(else
(do-read-from-client port))))
(define (do-read-from-ui)
(trc "reading from ui")
(let* ((form (with-error->eof read (current-input-port)))
(client (assq-ref (map (lambda (port)
(cons (fileno port) port))
clients)
(car form))))
(with-error->eof read-char (current-input-port))
(if client
(begin
(write (cdr form) client)
(newline client))
(trc "client not found")))
clients)
(define (accept-new-client)
(cons (car (accept server)) clients))
(define (do-read-from-client port)
(trc "reading from client")
(let ((next-char (with-error->eof peek-char port)))
;;(trc 'next-char next-char)
(cond ((eof-object? next-char)
(write-to-ui (list (fileno port) 'closed))
(close port)
(delq port clients))
((char=? next-char #\()
(write-to-ui (cons (fileno port) (with-error->eof read port)))
clients)
(else
(with-error->eof read-char port)
clients))))
;;(trc 'clients clients)
;;(trc 'readable-sockets readable-sockets)
(if (null? readable-sockets)
(loop clients (car (select (cons (current-input-port)
(cons server clients))
'()
'())))
(loop (do-read (car readable-sockets)) (cdr readable-sockets))))))

1626
emacs/gds.el
View file

File diff suppressed because it is too large Load diff

4
emacs/gud-guile.el
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Version: 1

4
emacs/guile-c.el
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:

4
emacs/guile-emacs.scm
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Code:

4
emacs/guile-scheme.el
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:

4
emacs/guile.el
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Code:

4
emacs/multistring.el
View file

@ -16,8 +16,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>

4
emacs/patch.el
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Version: 1

4
emacs/ppexpand.el
View file

@ -16,8 +16,8 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>

4
emacs/update-changelog.el
View file

@ -14,8 +14,8 @@
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:

4
examples/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
SUBDIRS = scripts box box-module box-dynamic box-dynamic-module\
modules safe

4
examples/box-dynamic-module/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README box.c box-module.scm box-mixed.scm check.test

4
examples/box-dynamic-module/box.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*/
/* Include all needed declarations. */

4
examples/box-dynamic/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README box.c check.test

4
examples/box-dynamic/box.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*/
/* Include all needed declarations. */

4
examples/box-module/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README box.c check.test

4
examples/box-module/box.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*/
/* Include all needed declarations. */

4
examples/box/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README box.c check.test

4
examples/box/box.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*/
/* Include all needed declarations. */

4
examples/compat/compat.h
View file

@ -16,8 +16,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.

4
examples/modules/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README module-0.scm module-1.scm module-2.scm main check.test

4
examples/safe/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README safe untrusted.scm evil.scm check.test

4
examples/scripts/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
EXTRA_DIST = README simple-hello.scm hello fact check.test

4
guile-config/Makefile.am
View file

@ -17,8 +17,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
bin_SCRIPTS=guile-config
CLEANFILES=guile-config

2
guile-config/guile-config.in
View file

@ -18,7 +18,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; TODO:
;;; * Add some plausible structure for returning the right exit status,

2
guile-config/guile.m4
View file

@ -14,7 +14,7 @@
##
## You should have received a copy of the GNU Lesser General Public
## License along with this library; if not, write to the Free Software
## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
## Index
## -----

4
guile-config/qthreads.m4
View file

@ -17,8 +17,8 @@ dnl GNU General Public License for more details.
dnl
dnl You should have received a copy of the GNU General Public
dnl License along with GUILE; see the file COPYING. If not, write
dnl to the Free Software Foundation, Inc., 59 Temple Place, Suite
dnl 330, Boston, MA 02111-1307 USA
dnl to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
dnl Floor, Boston, MA 02110-1301 USA

4
guile-readline/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
SUBDIRS = ice-9

4
guile-readline/ice-9/Makefile.am
View file

@ -17,8 +17,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
guile_pdd = $(patsubst %/guile-readline,%/guile,$(pkgdatadir))
ice9dir = $(guile_pdd)/$(GUILE_EFFECTIVE_VERSION)/ice-9

4
guile-readline/ice-9/readline.scm
View file

@ -14,8 +14,8 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;;
;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
;;;; Extensions based upon code by

4
guile-readline/readline.c
View file

@ -14,8 +14,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*
*/

4
guile-readline/readline.h
View file

@ -15,8 +15,8 @@
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA
*
*/

4
guile-tools.in
View file

@ -14,8 +14,8 @@
#
# You should have received a copy of the GNU General Public License
# along with this software; see the file COPYING. If not, write to
# the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
# Boston, MA 02111-1307 USA
# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
# Boston, MA 02110-1301 USA
# Usage: See `help' func below.
#

4
ice-9/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

2
ice-9/and-let-star.scm
View file

@ -15,7 +15,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 and-let-star)
:export-syntax (and-let*))

4
ice-9/arrays.scm
View file

@ -14,8 +14,8 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;;
(define (array-shape a)

2
ice-9/boot-9.scm
View file

@ -15,7 +15,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

2
ice-9/buffered-input.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 buffered-input)
#:export (make-buffered-input-port

2
ice-9/calling.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 calling)

2
ice-9/channel.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:

2
ice-9/common-list.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:

2
ice-9/debug.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN

2
ice-9/debugger.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger)
#:use-module (ice-9 debugger command-loop)

4
ice-9/debugger/Makefile.am
View file

@ -16,8 +16,8 @@
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
## 330, Boston, MA 02111-1307 USA
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu

353
ice-9/debugger/behaviour.scm
View file

@ -1,353 +0,0 @@
;;;; (ice-9 debugger behaviour) -- what to do when you hit a breakpoint
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugger behaviour)
#:use-module (ice-9 and-let-star)
#:use-module (ice-9 debug)
#:use-module (ice-9 debugger)
#:use-module (ice-9 debugger trap-hooks)
#:use-module (ice-9 debugger trc)
#:use-module (ice-9 debugger utils)
#:use-module (ice-9 optargs)
#:export (at-exit
at-entry
at-apply
at-step
at-next
debug-here
trace-here
trace-until-exit
trace-subtree
trace-exit-value
add-debug-entry-message
with-reference-frame
with-reference-frame*))
;;; This module defines useful kinds of behaviour for breakpoints.
(define *trap* #f)
(define *cont* #f)
(define *frame* #f)
(define *depth* #f)
(define *expr* #f)
(define *retval* #f)
(define *trace-retval* #f)
(define *trace-entry* #f)
(define *trace-depths* '())
(define *debug-flag* #f)
(add-hook! before-enter-frame-hook
(lambda (cont tail? expr)
(trc 'before-enter-frame-hook cont tail? expr)
(set! *trap* #:evaluation)
(set! *cont* cont)
(set! *frame* (last-stack-frame cont))
(set! *depth* (stack-length (make-stack cont)))
(set! *expr* expr)
(set! *trace-entry* #t)
(set! *debug-flag* #f)
(set! *debug-entry-messages* '())))
(add-hook! before-apply-frame-hook
(lambda (cont tail?)
(trc 'before-apply-frame-hook cont tail?)
(set! *trap* #:application)
(set! *cont* cont)
(set! *frame* (last-stack-frame cont))
(set! *depth* (stack-length (make-stack cont)))
(set! *expr* #f)
(set! *trace-entry* #t)
(set! *debug-flag* #f)
(set! *debug-entry-messages* '())))
(add-hook! before-exit-frame-hook
(lambda (cont retval)
(trc 'before-exit-frame-hook cont retval)
(set! *trap* #:return)
(set! *cont* cont)
(set! *frame* (last-stack-frame cont))
(set! *depth* (stack-length (make-stack cont)))
(set! *expr* #f)
(set! *retval* retval)
(set! *trace-entry* #f)
(set! *trace-retval* #f)
(set! *debug-flag* #f)
(set! *debug-entry-messages* '())))
(define (debug-if-flag-set)
(if *debug-flag*
(let ((ds-flags (cons #:continuable
(if (eq? *trap* #:return)
(list *trap* *retval*)
(list *trap*)))))
(for-each (lambda (msg)
(display msg (debugger-output-port)))
(reverse! *debug-entry-messages*))
(set! *debug-entry-messages* '())
(apply debug-stack (make-stack *cont*) ds-flags))))
(add-hook! after-enter-frame-hook debug-if-flag-set)
(add-hook! after-apply-frame-hook debug-if-flag-set)
(add-hook! after-exit-frame-hook
(lambda ()
(if *trace-retval*
(with-output-to-port (debugger-output-port)
(lambda ()
(let indent ((td *trace-depths*))
(cond ((null? td))
(else (display "| ")
(indent (cdr td)))))
(display "| ")
(write *retval*)
(newline)
(set! *trace-retval* #f))))
(debug-if-flag-set)))
(define (frame-depth frame)
(- (stack-length (car frame)) (cdr frame)))
(define (with-reference-frame* frame thunk)
(let ((saved-*frame* *frame*)
(saved-*depth* *depth*))
(dynamic-wind
(lambda ()
(set! *frame* frame)
(set! *depth* (frame-depth frame)))
thunk
(lambda ()
(set! *frame* saved-*frame*)
(set! *depth* saved-*depth*)))))
(define-macro (with-reference-frame frame . body)
`(with-reference-frame* ,frame (lambda () ,@body)))
;;; at-exit THUNK
;;;
;;; Install a thunk to run when we exit the current frame.
(define* (at-exit #:optional thunk)
(or thunk (set! thunk debug-here))
(let ((depth *depth*))
(letrec ((exit (lambda ()
(if (<= *depth* depth)
(begin
(remove-exit-frame-hook! exit)
(thunk))))))
(add-exit-frame-hook! exit))))
;;; at-entry [COUNT [THUNK]]
;;;
;;; Install a thunk to run when we get to the COUNT'th next frame
;;; entry. COUNT defaults to 1; THUNK defaults to debug-here.
(define* (at-entry #:optional count thunk)
(or count (set! count 1))
(or thunk (set! thunk debug-here))
(letrec ((enter (lambda ()
(set! count (- count 1))
(if (<= count 0)
(begin
(remove-enter-frame-hook! enter)
(thunk))))))
(add-enter-frame-hook! enter)))
;;; at-apply [COUNT [THUNK]]
;;;
;;; Install a thunk to run when we get to the COUNT'th next
;;; application. COUNT defaults to 1; THUNK defaults to debug-here.
(define* (at-apply #:optional count thunk)
(or count (set! count 1))
(or thunk (set! thunk debug-here))
(letrec ((apply (lambda ()
(set! count (- count 1))
(if (<= count 0)
(begin
(remove-apply-frame-hook! apply)
(thunk))))))
(add-apply-frame-hook! apply)))
;;; at-step [COUNT [THUNK [FILENAME]]]
;;;
;;; Install THUNK to run on the COUNT'th next application, frame entry
;;; or frame exit. COUNT defaults to 1; THUNK defaults to debug-here.
;;; If FILENAME is specified and not #f, only frames that begin in the
;;; named file are counted.
(define* (at-step #:optional count thunk filename)
(or count (set! count 1))
(or thunk (set! thunk debug-here))
(letrec ((proc (lambda ()
;; 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)
(thunk)))))
(step (lambda ()
;; Behaviour on frame entry: both execute the above
;; and install it as an exit hook.
(if (or (not filename)
(equal? (current-file-name) filename))
(begin
(proc)
(at-exit proc))))))
(at-exit proc)
(add-enter-frame-hook! step)
(add-apply-frame-hook! step)))
;;; at-next [COUNT [THUNK]]
;;;
;;; Install a thunk 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; THUNK defaults to debug-here. If the current
;;; location has no filename, fall back silently to `at-entry'
;;; behaviour.
(define (current-file-name)
(and-let* ((source (frame-source *frame*))
(position (source-position source)))
(and position (car position))))
(define* (at-next #:optional count thunk)
(at-step count thunk (current-file-name)))
;;; debug-here
;;;
;;; Set flag to enter the debugger once all behaviour hooks for this
;;; location have been run.
(define (debug-here)
(set! *debug-flag* #t))
;;; trace-here
;;;
;;; Trace the current location, and install a hook to trace the return
;;; value when we exit the current frame.
(define (trace-here)
(if *trace-entry*
(let ((stack (make-stack *cont*))
(push-current-depth #f))
(cond ((null? *trace-depths*)
(set! push-current-depth #t))
(else
(let loop ((frame-number (car *trace-depths*)))
(cond ((>= frame-number *depth*))
((frame-real? (stack-ref stack
(frame-number->index frame-number stack)))
(set! push-current-depth #t))
(else (loop (+ frame-number 1)))))))
(if push-current-depth
(set! *trace-depths* (cons *depth* *trace-depths*)))
(with-output-to-port (debugger-output-port)
(lambda ()
(let indent ((td *trace-depths*))
(cond ((null? td))
(else
(display "| ")
(indent (cdr td)))))
((if *expr*
write-frame-short/expression
write-frame-short/application) *frame*)
(newline)))
(if push-current-depth
(at-exit (lambda ()
(set! *trace-depths* (cdr *trace-depths*))
(set! *trace-retval* #t))))
(set! *trace-entry* #f))))
;;; trace-subtree
;;;
;;; Install hooks to trace everything until exit from the current
;;; frame. Variable lookups are omitted, as they would (usually) just
;;; clog up the trace without conveying any useful information
(define (trace-until-exit)
(let ((trace (lambda ()
(or (variable? *expr*)
(trace-here)))))
(add-enter-frame-hook! trace)
(add-apply-frame-hook! trace)
(at-exit (lambda ()
(remove-enter-frame-hook! trace)
(remove-apply-frame-hook! trace)))))
(define (trace-subtree)
(trace-until-exit)
(trace-here))
;;; trace-exit-value
;;;
;;; Trace the returned value in an exit frame handler.
(define (trace-exit-value)
(set! *trace-retval* #t))
;;; {Debug Entry Messages}
;;;
;;; Messages to be displayed if we decide to enter the debugger.
(define *debug-entry-messages* '())
(define (add-debug-entry-message message)
(set! *debug-entry-messages*
(cons message *debug-entry-messages*)))
;;; {Error Hook Utilities}
;(define (single-instance-installer hook handler)
; (let ((installed? #f))
; (lambda (yes/no?)
; (if (and yes/no? (not installed?))
; (begin
; (add-hook! hook handler)
; (set! installed? #t)))
; (if (and (not yes/no?) installed?)
; (begin
; (remove-hook! hook handler)
; (set! installed? #f))))))
;
;(define-public save-stack-on-error
; (letrec ((handler (lambda (key a b c d)
; (save-stack handler))))
; (single-instance-installer error-hook handler)))
;
;(define-public display-stack-on-error
; (letrec ((handler (lambda (key a b c d)
; (display "DISPLAY-STACK-ON-ERROR: ")
; (write (list key a b c d))
; (newline)
; (display-backtrace (make-stack #t handler)
; (current-error-port)))))
; (single-instance-installer error-hook handler)))
;
;(define-public debug-on-error
; (letrec ((handler (lambda (key a b c d)
; (let ((stack (make-stack #t handler)))
; (display "DEBUG-ON-ERROR: ")
; (write (list key a b c d))
; (newline)
; (display-error stack (current-error-port) a b c d)
; (debug-stack stack)))))
; (single-instance-installer error-hook handler)))
;;; (ice-9 debugger behaviour) ends here.

215
ice-9/debugger/breakpoints.scm
View file

@ -1,215 +0,0 @@
;;;; (ice-9 debugger breakpoints) -- general breakpoints interface
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugger breakpoints)
#:use-module (ice-9 debugger behaviour)
#:use-module (ice-9 format)
#:use-module (oop goops)
#:export (;; For <breakpoint> subclass implementations.
<breakpoint>
register-breakpoint-subclass
;; For application use and subclass implementations.
bp-number
bp-enabled?
bp-behaviour
bp-run
bp-message
bp-delete!
bp-describe
break!
trace!
trace-subtree!
set-breakpoint!
get-breakpoint
describe-breakpoint
disable-breakpoint!
enable-breakpoint!
delete-breakpoint!
all-breakpoints
describe-all-breakpoints))
;;; {Breakpoints -- General Properties and Behaviour}
;;; Generics with names beginning `bp-' all take a single breakpoint
;;; argument (i.e. an instance of a subclass of <breakpoint>).
(define-generic bp-number) ; implemented
(define-generic bp-enabled?) ; implemented
(define-generic bp-behaviour) ; implemented
(define-generic bp-run) ; implemented
(define-generic bp-message) ; virtual
(define-generic bp-delete!) ; virtual
(define-generic bp-describe) ; implemented
;;; The following all take arguments that describe (in whatever way
;;; the various subclasses support) a breakpoint location. The
;;; <breakpoint> implementations of `break!' and `trace!' just call
;;; `set-breakpoint!' specifying the `debug-here' and `trace-here'
;;; behaviours respectively.
(define-generic set-breakpoint!) ; semi-virtual
(define-generic get-breakpoint) ; semi-virtual
;;; Common base class for breakpoints.
(define-class <breakpoint> ()
;; Breakpoint number.
(number #:accessor bp-number
#:init-thunk (let ((count 0))
(lambda ()
(set! count (+ count 1))
count)))
;; Whether this breakpoint is currently enabled.
(enabled? #:accessor bp-enabled?
#:init-value #t)
;; Breakpoint behaviour, either a list of behaviour indicators, or a
;; thunk that, when called, returns such a list.
(behaviour #:accessor bp-behaviour
#:init-value '()))
;;; Registration of <breakpoint> subclasses. The only current reason
;;; for this is so that we can provide `all-breakpoints'.
(define subclass-registrations '())
(define (register-breakpoint-subclass class list-thunk)
;; LIST-THUNK should be a thunk that returns a list containing all
;; current breakpoints of the corresponding class.
(set! subclass-registrations
(assq-set! subclass-registrations class list-thunk)))
(define (all-breakpoints)
(sort (apply append
(map (lambda (list-thunk) (list-thunk))
(map cdr subclass-registrations)))
(lambda (bp1 bp2)
(< (bp-number bp1) (bp-number bp2)))))
(define (describe-all-breakpoints)
(for-each (lambda (bp)
(bp-describe bp #t))
(all-breakpoints)))
(define-method (get-breakpoint (number <integer>))
(let loop ((bps (all-breakpoints)))
(if (null? bps)
#f
(let* ((bp (car bps))
(bp-num (bp-number bp)))
(cond ((= bp-num number) bp)
((> bp-num number) #f)
(else (loop (cdr bps))))))))
(define (make-breakpoint-command proc)
(lambda args
(let ((bp (apply get-breakpoint args)))
(if bp
(proc bp)
(display "Breakpoint not found\n")))))
(define describe-breakpoint
(make-breakpoint-command (lambda (bp)
(bp-describe bp #t))))
(define disable-breakpoint!
(make-breakpoint-command (lambda (bp)
(set! (bp-enabled? bp) #f)
(bp-describe bp #t))))
(define enable-breakpoint!
(make-breakpoint-command (lambda (bp)
(set! (bp-enabled? bp) #t)
(bp-describe bp #t))))
(define delete-breakpoint!
(make-breakpoint-command bp-delete!))
(define-method (set-breakpoint! behaviour (number <integer>))
(let ((bp (get-breakpoint number)))
(if bp
(begin
(set! (bp-behaviour bp) behaviour)
(bp-describe bp #t))
(display "No such breakpoint\n"))))
;;; `bp-run' is what trap hook functions should call when they
;;; establish that the program is at a breakpoint location.
(define-method (bp-run (bp <breakpoint>))
;; Only do anything if the breakpoint is enabled.
(add-debug-entry-message (bp-message bp "Hit breakpoint" #f))
(if (bp-enabled? bp)
;; Get behaviour for this breakpoint.
(let ((behaviour (bp-behaviour bp)))
;; Behaviour should be a thunk or a list of thunks.
(cond ((thunk? behaviour)
(behaviour))
((list? behaviour)
(for-each (lambda (thunk) (thunk)) behaviour))
(else
(bp-message bp "Bad behaviour for breakpoint" #t)))
; (if (thunk? behaviour)
; (set! behaviour (behaviour)))
; ;; If not a list, wrap as a list.
; (or (list? behaviour)
; (set! behaviour (list behaviour)))
; ;; If behaviour indicates tracing, do so.
; (if (memq #:trace behaviour)
; (trace-here))
; ;; If behaviour indicates a thunk to be run when we exit the
; ;; current frame, register it.
; (let ((at-exit (memq #:at-exit behaviour)))
; (if (and at-exit (not (null? (cdr at-exit))))
; (set-at-exit (cadr at-exit))))
; ;; If behaviour indicates interactive debugging, set flag that
; ;; will cause us to enter the debugger.
; (if (memq #:debug behaviour)
; (begin
; (bp-message "Hit breakpoint" bp)
; (debug-here)))
)))
;;; `break! ...' is just shorthand for `set-breakpoint! debug-here ...'.
(define (break! . args)
(apply set-breakpoint! debug-here args))
;;; Similarly `trace! ...' and `set-breakpoint! trace-here ...'.
(define (trace! . args)
(apply set-breakpoint! trace-here args))
;;; And so on.
(define (trace-subtree! . args)
(apply set-breakpoint! trace-subtree args))
;;; `bp-describe' is expected to be overridden/extended by subclasses,
;;; but subclass implementations may want to leverage this
;;; implementation by beginning with `(next-method)'.
(define-method (bp-describe (bp <breakpoint>) port)
(bp-message bp "Breakpoint" port)
(format port "\tenabled? = ~S\n" (bp-enabled? bp))
(format port "\tbehaviour = ~S\n" (bp-behaviour bp))
*unspecified*)
;;; (ice-9 debugger breakpoints) ends here.

28
ice-9/debugger/breakpoints/Makefile.am
View file

@ -1,28 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2002, 2004 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or
## modify it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or (at
## your option) any later version.
##
## GUILE is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
## General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with GUILE; see the file COPYING. If not, write to
## the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
## Boston, MA 02111-1307 USA
AUTOMAKE_OPTIONS = gnu
subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger/breakpoints
subpkgdata_DATA = procedural.scm range.scm source.scm
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(subpkgdata_DATA)

103
ice-9/debugger/breakpoints/procedural.scm
View file

@ -1,103 +0,0 @@
;;;; (ice-9 debugger breakpoints procedural) -- procedural breakpoints
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugger breakpoints procedural)
#:use-module (ice-9 format)
#:use-module (oop goops)
#:use-module (ice-9 debugger breakpoints)
#:use-module (ice-9 debugger trc)
#:use-module (ice-9 debugger trap-hooks)
#:export (<procedure-breakpoint>
bp-procedure))
;;; {Procedure Breakpoints}
;;;
;;; Breakpoints that activate upon application of a particular
;;; procedure.
(define-generic bp-procedure)
(define-generic bp-hook)
(define-class <procedure-breakpoint> (<breakpoint>)
;; The procedure to which this breakpoint applies.
(procedure #:accessor bp-procedure
#:init-keyword #:procedure)
;; The procedure that is registered as a trace hook for this
;; breakpoint, stored here so that we can easily deregister it.
(hook #:accessor bp-hook))
(define (nameify proc)
(or (procedure-name proc) proc))
(define-method (bp-message (bp <procedure-breakpoint>) message port)
(format port
"~A ~A: [~A]\n"
message
(bp-number bp)
(nameify (bp-procedure bp))))
;;; Alist of all procedure breakpoints:
;;; ((PROCEDURE . BREAKPOINT) ...)
;;; Keys are unique according to `eq?'.
(define procedure-breakpoints '())
(define-method (get-breakpoint (proc <procedure>))
(assq-ref procedure-breakpoints proc))
(define *proc* #f)
(add-hook! before-apply-frame-hook
(lambda (cont tail?)
(trc 'before-apply-frame-hook tail?)
;(set! *expr* #f)
(set! *proc* (frame-procedure (last-stack-frame cont)))))
(define (add-breakpoint proc)
(let* ((bp (make <procedure-breakpoint> #:procedure proc))
(hook (lambda ()
(if (eq? proc *proc*)
(bp-run bp)))))
(set-procedure-property! proc 'trace #t)
(set! (bp-hook bp) hook)
(add-trace-hook! hook)
(set! procedure-breakpoints (assq-set! procedure-breakpoints proc bp))
bp))
(define-method (set-breakpoint! behaviour (proc <procedure>))
(let ((bp (or (get-breakpoint proc)
(add-breakpoint proc))))
(set! (bp-behaviour bp) behaviour)
(bp-message bp "Set breakpoint" #t)
bp))
(define-method (bp-delete! (bp <procedure-breakpoint>))
(let ((proc (bp-procedure bp)))
(set! procedure-breakpoints
(assq-remove! procedure-breakpoints proc))
(set-procedure-property! proc 'trace #f)
(remove-trace-hook! (bp-hook bp))
(bp-message bp "Deleted breakpoint" #t))
*unspecified*)
(register-breakpoint-subclass <procedure-breakpoint>
(lambda ()
(map cdr procedure-breakpoints)))
;;; (ice-9 debugger breakpoints procedure) ends here.

192
ice-9/debugger/breakpoints/range.scm
View file

@ -1,192 +0,0 @@
;;;; (ice-9 debugger breakpoints range) -- experimental range breakpoints
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugger breakpoints range)
#:use-module (ice-9 debugger breakpoints)
#:use-module (ice-9 debugger trap-hooks)
#:use-module (ice-9 debugger trc)
#:use-module (ice-9 debugger utils)
#:use-module (ice-9 format)
#:use-module (oop goops)
#:export (<range-breakpoint>
bp-range))
;;; {Range Breakpoints}
;;;
;;; Breakpoints that activate upon entry to a frame whose source lies
;;; in a specified range.
(define-generic bp-range)
(define-class <range-breakpoint> (<breakpoint>)
;; The range of this breakpoint.
(range #:accessor bp-range #:init-keyword #:range))
(define (range->string filename from-line from-column to-line to-column)
(if (positive? from-line)
(format #f "~A:~A:~A-~A:~A" filename
(+ from-line 1) (+ from-column 1)
(+ to-line 1) (+ to-column 1))
(format #f "~A (whole file)" filename)))
(define-method (bp-message (bp <range-breakpoint>) message port)
(format port
"~A ~A: ~A\n"
message
(bp-number bp)
(apply range->string (bp-range bp))))
;;; Alist of all range breakpoints:
;;; ((RANGE . BREAKPOINT) ...)
;;; where RANGE is
;;; (FILE-NAME FROM-LINE FROM-COLUMN TO-LINE TO-COLUMN)
;;; Keys are unique according to `equal?'.
(define range-breakpoints '())
(define-method (get-breakpoint (filename <string>)
(from-line <integer>)
(from-column <integer>)
(to-line <integer>)
(to-column <integer>))
(assoc-ref range-breakpoints
(if (positive? from-line)
(list filename
(- from-line 1)
(- from-column 1)
(- to-line 1)
(- to-column 1))
(list filename 0 0 0 0))))
(define-method (get-breakpoint (filename <string>))
(get-breakpoint filename 0 0 0 0))
(define-method (get-breakpoint (filename <string>)
(line <integer>))
(get-breakpoint filename line 1 (+ line 1) 1))
(define-method (get-breakpoint (filename <string>)
(from-line <integer>)
(to-line <integer>))
(get-breakpoint filename from-line 1 to-line 1))
(define (add-breakpoint filename from-line from-column to-line to-column)
(let* ((range (if (positive? from-line)
(list filename
(- from-line 1)
(- from-column 1)
(- to-line 1)
(- to-column 1))
(list filename 0 0 0 0)))
(bp (make <range-breakpoint> #:range range)))
(set! range-breakpoints (assoc-set! range-breakpoints range bp))
(remove/install-range-breakpoint-hooks)
bp))
(define-method (set-breakpoint! behaviour
(filename <string>)
(from-line <integer>)
(from-column <integer>)
(to-line <integer>)
(to-column <integer>))
(let ((bp (or (get-breakpoint filename from-line from-column to-line to-column)
(add-breakpoint filename from-line from-column to-line to-column))))
(set! (bp-behaviour bp) behaviour)
(bp-message bp "Set breakpoint" #t)
bp))
(define-method (set-breakpoint! behaviour
(filename <string>))
(set-breakpoint! behaviour filename 0 0 0 0))
(define-method (set-breakpoint! behaviour
(filename <string>)
(line <integer>))
(set-breakpoint! behaviour filename line 1 (+ line 1) 1))
(define-method (set-breakpoint! behaviour
(filename <string>)
(from-line <integer>)
(to-line <integer>))
(set-breakpoint! behaviour filename from-line 1 to-line 1))
(define remove/install-range-breakpoint-hooks
(let ((hooks-installed? #f))
(lambda ()
(cond ((and hooks-installed?
(null? range-breakpoints))
(remove-hook! before-enter-frame-hook
range-before-enter-frame-hook)
(remove-enter-frame-hook! range-enter-frame-hook)
(set! hooks-installed? #f))
((and (not hooks-installed?)
(not (null? range-breakpoints)))
(add-hook! before-enter-frame-hook
range-before-enter-frame-hook)
(add-enter-frame-hook! range-enter-frame-hook)
(set! hooks-installed? #t))))))
(define *cont* #f)
(define (range-before-enter-frame-hook cont . ignored)
(trc 'range-before-enter-frame-hook)
(set! *cont* cont))
(define (range-enter-frame-hook)
(trc 'range-enter-frame-hook)
(let* ((frame (last-stack-frame *cont*))
(source (frame-source frame))
(position (and source (source-position source))))
(if position
(for-each (lambda (range bp)
(if (apply position-in-range position range)
(bp-run bp)))
(map car range-breakpoints)
(map cdr range-breakpoints)))))
(define (position-in-range position
filename
from-line
from-column
to-line
to-column)
(and (string=? (car position) filename)
(if (positive? from-line)
(let ((pline (cadr position))
(pcolumn (caddr position)))
(and (or (and (= pline from-line)
(>= pcolumn from-column))
(> pline from-line))
(or (and (= pline to-line)
(< pcolumn to-column))
(< pline to-line))))
#t)))
(define-method (bp-delete! (bp <range-breakpoint>))
(set! range-breakpoints
(assoc-remove! range-breakpoints (bp-range bp)))
(remove/install-range-breakpoint-hooks)
(bp-message bp "Deleted breakpoint" #t)
*unspecified*)
(register-breakpoint-subclass <range-breakpoint>
(lambda ()
(map cdr range-breakpoints)))
;;; (ice-9 debugger breakpoints range) ends here.

244
ice-9/debugger/breakpoints/source.scm
View file

@ -1,244 +0,0 @@
;;;; (ice-9 debugger breakpoints source) -- source location breakpoints
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugger breakpoints source)
#:use-module (ice-9 format)
#:use-module (ice-9 debugger breakpoints)
#:use-module (ice-9 debugger trap-hooks)
#:use-module (ice-9 debugger trc)
#:use-module (ice-9 debugger utils)
#:use-module (oop goops)
#:export (<source-breakpoint>
bp-location
bp-expression))
;;; {Source Breakpoints}
;;;
;;; Breakpoints that activate upon reaching a particular source
;;; location or range of source locations.
(define-generic bp-location)
(define-generic bp-expression)
(define-class <source-breakpoint> (<breakpoint>)
;; The location of this breakpoint.
(location #:accessor bp-location
#:init-keyword #:location)
;; The source expression at this breakpoint.
(expression #:accessor bp-expression
#:init-keyword #:expression)
;; Counter: incremented when the breakpoint is set, decremented when
;; a source expression using this breakpoint applied has been GC'd.
(use-count #:accessor bp-use-count
#:init-value 0))
(define (location->string filename line column)
(format #f "~A:~A:~A" filename (+ line 1) (+ column 1)))
(define-method (bp-message (bp <source-breakpoint>) message port)
(format port
"~A ~A: ~A: ~S\n"
message
(bp-number bp)
(apply location->string (bp-location bp))
(bp-expression bp)))
(define-method (bp-describe (bp <source-breakpoint>) port)
(next-method)
(if (zero? (bp-use-count bp))
(format port "\t(this breakpoint is a zombie)\n"))
*unspecified*)
;;; Alist of all source breakpoints:
;;; ((LOCATION . BREAKPOINT) ...)
;;; where LOCATION is
;;; (FILE-NAME LINE COLUMN)
;;; Keys are unique according to `equal?'.
(define source-breakpoints '())
(define-method (get-breakpoint (filename <string>)
(line <integer>)
(column <integer>))
(assoc-ref source-breakpoints (list filename line column)))
;;; When the source expression that a breakpoint is attached to is
;;; GC'd, typically because the variable that included it in its value
;;; has been redefined, we'd like to mark the breakpoint as no longer
;;; relevant. We do this by using a property guardian ...
(define (make-property-guardian)
;; Return a new property guardian. A property guardian is a
;; combination of a guardian and an object property that accepts KEY
;; -> VALUE associations and gives you back the VALUE when its KEY
;; has been garbage collected.
;;
;; To store an association, call it in the same way as you would an
;; object property: (set! (PROPERTY-GUARDIAN KEY) VALUE).
;;
;; To retrieve the VALUE for a KEY that has been GC'd, call the
;; property guardian in the same way as you would a guardian, with
;; no args: (PROPERTY-GUARDIAN).
(let ((p (make-object-property))
(g (make-guardian)))
(make-procedure-with-setter
(lambda ()
(let ((collected (g)))
(and collected (car collected))))
(lambda (key value)
(let ((collectible (list value)))
;; Store the collectible value both as an object property,
;; and in the guardian.
(set! (p key) collectible)
(g collectible))))))
(define source-breakpoint-guardian (make-property-guardian))
(add-hook! after-gc-hook
(lambda ()
(let loop ((bp (source-breakpoint-guardian)))
(if bp
(let ((new-use-count (- (bp-use-count bp) 1)))
(set! (bp-use-count bp) new-use-count)
(if (zero? new-use-count)
(bp-message bp "Zombified breakpoint" #t))
(loop (source-breakpoint-guardian)))))))
(define (add-breakpoint filename line column expression)
(let* ((location (list filename line column))
(bp (make <source-breakpoint>
#:location location
#:expression (if (pair? expression)
;; The point of this strange looking
;; copy is to copy the expression
;; without its source properties.
;; This is necessary to allow the
;; source properties to be GC'd when
;; the source expression becomes
;; obsolete. (Note that `copy-tree'
;; copies source properties as well!)
(cons (car expression) (cdr expression))
expression))))
(set! source-breakpoints (assoc-set! source-breakpoints location bp))
bp))
(define-method (set-breakpoint! behaviour
x-as-read
(x-pairified <pair>))
(let ((filename (source-property x-pairified 'filename))
(line (source-property x-pairified 'line))
(column (source-property x-pairified 'column)))
(let ((bp (or (get-breakpoint filename line column)
(add-breakpoint filename line column x-as-read))))
(set! (bp-behaviour bp) behaviour)
(install-breakpoint x-pairified bp)
(bp-message bp "Set breakpoint" #t)
bp)))
(define (install-breakpoint x bp)
;; Make the necessary connections with the specified expression and
;; its breakpoint.
(set-source-property! x 'breakpoint #t)
(set! (source-breakpoint-guardian x) bp)
(set! (bp-use-count bp) (+ (bp-use-count bp) 1))
(remove/install-source-breakpoint-hooks))
(define remove/install-source-breakpoint-hooks
(let ((hooks-installed? #f))
(lambda ()
(cond ((and hooks-installed?
(null? source-breakpoints))
(remove-hook! before-enter-frame-hook
source-before-enter-frame-hook)
(remove-breakpoint-hook! source-breakpoint-hook)
(set! hooks-installed? #f))
((and (not hooks-installed?)
(not (null? source-breakpoints)))
(add-hook! before-enter-frame-hook
source-before-enter-frame-hook)
(add-breakpoint-hook! source-breakpoint-hook)
(set! hooks-installed? #t))))))
(define *cont* #f)
(define (source-before-enter-frame-hook cont . ignored)
(trc 'source-before-enter-frame-hook)
(set! *cont* cont))
(define (source-breakpoint-hook)
(trc 'source-breakpoint-hook)
(let* ((frame (last-stack-frame *cont*))
(source (frame-source frame))
(position (and source (source-position source)))
(bp (and position (apply get-breakpoint position))))
(if bp
(bp-run bp))))
(define-method (bp-delete! (bp <source-breakpoint>))
(set! source-breakpoints (assoc-remove! source-breakpoints (bp-location bp)))
(remove/install-source-breakpoint-hooks)
(bp-message bp "Deleted breakpoint" #t)
*unspecified*)
(register-breakpoint-subclass <source-breakpoint>
(lambda ()
(map cdr source-breakpoints)))
(read-hash-extend #\#
(lambda (c port)
(let (;; Save off port coordinates before reading
;; the following expression, as we'll need
;; to install source coordinates by hand if
;; the expression turns out not to be a
;; pair.
(filename (port-filename port))
(line (port-line port))
(column (port-column port)))
;; Now read the marked expression.
(let* ((x (read port))
(x' (if (pair? x)
x
;; The marked expression isn't a
;; pair, so it can't carry source
;; properties by itself.
;; Therefore we pretend instead
;; to have read `(begin X)', and
;; attach coordinate and
;; breakpoint information to the
;; begin expression.
(let ((x' (list begin x)))
(set-source-property! x' 'filename
filename)
(set-source-property! x' 'line
line)
(set-source-property! x' 'column
column)
x'))))
;; Don't allow breakpointed expression to have
;; a filename property that isn't a string.
(or (string? filename)
(set-source-property! x' 'filename "<unnamed port>"))
(break! x x')
x'))))
(read-enable 'positions)
;;; (ice-9 debugger breakpoints source) ends here.

2
ice-9/debugger/command-loop.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; 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:)

2
ice-9/debugger/commands.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger commands)
#:use-module (ice-9 debug)

2
ice-9/debugger/state.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger state)
#:export (make-state

320
ice-9/debugger/trap-hooks.scm
View file

@ -1,320 +0,0 @@
;;;; (ice-9 debugger trap-hooks) -- abstraction of libguile's traps interface
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; 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 debugger trap-hooks)
#:use-module (ice-9 debugger trc)
#:export (add-trapped-stack-id!
remove-trapped-stack-id!
before-apply-frame-hook
before-enter-frame-hook
before-exit-frame-hook
after-apply-frame-hook
after-enter-frame-hook
after-exit-frame-hook
add-apply-frame-hook!
add-breakpoint-hook!
add-enter-frame-hook!
add-exit-frame-hook!
add-trace-hook!
remove-apply-frame-hook!
remove-breakpoint-hook!
remove-enter-frame-hook!
remove-exit-frame-hook!
remove-trace-hook!
debug-hook-membership))
;;; 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 possible 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.
;;; {Stack IDs}
;;;
;;; Mechanism for limiting trapping to contexts whose stack ID matches
;;; one of a registered set. The default set up is to limit trapping
;;; to events in the contexts of the Guile REPL and of file loading.
(define trapped-stack-ids (list 'repl-stack 'load-stack))
(define all-stack-ids-trapped? #f)
(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 before-enter-frame-hook (make-hook 3))
(define enter-frame-hook (make-hook))
(define breakpoint-hook (make-hook))
(define after-enter-frame-hook (make-hook))
(define before-exit-frame-hook (make-hook 2))
(define exit-frame-hook (make-hook))
(define after-exit-frame-hook (make-hook))
(define before-apply-frame-hook (make-hook 2))
(define apply-frame-hook (make-hook))
(define trace-hook (make-hook))
(define after-apply-frame-hook (make-hook))
(define (hook-not-empty? hook)
(not (hook-empty? hook)))
(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 (hook-not-empty? trace-hook))
(need-breakpoints (hook-not-empty? breakpoint-hook))
(need-enter-frame (hook-not-empty? enter-frame-hook))
(need-apply-frame (hook-not-empty? apply-frame-hook))
(need-exit-frame (hook-not-empty? exit-frame-hook)))
(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)))
(trc 'enter-frame-handler)
(if application-entry?
(run-hook before-enter-frame-hook cont #f #f)
(run-hook before-enter-frame-hook cont (car args) (cadr args)))
(run-hook enter-frame-hook)
(or application-entry?
(run-hook breakpoint-hook))
(run-hook after-enter-frame-hook))))
(define (exit-frame-handler key cont retval)
(if (trap-here? cont)
(begin
(trc 'exit-frame-handler retval (stack-length (make-stack cont)))
(run-hook before-exit-frame-hook cont retval)
(run-hook exit-frame-hook)
(run-hook after-exit-frame-hook))))
(define (apply-frame-handler key cont tail?)
(if (trap-here? cont)
(begin
(trc 'apply-frame-handler tail?)
(run-hook before-apply-frame-hook cont tail?)
(run-hook apply-frame-hook)
(run-hook trace-hook)
(run-hook after-apply-frame-hook))))
(define-public (add-enter-frame-hook! proc)
(add-hook! enter-frame-hook proc)
(set-debug-and-trap-options))
(define-public (add-breakpoint-hook! proc)
(add-hook! breakpoint-hook proc)
(set-debug-and-trap-options))
(define-public (add-exit-frame-hook! proc)
(add-hook! exit-frame-hook proc)
(set-debug-and-trap-options))
(define-public (add-apply-frame-hook! proc)
(add-hook! apply-frame-hook proc)
(set-debug-and-trap-options))
(define-public (add-trace-hook! proc)
(add-hook! trace-hook proc)
(set-debug-and-trap-options))
(define-public (remove-enter-frame-hook! proc)
(remove-hook! enter-frame-hook proc)
(set-debug-and-trap-options))
(define-public (remove-breakpoint-hook! proc)
(remove-hook! breakpoint-hook proc)
(set-debug-and-trap-options))
(define-public (remove-exit-frame-hook! proc)
(remove-hook! exit-frame-hook proc)
(set-debug-and-trap-options))
(define-public (remove-apply-frame-hook! proc)
(remove-hook! apply-frame-hook proc)
(set-debug-and-trap-options))
(define-public (remove-trace-hook! proc)
(remove-hook! trace-hook proc)
(set-debug-and-trap-options))
(define-public (debug-hook-membership)
(for-each (lambda (name+hook)
(format #t "~A:\n" (car name+hook))
(for-each (lambda (proc)
(format #t " ~S\n" proc))
(hook->list (cdr name+hook))))
`((before-enter-frame-hook . ,before-enter-frame-hook)
(enter-frame-hook . ,enter-frame-hook )
(breakpoint-hook . ,breakpoint-hook )
(after-enter-frame-hook . ,after-enter-frame-hook )
(before-exit-frame-hook . ,before-exit-frame-hook )
(exit-frame-hook . ,exit-frame-hook )
(after-exit-frame-hook . ,after-exit-frame-hook )
(before-apply-frame-hook . ,before-apply-frame-hook)
(apply-frame-hook . ,apply-frame-hook )
(trace-hook . ,trace-hook )
(after-apply-frame-hook . ,after-apply-frame-hook ))))
;;; (ice-9 debugger trap-hooks) ends here.

2
ice-9/debugger/trc.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; 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))

2
ice-9/deprecated.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; Deprecated definitions.

2
ice-9/documentation.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:

2
ice-9/emacs.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN

2
ice-9/expect.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:

2
ice-9/ftw.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

2
ice-9/gap-buffer.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

2
ice-9/getopt-long.scm
View file

@ -12,7 +12,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)

2
ice-9/hcons.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

2
ice-9/history.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; A simple value history support

2
ice-9/lineio.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

2
ice-9/list.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 list)
:export (rassoc rassv rassq))

2
ice-9/ls.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 ls)

2
ice-9/mapping.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

2
ice-9/match.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 match)

2
ice-9/networking.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define (gethostbyaddr addr) (gethost addr))

2
ice-9/null.scm
View file

@ -12,7 +12,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; The null environment - only syntactic bindings

2
ice-9/occam-channel.scm
View file

@ -14,7 +14,7 @@
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 occam-channel)
#:use-syntax (ice-9 syncase)

2
ice-9/optargs.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>

2
ice-9/poe.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

2
ice-9/popen.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 popen)

2
ice-9/posix.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define (stat:dev f) (vector-ref f 0))

2
ice-9/pretty-print.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 pretty-print)
:use-module (ice-9 optargs)

2
ice-9/psyntax.ss
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

2
ice-9/q.scm
View file

@ -14,7 +14,7 @@
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:

Some files were not shown because too many files have changed in this diff Show more