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

Merge GDS (except for breakpoints) from CVS HEAD:

Browse source 
* scheme-using.texi: New (merged with modifications from CVS
HEAD).

* Makefile.am, gds-scheme.el, gds-server.el, gds.el: New (merged
with modifications from CVS HEAD).

* debugging/Makefile.am, debugging/example-fns.scm,
debugging/ice-9-debugger-extensions.scm, debugging/steps.scm,
debugging/trace.scm, debugging/traps.scm, debugging/trc.scm: New
(merged with modifications from CVS HEAD).

* gds-client.scm, gds-server.scm: New (merged with modifications
from CVS HEAD).
This commit is contained in:
Neil Jerram 2008-03-12 00:39:26 +00:00
parent d412e58c1f
commit 51d237110f
17 changed files with 4727 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

5
doc/ref/ChangeLog
View file

@ -1,3 +1,8 @@
2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
* scheme-using.texi: New (merged with modifications from CVS
HEAD).
2008-02-11 Neil Jerram <neil@ossau.uklinux.net>
* api-data.texi (Random): New text about the default random state,

1061
doc/ref/scheme-using.texi Normal file
View file

File diff suppressed because it is too large Load diff

5
emacs/ChangeLog
View file

@ -1,3 +1,8 @@
2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am, gds-scheme.el, gds-server.el, gds.el: New (merged
with modifications from CVS HEAD).
2005-07-09 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am, REAME.GDS, gds-client.scm, gds-problems.txt,

27
emacs/Makefile.am Normal file
View file

@ -0,0 +1,27 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
dist_lisp_LISP = gds.el gds-server.el gds-scheme.el
ELCFILES =
ETAGS_ARGS = $(dist_lisp_LISP)

520
emacs/gds-scheme.el Executable file
View file

@ -0,0 +1,520 @@
;;; gds-scheme.el -- GDS function for Scheme mode buffers
;;;; Copyright (C) 2005 Neil Jerram
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later
;;;; version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA
(require 'comint)
(require 'scheme)
(require 'derived)
(require 'pp)
;;;; Maintaining an association between a Guile client process and a
;;;; set of Scheme mode buffers.
(defcustom gds-auto-create-utility-client t
"Whether to automatically create a utility Guile client, and
associate the current buffer with it, if there are no existing Guile
clients available to GDS when the user does something that requires a
running Guile client."
:type 'boolean
:group 'gds)
(defcustom gds-auto-associate-single-client t
"Whether to automatically associate the current buffer with an
existing Guile client, if there is only only client known to GDS when
the user does something that requires a running Guile client, and the
current buffer is not already associated with a Guile client."
:type 'boolean
:group 'gds)
(defcustom gds-auto-associate-last-client t
"Whether to automatically associate the current buffer with the
Guile client that most recently caused that buffer to be displayed,
when the user does something that requires a running Guile client and
the current buffer is not already associated with a Guile client."
:type 'boolean
:group 'gds)
(defvar gds-last-touched-by nil
"For each Scheme mode buffer, this records the GDS client that most
recently `touched' that buffer in the sense of using it to display
source code, for example for the source code relevant to a debugger
stack frame.")
(make-variable-buffer-local 'gds-last-touched-by)
(defun gds-auto-associate-buffer ()
"Automatically associate the current buffer with a Guile client, if
possible."
(let* ((num-clients (length gds-client-info))
(client
(or
;; If there are no clients yet, and
;; `gds-auto-create-utility-client' allows us to create one
;; automatically, do that.
(and (= num-clients 0)
gds-auto-create-utility-client
(gds-start-utility-guile))
;; Otherwise, if there is a single existing client, and
;; `gds-auto-associate-single-client' allows us to use it
;; for automatic association, do that.
(and (= num-clients 1)
gds-auto-associate-single-client
(caar gds-client-info))
;; Otherwise, if the current buffer was displayed because
;; of a Guile client trapping somewhere in its code, and
;; `gds-auto-associate-last-client' allows us to associate
;; with that client, do so.
(and gds-auto-associate-last-client
gds-last-touched-by))))
(if client
(gds-associate-buffer client))))
(defun gds-associate-buffer (client)
"Associate the current buffer with the Guile process CLIENT.
This means that operations in this buffer that require a running Guile
process - such as evaluation, help, completion and setting traps -
will be sent to the Guile process whose name or connection number is
CLIENT."
(interactive (list (gds-choose-client)))
;; If this buffer is already associated, dissociate from its
;; existing client first.
(if gds-client (gds-dissociate-buffer))
;; Store the client number in the buffer-local variable gds-client.
(setq gds-client client)
;; Add this buffer to the list of buffers associated with the
;; client.
(gds-client-put client 'associated-buffers
(cons (current-buffer)
(gds-client-get client 'associated-buffers))))
(defun gds-dissociate-buffer ()
"Dissociate the current buffer from any specific Guile process."
(interactive)
(if gds-client
(progn
;; Remove this buffer from the list of buffers associated with
;; the current client.
(gds-client-put gds-client 'associated-buffers
(delq (current-buffer)
(gds-client-get gds-client 'associated-buffers)))
;; Reset the buffer-local variable gds-client.
(setq gds-client nil)
;; Clear any process status indication from the modeline.
(setq mode-line-process nil)
(force-mode-line-update))))
(defun gds-show-client-status (client status-string)
"Show a client's status in the modeline of all its associated
buffers."
(let ((buffers (gds-client-get client 'associated-buffers)))
(while buffers
(if (buffer-live-p (car buffers))
(with-current-buffer (car buffers)
(setq mode-line-process status-string)
(force-mode-line-update)))
(setq buffers (cdr buffers)))))
(defcustom gds-running-text ":running"
"*Mode line text used to show that a Guile process is \"running\".
\"Running\" means that the process cannot currently accept any input
from the GDS frontend in Emacs, because all of its threads are busy
running code that GDS cannot easily interrupt."
:type 'string
:group 'gds)
(defcustom gds-ready-text ":ready"
"*Mode line text used to show that a Guile process is \"ready\".
\"Ready\" means that the process is ready to interact with the GDS
frontend in Emacs, because at least one of its threads is waiting for
GDS input."
:type 'string
:group 'gds)
(defcustom gds-debug-text ":debug"
"*Mode line text used to show that a Guile process is \"debugging\".
\"Debugging\" means that the process is using the GDS frontend in
Emacs to display an error or trap so that the user can debug it."
:type 'string
:group 'gds)
(defun gds-choose-client ()
"Ask the user to choose a GDS client process from a list."
(let ((table '())
(default nil))
;; Prepare a table containing all current clients.
(mapcar (lambda (client-info)
(setq table (cons (cons (cadr (memq 'name client-info))
(car client-info))
table)))
gds-client-info)
;; Add an entry to allow the user to ask for a new process.
(setq table (cons (cons "Start a new Guile process" nil) table))
;; Work out a good default. If the buffer has a good value in
;; gds-last-touched-by, we use that; otherwise default to starting
;; a new process.
(setq default (or (and gds-last-touched-by
(gds-client-get gds-last-touched-by 'name))
(caar table)))
;; Read using this table.
(let* ((name (completing-read "Choose a Guile process: "
table
nil
t ; REQUIRE-MATCH
nil ; INITIAL-INPUT
nil ; HIST
default))
;; Convert name to a client number.
(client (cdr (assoc name table))))
;; If the user asked to start a new Guile process, do that now.
(or client (setq client (gds-start-utility-guile)))
;; Return the chosen client ID.
client)))
(defvar gds-last-utility-number 0
"Number of the last started Guile utility process.")
(defun gds-start-utility-guile ()
"Start a new utility Guile process."
(setq gds-last-utility-number (+ gds-last-utility-number 1))
(let* ((procname (format "gds-util[%d]" gds-last-utility-number))
(code (format "(begin
%s
(use-modules (ice-9 gds-client))
(run-utility))"
(if gds-scheme-directory
(concat "(set! %load-path (cons "
(format "%S" gds-scheme-directory)
" %load-path))")
"")))
(proc (start-process procname
(get-buffer-create procname)
gds-guile-program
"-q"
"--debug"
"-c"
code))
(client nil))
;; Note that this process can be killed automatically on Emacs
;; exit.
(process-kill-without-query proc)
;; Set up a process filter to catch the new client's number.
(set-process-filter proc
(lambda (proc string)
(setq client (string-to-number string))
(if (process-buffer proc)
(with-current-buffer (process-buffer proc)
(insert string)))))
;; Accept output from the new process until we have its number.
(while (not client)
(accept-process-output proc))
;; Return the new process's client number.
client))
;;;; Evaluating code.
;; The following commands send code for evaluation through the GDS TCP
;; connection, receive the result and any output generated through the
;; same connection, and display the result and output to the user.
;;
;; For each buffer where evaluations can be requested, GDS uses the
;; buffer-local variable `gds-client' to track which GDS client
;; program should receive and handle that buffer's evaluations.
(defun gds-module-name (start end)
"Determine and return the name of the module that governs the
specified region. The module name is returned as a list of symbols."
(interactive "r") ; why not?
(save-excursion
(goto-char start)
(let (module-name)
(while (and (not module-name)
(beginning-of-defun-raw 1))
(if (looking-at "(define-module ")
(setq module-name
(progn
(goto-char (match-end 0))
(read (current-buffer))))))
module-name)))
(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
"Prefix used when telling Guile the name of the port from which a
chunk of Scheme code (to be evaluated) comes. GDS uses this prefix,
followed by the buffer name, in two cases: when the buffer concerned
is not associated with a file, or if the buffer has been modified
since last saving to its file. In the case where the buffer is
identical to a saved file, GDS uses the file name as the port name."
:type '(string)
:group 'gds)
(defun gds-port-name (start end)
"Return port name for the specified region of the current buffer.
The name will be used by Guile as the port name when evaluating that
region's code."
(or (and (not (buffer-modified-p))
buffer-file-name)
(concat gds-emacs-buffer-port-name-prefix (buffer-name))))
(defun gds-line-and-column (pos)
"Return 0-based line and column number at POS."
(let (line column)
(save-excursion
(goto-char pos)
(setq column (current-column))
(beginning-of-line)
(setq line (count-lines (point-min) (point))))
(cons line column)))
(defun gds-eval-region (start end)
"Evaluate the current region."
(interactive "r")
(or gds-client
(gds-auto-associate-buffer)
(call-interactively 'gds-associate-buffer))
(let ((module (gds-module-name start end))
(port-name (gds-port-name start end))
(lc (gds-line-and-column start)))
(let ((code (buffer-substring-no-properties start end)))
(gds-send (format "eval (region . %S) %s %S %d %d %S"
(gds-abbreviated code)
(if module (prin1-to-string module) "#f")
port-name (car lc) (cdr lc)
code)
gds-client))))
(defun gds-eval-expression (expr &optional correlator)
"Evaluate the supplied EXPR (a string)."
(interactive "sEvaluate expression: \nP")
(or gds-client
(gds-auto-associate-buffer)
(call-interactively 'gds-associate-buffer))
(set-text-properties 0 (length expr) nil expr)
(gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S"
(or correlator 'expression)
(gds-abbreviated expr)
expr)
gds-client))
(defconst gds-abbreviated-length 35)
(defun gds-abbreviated (code)
(let ((nlpos (string-match (regexp-quote "\n") code)))
(while nlpos
(setq code
(if (= nlpos (- (length code) 1))
(substring code 0 nlpos)
(concat (substring code 0 nlpos)
"\\n"
(substring code (+ nlpos 1)))))
(setq nlpos (string-match (regexp-quote "\n") code))))
(if (> (length code) gds-abbreviated-length)
(concat (substring code 0 (- gds-abbreviated-length 3)) "...")
code))
(defun gds-eval-defun ()
"Evaluate the defun (top-level form) at point."
(interactive)
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(gds-eval-region (point) end))))
(defun gds-eval-last-sexp ()
"Evaluate the sexp before point."
(interactive)
(gds-eval-region (save-excursion (backward-sexp) (point)) (point)))
;;;; Help.
;; Help is implemented as a special case of evaluation, identified by
;; the evaluation correlator 'help.
(defun gds-help-symbol (sym)
"Get help for SYM (a Scheme symbol)."
(interactive
(let ((sym (thing-at-point 'symbol))
(enable-recursive-minibuffers t)
val)
(setq val (read-from-minibuffer
(if sym
(format "Describe Guile symbol (default %s): " sym)
"Describe Guile symbol: ")))
(list (if (zerop (length val)) sym val))))
(gds-eval-expression (format "(help %s)" sym) 'help))
(defun gds-apropos (regex)
"List Guile symbols matching REGEX."
(interactive
(let ((sym (thing-at-point 'symbol))
(enable-recursive-minibuffers t)
val)
(setq val (read-from-minibuffer
(if sym
(format "Guile apropos (regexp, default \"%s\"): " sym)
"Guile apropos (regexp): ")))
(list (if (zerop (length val)) sym val))))
(set-text-properties 0 (length regex) nil regex)
(gds-eval-expression (format "(apropos %S)" regex) 'apropos))
;;;; Displaying results of help and eval.
(defun gds-display-results (client correlator stack-available results)
(let* ((helpp+bufname (cond ((eq (car correlator) 'help)
'(t . "*Guile Help*"))
((eq (car correlator) 'apropos)
'(t . "*Guile Apropos*"))
(t
'(nil . "*Guile Evaluation*"))))
(helpp (car helpp+bufname)))
(let ((buf (get-buffer-create (cdr helpp+bufname))))
(save-selected-window
(save-excursion
(set-buffer buf)
(gds-dissociate-buffer)
(erase-buffer)
(scheme-mode)
(insert (cdr correlator) "\n\n")
(while results
(insert (car results))
(or (bolp) (insert "\\\n"))
(if helpp
nil
(if (cadr results)
(mapcar (function (lambda (value)
(insert " => " value "\n")))
(cadr results))
(insert " => no (or unspecified) value\n"))
(insert "\n"))
(setq results (cddr results)))
(if stack-available
(let ((beg (point))
(map (make-sparse-keymap)))
(define-key map [mouse-1] 'gds-show-last-stack)
(define-key map "\C-m" 'gds-show-last-stack)
(insert "[click here to show error stack]")
(add-text-properties beg (point)
(list 'keymap map
'mouse-face 'highlight))
(insert "\n")))
(goto-char (point-min))
(gds-associate-buffer client))
(pop-to-buffer buf)
(run-hooks 'temp-buffer-show-hook)))))
(defun gds-show-last-stack ()
"Show stack of the most recent error."
(interactive)
(or gds-client
(gds-auto-associate-buffer)
(call-interactively 'gds-associate-buffer))
(gds-send "debug-lazy-trap-context" gds-client))
;;;; Completion.
(defvar gds-completion-results nil)
(defun gds-complete-symbol ()
"Complete the Guile symbol before point. Returns `t' if anything
interesting happened, `nil' if not."
(interactive)
(or gds-client
(gds-auto-associate-buffer)
(call-interactively 'gds-associate-buffer))
(let* ((chars (- (point) (save-excursion
(while (let ((syntax (char-syntax (char-before (point)))))
(or (eq syntax ?w) (eq syntax ?_)))
(forward-char -1))
(point)))))
(if (zerop chars)
nil
(setq gds-completion-results nil)
(gds-send (format "complete %s"
(prin1-to-string
(buffer-substring-no-properties (- (point) chars)
(point))))
gds-client)
(while (null gds-completion-results)
(accept-process-output gds-debug-server 0 200))
(cond ((eq gds-completion-results 'error)
(error "Internal error - please report the contents of the *Guile Evaluation* window"))
((eq gds-completion-results t)
nil)
((stringp gds-completion-results)
(if (<= (length gds-completion-results) chars)
nil
(insert (substring gds-completion-results chars))
(message "Sole completion")
t))
((= (length gds-completion-results) 1)
(if (<= (length (car gds-completion-results)) chars)
nil
(insert (substring (car gds-completion-results) chars))
t))
(t
(with-output-to-temp-buffer "*Completions*"
(display-completion-list gds-completion-results))
t)))))
;;;; Dispatcher for non-debug protocol.
(defun gds-nondebug-protocol (client proc args)
(cond (;; (eval-results ...) - Results of evaluation.
(eq proc 'eval-results)
(gds-display-results client (car args) (cadr args) (cddr args))
;; If these results indicate an error, set
;; gds-completion-results to non-nil in case the error arose
;; when trying to do a completion.
(if (eq (caar args) 'error)
(setq gds-completion-results 'error)))
(;; (completion-result ...) - Available completions.
(eq proc 'completion-result)
(setq gds-completion-results (or (car args) t)))
(;; (note ...) - For debugging only.
(eq proc 'note))
(;; (trace ...) - Tracing.
(eq proc 'trace)
(with-current-buffer (get-buffer-create "*GDS Trace*")
(save-excursion
(goto-char (point-max))
(or (bolp) (insert "\n"))
(insert "[client " (number-to-string client) "] " (car args) "\n"))))
(t
;; Unexpected.
(error "Bad protocol: %S" form))))
;;;; Scheme mode keymap items.
(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
(define-key scheme-mode-map "\C-hG" 'gds-apropos)
(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
;;;; The end!
(provide 'gds-scheme)
;;; gds-scheme.el ends here.

111
emacs/gds-server.el Normal file
View file

@ -0,0 +1,111 @@
;;; gds-server.el -- infrastructure for running GDS server processes
;;;; 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
;;;; Customization group setup.
(defgroup gds nil
"Customization options for Guile Emacs frontend."
:group 'scheme)
;;;; Communication with the (ice-9 gds-server) subprocess.
;; Subprocess output goes into the `*GDS Process*' buffer, and
;; is then read from there one form at a time. `gds-read-cursor' is
;; the buffer position of the start of the next unread form.
(defvar gds-read-cursor nil)
;; The guile executable used by the GDS server process.
(defcustom gds-guile-program "guile"
"*The guile executable used by the GDS server process."
:type 'string
:group 'gds)
(defcustom gds-scheme-directory nil
"Where GDS's Scheme code is, if not in one of the standard places."
:group 'gds
:type '(choice (const :tag "nil" nil) directory))
(defun gds-start-server (procname port-or-path protocol-handler &optional bufname)
"Start a GDS server process called PROCNAME, listening on TCP port
or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a
function that accepts and processes one protocol form. Optional arg
BUFNAME specifies the name of the buffer that is used for process
output; if not specified the buffer name is the same as the process
name."
(with-current-buffer (get-buffer-create (or bufname procname))
(erase-buffer)
(let* ((code (format "(begin
%s
(use-modules (ice-9 gds-server))
(run-server %S))"
(if gds-scheme-directory
(concat "(set! %load-path (cons "
(format "%S" gds-scheme-directory)
" %load-path))")
"")
port-or-path))
(process-connection-type nil) ; use a pipe
(proc (start-process procname
(current-buffer)
gds-guile-program
"-q"
"--debug"
"-c"
code)))
(set (make-local-variable 'gds-read-cursor) (point-min))
(set (make-local-variable 'gds-protocol-handler) protocol-handler)
(set-process-filter proc (function gds-filter))
(set-process-sentinel proc (function gds-sentinel))
(set-process-coding-system proc 'latin-1-unix)
(process-kill-without-query proc)
proc)))
;; Subprocess output filter: inserts normally into the process buffer,
;; then tries to reread the output one form at a time and delegates
;; processing of each form to `gds-protocol-handler'.
(defun gds-filter (proc string)
(with-current-buffer (process-buffer proc)
(save-excursion
(goto-char (process-mark proc))
(insert-before-markers string))
(goto-char gds-read-cursor)
(while (let ((form (condition-case nil
(read (current-buffer))
(error nil))))
(if form
(save-excursion
(funcall gds-protocol-handler (car form) (cdr form))))
form)
(setq gds-read-cursor (point)))))
;; Subprocess sentinel: do nothing. (Currently just here to avoid
;; inserting un-`read'able process status messages into the process
;; buffer.)
(defun gds-sentinel (proc event)
)
;;;; The end!
(provide 'gds-server)
;;; gds-server.el ends here.

629
emacs/gds.el Normal file
View file

@ -0,0 +1,629 @@
;;; gds.el -- frontend for Guile development in Emacs
;;;; 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
; TODO:
; ?transcript
; scheme-mode menu
; interrupt/sigint/async-break
; (module browsing)
; load file
; doing common protocol from debugger
; thread override for debugging
;;;; Prerequisites.
(require 'scheme)
(require 'cl)
(require 'gds-server)
(require 'gds-scheme)
;; The subprocess object for the debug server.
(defvar gds-debug-server nil)
(defvar gds-socket-type-alist '((tcp . 8333)
(unix . "/tmp/.gds_socket"))
"Maps each of the possible socket types that the GDS server can
listen on to the path that it should bind to for each one.")
(defun gds-run-debug-server ()
"Start (or restart, if already running) the GDS debug server process."
(interactive)
(if gds-debug-server (gds-kill-debug-server))
(setq gds-debug-server
(gds-start-server "gds-debug"
(cdr (assq gds-server-socket-type
gds-socket-type-alist))
'gds-debug-protocol))
(process-kill-without-query gds-debug-server))
(defun gds-kill-debug-server ()
"Kill the GDS debug server process."
(interactive)
(mapcar (function gds-client-gone)
(mapcar (function car) gds-client-info))
(condition-case nil
(progn
(kill-process gds-debug-server)
(accept-process-output gds-debug-server 0 200))
(error))
(setq gds-debug-server nil))
;; Send input to the subprocess.
(defun gds-send (string client)
(with-current-buffer (get-buffer-create "*GDS Transcript*")
(goto-char (point-max))
(insert (number-to-string client) ": (" string ")\n"))
(gds-client-put client 'thread-id nil)
(gds-show-client-status client gds-running-text)
(process-send-string gds-debug-server (format "(%S %s)\n" client string)))
;;;; Per-client information
(defun gds-client-put (client property value)
(let ((client-info (assq client gds-client-info)))
(if client-info
(let ((prop-info (memq property client-info)))
(if prop-info
(setcar (cdr prop-info) value)
(setcdr client-info
(list* property value (cdr client-info)))))
(setq gds-client-info
(cons (list client property value) gds-client-info)))))
(defun gds-client-get (client property)
(let ((client-info (assq client gds-client-info)))
(and client-info
(cadr (memq property client-info)))))
(defvar gds-client-info '())
(defun gds-get-client-buffer (client)
(let ((existing-buffer (gds-client-get client 'stack-buffer)))
(if (and existing-buffer
(buffer-live-p existing-buffer))
existing-buffer
(let ((new-buffer (generate-new-buffer (gds-client-get client 'name))))
(with-current-buffer new-buffer
(gds-debug-mode)
(setq gds-client client)
(setq gds-stack nil))
(gds-client-put client 'stack-buffer new-buffer)
new-buffer))))
(defun gds-client-gone (client &rest ignored)
;; Kill the client's stack buffer, if it has one.
(let ((stack-buffer (gds-client-get client 'stack-buffer)))
(if (and stack-buffer
(buffer-live-p stack-buffer))
(kill-buffer stack-buffer)))
;; Dissociate all the client's associated buffers.
(mapcar (function (lambda (buffer)
(if (buffer-live-p buffer)
(with-current-buffer buffer
(gds-dissociate-buffer)))))
(copy-sequence (gds-client-get client 'associated-buffers)))
;; Remove this client's record from gds-client-info.
(setq gds-client-info (delq (assq client gds-client-info) gds-client-info)))
(defvar gds-client nil)
(make-variable-buffer-local 'gds-client)
(defvar gds-stack nil)
(make-variable-buffer-local 'gds-stack)
(defvar gds-tweaking nil)
(make-variable-buffer-local 'gds-tweaking)
(defvar gds-selected-frame-index nil)
(make-variable-buffer-local 'gds-selected-frame-index)
;;;; Debugger protocol
(defun gds-debug-protocol (client form)
(or (eq client '*)
(let ((proc (car form)))
(cond ((eq proc 'name)
;; (name ...) - client name.
(gds-client-put client 'name (caddr form)))
((eq proc 'stack)
;; (stack ...) - stack information.
(with-current-buffer (gds-get-client-buffer client)
(setq gds-stack (cddr form))
(setq gds-tweaking (memq 'instead (cadr gds-stack)))
(setq gds-selected-frame-index (cadr form))
(gds-display-stack)))
((eq proc 'closed)
;; (closed) - client has gone/died.
(gds-client-gone client))
((eq proc 'eval-result)
;; (eval-result RESULT) - result of evaluation.
(if gds-last-eval-result
(message "%s" (cadr form))
(setq gds-last-eval-result (cadr form))))
((eq proc 'info-result)
;; (info-result RESULT) - info about selected frame.
(message "%s" (cadr form)))
((eq proc 'thread-id)
;; (thread-id THREAD) - says which client thread is reading.
(let ((thread-id (cadr form))
(debug-thread-id (gds-client-get client 'debug-thread-id)))
(if (and debug-thread-id
(/= thread-id debug-thread-id))
;; Tell the newly reading thread to go away.
(gds-send "dismiss" client)
;; Either there's no current debug-thread-id, or
;; the thread now reading is the debug thread.
(if debug-thread-id
(progn
;; Reset the debug-thread-id.
(gds-client-put client 'debug-thread-id nil)
;; Indicate debug status in modelines.
(gds-show-client-status client gds-debug-text))
;; Indicate normal read status in modelines..
(gds-show-client-status client gds-ready-text)))))
((eq proc 'debug-thread-id)
;; (debug-thread-id THREAD) - debug override indication.
(gds-client-put client 'debug-thread-id (cadr form))
;; If another thread is already reading, send it away.
(if (gds-client-get client 'thread-id)
(gds-send "dismiss" client)))
(t
;; Non-debug-specific protocol.
(gds-nondebug-protocol client proc (cdr form)))))))
;;;; Displaying a stack
(define-derived-mode gds-debug-mode
scheme-mode
"Guile-Debug"
"Major mode for debugging a Guile client application."
(use-local-map gds-mode-map))
(defun gds-display-stack-first-line ()
(let ((flags (cadr gds-stack)))
(cond ((memq 'application flags)
(insert "Calling procedure:\n"))
((memq 'evaluation flags)
(insert "Evaluating expression"
(cond ((stringp gds-tweaking) (format " (tweaked: %s)"
gds-tweaking))
(gds-tweaking " (tweakable)")
(t ""))
":\n"))
((memq 'return flags)
(let ((value (cadr (memq 'return flags))))
(while (string-match "\n" value)
(setq value (replace-match "\\n" nil t value)))
(insert "Return value"
(cond ((stringp gds-tweaking) (format " (tweaked: %s)"
gds-tweaking))
(gds-tweaking " (tweakable)")
(t ""))
": " value "\n")))
((memq 'error flags)
(let ((value (cadr (memq 'error flags))))
(while (string-match "\n" value)
(setq value (replace-match "\\n" nil t value)))
(insert "Error: " value "\n")))
(t
(insert "Stack: " (prin1-to-string flags) "\n")))))
(defun gds-display-stack ()
(if gds-undisplay-timer
(cancel-timer gds-undisplay-timer))
(setq gds-undisplay-timer nil)
;(setq buffer-read-only nil)
(mapcar 'delete-overlay
(overlays-in (point-min) (point-max)))
(erase-buffer)
(gds-display-stack-first-line)
(let ((frames (car gds-stack)))
(while frames
(let ((frame-text (cadr (car frames)))
(frame-source (caddr (car frames))))
(while (string-match "\n" frame-text)
(setq frame-text (replace-match "\\n" nil t frame-text)))
(insert " "
(if frame-source "s" " ")
frame-text
"\n"))
(setq frames (cdr frames))))
;(setq buffer-read-only t)
(gds-show-selected-frame))
(defun gds-tweak (expr)
(interactive "sTweak expression or return value: ")
(or gds-tweaking
(error "The current stack cannot be tweaked"))
(setq gds-tweaking
(if (> (length expr) 0)
expr
t))
(save-excursion
(goto-char (point-min))
(delete-region (point) (progn (forward-line 1) (point)))
(gds-display-stack-first-line)))
(defvar gds-undisplay-timer nil)
(make-variable-buffer-local 'gds-undisplay-timer)
(defvar gds-undisplay-wait 1)
(defun gds-undisplay-buffer ()
(if gds-undisplay-timer
(cancel-timer gds-undisplay-timer))
(setq gds-undisplay-timer
(run-at-time gds-undisplay-wait
nil
(function kill-buffer)
(current-buffer))))
(defun gds-show-selected-frame ()
(setq gds-local-var-cache nil)
(goto-char (point-min))
(forward-line (+ gds-selected-frame-index 1))
(delete-char 3)
(insert "=> ")
(beginning-of-line)
(gds-show-selected-frame-source (caddr (nth gds-selected-frame-index
(car gds-stack)))))
(defun gds-unshow-selected-frame ()
(if gds-frame-source-overlay
(move-overlay gds-frame-source-overlay 0 0))
(save-excursion
(goto-char (point-min))
(forward-line (+ gds-selected-frame-index 1))
(delete-char 3)
(insert " ")))
;; Overlay used to highlight the source expression corresponding to
;; the selected frame.
(defvar gds-frame-source-overlay nil)
(defcustom gds-source-file-name-transforms nil
"Alist of regexps and substitutions for transforming Scheme source
file names. Each element in the alist is (REGEXP . SUBSTITUTION).
Each source file name in a Guile backtrace is compared against each
REGEXP in turn until the first one that matches, then `replace-match'
is called with SUBSTITUTION to transform that file name.
This mechanism targets the situation where you are working on a Guile
application and want to install it, in /usr/local say, before each
test run. In this situation, even though Guile is reading your Scheme
files from /usr/local/share/guile, you probably want Emacs to pop up
the corresponding files from your working codebase instead. Therefore
you would add an element to this alist to transform
\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"."
:type '(alist :key-type regexp :value-type string)
:group 'gds)
(defun gds-show-selected-frame-source (source)
;; Highlight the frame source, if possible.
(if source
(let ((filename (car source))
(client gds-client)
(transforms gds-source-file-name-transforms))
;; Apply possible transforms to the source file name.
(while transforms
(if (string-match (caar transforms) filename)
(let ((trans-fn (replace-match (cdar transforms)
t nil filename)))
(if (file-readable-p trans-fn)
(setq filename trans-fn
transforms nil))))
(setq transforms (cdr transforms)))
;; Try to map the (possibly transformed) source file to a
;; buffer.
(let ((source-buffer (gds-source-file-name-to-buffer filename)))
(if source-buffer
(with-current-buffer source-buffer
(if gds-frame-source-overlay
nil
(setq gds-frame-source-overlay (make-overlay 0 0))
(overlay-put gds-frame-source-overlay 'face 'highlight)
(overlay-put gds-frame-source-overlay
'help-echo
(function gds-show-local-var)))
;; Move to source line. Note that Guile line numbering
;; is 0-based, while Emacs numbering is 1-based.
(save-restriction
(widen)
(goto-line (+ (cadr source) 1))
(move-to-column (caddr source))
(move-overlay gds-frame-source-overlay
(point)
(if (not (looking-at ")"))
(save-excursion (forward-sexp 1) (point))
;; It seems that the source
;; coordinates for backquoted
;; expressions are at the end of the
;; sexp rather than the beginning...
(save-excursion (forward-char 1)
(backward-sexp 1) (point)))
(current-buffer)))
;; Record that this source buffer has been touched by a
;; GDS client process.
(setq gds-last-touched-by client))
(message "Source for this frame cannot be shown: %s:%d:%d"
filename
(cadr source)
(caddr source)))))
(message "Source for this frame was not recorded"))
(gds-display-buffers))
(defvar gds-local-var-cache nil)
(defun gds-show-local-var (window overlay position)
(let ((frame-index gds-selected-frame-index)
(client gds-client))
(with-current-buffer (overlay-buffer overlay)
(save-excursion
(goto-char position)
(let ((gds-selected-frame-index frame-index)
(gds-client client)
(varname (thing-at-point 'symbol))
(state (parse-partial-sexp (overlay-start overlay) (point))))
(when (and gds-selected-frame-index
gds-client
varname
(not (or (nth 3 state)
(nth 4 state))))
(set-text-properties 0 (length varname) nil varname)
(let ((existing (assoc varname gds-local-var-cache)))
(if existing
(cdr existing)
(gds-evaluate varname)
(setq gds-last-eval-result nil)
(while (not gds-last-eval-result)
(accept-process-output gds-debug-server))
(setq gds-local-var-cache
(cons (cons varname gds-last-eval-result)
gds-local-var-cache))
gds-last-eval-result))))))))
(defun gds-source-file-name-to-buffer (filename)
;; See if filename begins with gds-emacs-buffer-port-name-prefix.
(if (string-match (concat "^"
(regexp-quote gds-emacs-buffer-port-name-prefix))
filename)
;; It does, so get the named buffer.
(get-buffer (substring filename (match-end 0)))
;; It doesn't, so treat as a file name.
(and (file-readable-p filename)
(find-file-noselect filename))))
(defun gds-select-stack-frame (&optional frame-index)
(interactive)
(let ((new-frame-index (or frame-index
(gds-current-line-frame-index))))
(or (and (>= new-frame-index 0)
(< new-frame-index (length (car gds-stack))))
(error (if frame-index
"No more frames in this direction"
"No frame here")))
(gds-unshow-selected-frame)
(setq gds-selected-frame-index new-frame-index)
(gds-show-selected-frame)))
(defun gds-up ()
(interactive)
(gds-select-stack-frame (- gds-selected-frame-index 1)))
(defun gds-down ()
(interactive)
(gds-select-stack-frame (+ gds-selected-frame-index 1)))
(defun gds-current-line-frame-index ()
(- (count-lines (point-min)
(save-excursion
(beginning-of-line)
(point)))
1))
(defun gds-display-buffers ()
(let ((buf (current-buffer)))
;; If there's already a window showing the buffer, use it.
(let ((window (get-buffer-window buf t)))
(if window
(progn
(make-frame-visible (window-frame window))
(select-window window))
(switch-to-buffer buf)
(setq window (get-buffer-window buf t))))
;; If there is an associated source buffer, display it as well.
(if (and gds-frame-source-overlay
(overlay-end gds-frame-source-overlay)
(> (overlay-end gds-frame-source-overlay) 1))
(progn
(delete-other-windows)
(let ((window (display-buffer
(overlay-buffer gds-frame-source-overlay))))
(set-window-point window
(overlay-start gds-frame-source-overlay)))))))
;;;; Debugger commands.
;; Typically but not necessarily used from the `stack' view.
(defun gds-send-tweaking ()
(if (stringp gds-tweaking)
(gds-send (format "tweak %S" gds-tweaking) gds-client)))
(defun gds-go ()
(interactive)
(gds-send-tweaking)
(gds-send "continue" gds-client)
(gds-unshow-selected-frame)
(gds-undisplay-buffer))
(defvar gds-last-eval-result t)
(defun gds-evaluate (expr)
(interactive "sEvaluate variable or expression: ")
(gds-send (format "evaluate %d %s"
gds-selected-frame-index
(prin1-to-string expr))
gds-client))
(defun gds-frame-info ()
(interactive)
(gds-send (format "info-frame %d" gds-selected-frame-index)
gds-client))
(defun gds-frame-args ()
(interactive)
(gds-send (format "info-args %d" gds-selected-frame-index)
gds-client))
(defun gds-proc-source ()
(interactive)
(gds-send (format "proc-source %d" gds-selected-frame-index)
gds-client))
(defun gds-traps-here ()
(interactive)
(gds-send "traps-here" gds-client))
(defun gds-step-into ()
(interactive)
(gds-send-tweaking)
(gds-send (format "step-into %d" gds-selected-frame-index)
gds-client)
(gds-unshow-selected-frame)
(gds-undisplay-buffer))
(defun gds-step-over ()
(interactive)
(gds-send-tweaking)
(gds-send (format "step-over %d" gds-selected-frame-index)
gds-client)
(gds-unshow-selected-frame)
(gds-undisplay-buffer))
(defun gds-step-file ()
(interactive)
(gds-send-tweaking)
(gds-send (format "step-file %d" gds-selected-frame-index)
gds-client)
(gds-unshow-selected-frame)
(gds-undisplay-buffer))
;;;; Guile Interaction mode keymap and menu items.
(defvar gds-mode-map (make-sparse-keymap))
(define-key gds-mode-map "c" (function gds-go))
(define-key gds-mode-map "g" (function gds-go))
(define-key gds-mode-map "q" (function gds-go))
(define-key gds-mode-map "e" (function gds-evaluate))
(define-key gds-mode-map "I" (function gds-frame-info))
(define-key gds-mode-map "A" (function gds-frame-args))
(define-key gds-mode-map "S" (function gds-proc-source))
(define-key gds-mode-map "T" (function gds-traps-here))
(define-key gds-mode-map "\C-m" (function gds-select-stack-frame))
(define-key gds-mode-map "u" (function gds-up))
(define-key gds-mode-map [up] (function gds-up))
(define-key gds-mode-map "\C-p" (function gds-up))
(define-key gds-mode-map "d" (function gds-down))
(define-key gds-mode-map [down] (function gds-down))
(define-key gds-mode-map "\C-n" (function gds-down))
(define-key gds-mode-map " " (function gds-step-file))
(define-key gds-mode-map "i" (function gds-step-into))
(define-key gds-mode-map "o" (function gds-step-over))
(define-key gds-mode-map "t" (function gds-tweak))
(defvar gds-menu nil
"Global menu for GDS commands.")
(if nil;gds-menu
nil
(setq gds-menu (make-sparse-keymap "Guile-Debug"))
(define-key gds-menu [traps-here]
'(menu-item "Show Traps Here" gds-traps-here))
(define-key gds-menu [proc-source]
'(menu-item "Show Procedure Source" gds-proc-source))
(define-key gds-menu [frame-args]
'(menu-item "Show Frame Args" gds-frame-args))
(define-key gds-menu [frame-info]
'(menu-item "Show Frame Info" gds-frame-info))
(define-key gds-menu [separator-1]
'("--"))
(define-key gds-menu [evaluate]
'(menu-item "Evaluate..." gds-evaluate))
(define-key gds-menu [separator-2]
'("--"))
(define-key gds-menu [down]
'(menu-item "Move Down A Frame" gds-down))
(define-key gds-menu [up]
'(menu-item "Move Up A Frame" gds-up))
(define-key gds-menu [separator-3]
'("--"))
(define-key gds-menu [step-over]
'(menu-item "Step Over Current Expression" gds-step-over))
(define-key gds-menu [step-into]
'(menu-item "Step Into Current Expression" gds-step-into))
(define-key gds-menu [step-file]
'(menu-item "Step Through Current Source File" gds-step-file))
(define-key gds-menu [separator-4]
'("--"))
(define-key gds-menu [go]
'(menu-item "Go [continue execution]" gds-go))
(define-key gds-mode-map [menu-bar gds-debug]
(cons "Guile-Debug" gds-menu)))
;;;; Autostarting the GDS server.
(defcustom gds-autorun-debug-server t
"Whether to automatically run the GDS server when `gds.el' is loaded."
:type 'boolean
:group 'gds)
(defcustom gds-server-socket-type 'tcp
"What kind of socket the GDS server should listen on."
:group 'gds
:type '(choice (const :tag "TCP" tcp)
(const :tag "Unix" unix)))
;;;; If requested, autostart the server after loading.
(if (and gds-autorun-debug-server
(not gds-debug-server))
(gds-run-debug-server))
;;;; The end!
(provide 'gds)
;;; gds.el ends here.

10
ice-9/ChangeLog
View file

@ -1,3 +1,13 @@
2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
* debugging/Makefile.am, debugging/example-fns.scm,
debugging/ice-9-debugger-extensions.scm, debugging/steps.scm,
debugging/trace.scm, debugging/traps.scm, debugging/trc.scm: New
(merged with modifications from CVS HEAD).
* gds-client.scm, gds-server.scm: New (merged with modifications
from CVS HEAD).
2008-02-22 Ludovic Courtès <ludo@gnu.org>
* match.scm: Export `match:andmap'. This fixes evaluation of

33
ice-9/debugging/Makefile.am Normal file
View file

@ -0,0 +1,33 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as
## published by the Free Software Foundation; either version 2, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
ice9_debugging_sources = example-fns.scm \
ice-9-debugger-extensions.scm \
steps.scm trace.scm traps.scm trc.scm
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging
subpkgdata_DATA = $(ice9_debugging_sources)
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(ice9_debugging_sources)

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

@ -0,0 +1,17 @@
(define-module (ice-9 debugging example-fns)
#:export (fact1 fact2 facti))
(define (fact1 n)
(if (= n 0)
1
(* n (fact1 (- n 1)))))
(define (facti n a)
(if (= n 0)
a
(facti (- n 1) (* a n))))
(define (fact2 n)
(facti n 1))
; Test: (fact2 3)

169
ice-9/debugging/ice-9-debugger-extensions.scm Normal file
View file

@ -0,0 +1,169 @@
(define-module (ice-9 debugging ice-9-debugger-extensions)
#:use-module (ice-9 debugger))
;;; Upgrade the debugger state object so that it can carry a flag
;;; indicating whether the debugging session is continuable.
(cond ((string>=? (version) "1.7")
(use-modules (ice-9 debugger state))
(define-module (ice-9 debugger state)))
(else
(define-module (ice-9 debugger))))
(set! state-rtd (make-record-type "debugger-state" '(stack index flags)))
(set! state? (record-predicate state-rtd))
(set! make-state
(let ((make-state-internal (record-constructor state-rtd
'(stack index flags))))
(lambda (stack index . flags)
(make-state-internal stack index flags))))
(set! state-stack (record-accessor state-rtd 'stack))
(set! state-index (record-accessor state-rtd 'index))
(define state-flags (record-accessor state-rtd 'flags))
;;; Add commands that (ice-9 debugger) doesn't currently have, for
;;; continuing or single stepping program execution.
(cond ((string>=? (version) "1.7")
(use-modules (ice-9 debugger command-loop))
(define-module (ice-9 debugger command-loop))
(define new-define-command define-command)
(set! define-command
(lambda (name argument-template documentation procedure)
(new-define-command name argument-template procedure))))
(else
(define-module (ice-9 debugger))))
(use-modules (ice-9 debugging steps))
(define (assert-continuable state)
;; Check that debugger is in a state where `continuing' makes sense.
;; If not, signal an error.
(or (memq #:continuable (state-flags state))
(user-error "This debug session is not continuable.")))
(define (debugger:continue state)
"Tell the program being debugged to continue running. (In fact this is
the same as the @code{quit} command, because it exits the debugger
command loop and so allows whatever code it was that invoked the
debugger to continue.)"
(assert-continuable state)
(throw 'exit-debugger))
(define (debugger:finish state)
"Continue until evaluation of the current frame is complete, and
print the result obtained."
(assert-continuable state)
(at-exit (- (stack-length (state-stack state))
(state-index state))
(list trace-trap debug-trap))
(debugger:continue state))
(define (debugger:step state n)
"Tell the debugged program to do @var{n} more steps from its current
position. One @dfn{step} means executing until the next frame entry
or exit of any kind. @var{n} defaults to 1."
(assert-continuable state)
(at-step debug-trap (or n 1))
(debugger:continue state))
(define (debugger:next state n)
"Tell the debugged program to do @var{n} more steps from its current
position, but only counting frame entries and exits where the
corresponding source code comes from the same file as the current
stack frame. (See @ref{Step Traps} for the details of how this
works.) If the current stack frame has no source code, the effect of
this command is the same as of @code{step}. @var{n} defaults to 1."
(assert-continuable state)
(at-step debug-trap
(or n 1)
(frame-file-name (stack-ref (state-stack state)
(state-index state)))
(if (memq #:return (state-flags state))
#f
(- (stack-length (state-stack state)) (state-index state))))
(debugger:continue state))
(define-command "continue" '()
"Continue program execution."
debugger:continue)
(define-command "finish" '()
"Continue until evaluation of the current frame is complete, and
print the result obtained."
debugger:finish)
(define-command "step" '('optional exact-integer)
"Continue until entry to @var{n}th next frame."
debugger:step)
(define-command "next" '('optional exact-integer)
"Continue until entry to @var{n}th next frame in same file."
debugger:next)
;;; Export a couple of procedures for use by (ice-9 debugging trace).
(cond ((string>=? (version) "1.7"))
(else
(define-module (ice-9 debugger))
(export write-frame-short/expression
write-frame-short/application)))
;;; Provide a `debug-trap' entry point in (ice-9 debugger). This is
;;; designed so that it can be called to explore the stack at a
;;; breakpoint, and to single step from the breakpoint.
(define-module (ice-9 debugger))
(use-modules (ice-9 debugging traps))
(define *not-yet-introduced* #t)
(cond ((string>=? (version) "1.7"))
(else
(define (debugger-command-loop state)
(read-and-dispatch-commands state (current-input-port)))))
(define-public (debug-trap trap-context)
"Invoke the Guile debugger to explore the stack at the specified @var{trap}."
(start-stack 'debugger
(let* ((stack (tc:stack trap-context))
(flags1 (let ((trap-type (tc:type trap-context)))
(case trap-type
((#:return #:error)
(list trap-type
(tc:return-value trap-context)))
(else
(list trap-type)))))
(flags (if (tc:continuation trap-context)
(cons #:continuable flags1)
flags1))
(state (apply make-state stack 0 flags)))
(if *not-yet-introduced*
(let ((ssize (stack-length stack)))
(display "This is the Guile debugger -- for help, type `help'.\n")
(set! *not-yet-introduced* #f)
(if (= ssize 1)
(display "There is 1 frame on the stack.\n\n")
(format #t "There are ~A frames on the stack.\n\n" ssize))))
(write-state-short-with-source-location state)
(debugger-command-loop state))))
(define write-state-short-with-source-location
(cond ((string>=? (version) "1.7")
write-state-short)
(else
(lambda (state)
(let* ((frame (stack-ref (state-stack state) (state-index state)))
(source (frame-source frame))
(position (and source (source-position source))))
(format #t "Frame ~A at " (frame-number frame))
(if position
(display-position position)
(display "unknown source location"))
(newline)
(write-char #\tab)
(write-frame-short frame)
(newline))))))

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

@ -0,0 +1,106 @@
;;;; (ice-9 debugging steps) -- stepping through code from the debugger
;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugging steps)
#:use-module (ice-9 debugging traps)
#:use-module (ice-9 and-let-star)
#:use-module (ice-9 debugger)
#:use-module (ice-9 optargs)
#:export (at-exit
at-entry
at-apply
at-step
at-next))
;;; at-exit DEPTH BEHAVIOUR
;;;
;;; Install a behaviour to run when we exit the current frame.
(define (at-exit depth behaviour)
(install-trap (make <exit-trap>
#:depth depth
#:single-shot #t
#:behaviour behaviour)))
;;; at-entry BEHAVIOUR [COUNT]
;;;
;;; Install a behaviour to run when we get to the COUNT'th next frame
;;; entry. COUNT defaults to 1.
(define* (at-entry behaviour #:optional (count 1))
(install-trap (make <entry-trap>
#:skip-count (- count 1)
#:single-shot #t
#:behaviour behaviour)))
;;; at-apply BEHAVIOUR [COUNT]
;;;
;;; Install a behaviour to run when we get to the COUNT'th next
;;; application. COUNT defaults to 1.
(define* (at-apply behaviour #:optional (count 1))
(install-trap (make <apply-trap>
#:skip-count (- count 1)
#:single-shot #t
#:behaviour behaviour)))
;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]]
;;;
;;; Install BEHAVIOUR to run on the COUNT'th next application, frame
;;; entry or frame exit. COUNT defaults to 1. If FILENAME is
;;; specified and not #f, only frames that begin in the named file are
;;; counted.
(define* (at-step behaviour #:optional (count 1) filename (depth 1000))
(install-trap (make <step-trap>
#:file-name filename
#:exit-depth depth
#:skip-count (- count 1)
#:single-shot #t
#:behaviour behaviour)))
;; (or count (set! count 1))
;; (letrec ((proc (lambda (trap-context)
;; ;; Behaviour whenever we enter or exit a frame.
;; (set! count (- count 1))
;; (if (= count 0)
;; (begin
;; (remove-enter-frame-hook! step)
;; (remove-apply-frame-hook! step)
;; (behaviour trap-context)))))
;; (step (lambda (trap-context)
;; ;; Behaviour on frame entry: both execute the above
;; ;; and install it as an exit hook.
;; (if (or (not filename)
;; (equal? (frame-file-name (tc:frame trap-context))
;; filename))
;; (begin
;; (proc trap-context)
;; (at-exit (tc:depth trap-context) proc))))))
;; (at-exit depth proc)
;; (add-enter-frame-hook! step)
;; (add-apply-frame-hook! step)))
;;; at-next BEHAVIOUR [COUNT]
;;;
;;; Install a behaviour to run when we get to the COUNT'th next frame
;;; entry in the same source file as the current location. COUNT
;;; defaults to 1. If the current location has no filename, fall back
;;; silently to `at-entry' behaviour.
;;; (ice-9 debugging steps) ends here.

157
ice-9/debugging/trace.scm Normal file
View file

@ -0,0 +1,157 @@
;;;; (ice-9 debugging trace) -- breakpoint trace behaviour
;;; Copyright (C) 2002 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugging trace)
#:use-module (ice-9 debug)
#:use-module (ice-9 debugger)
#:use-module (ice-9 debugging ice-9-debugger-extensions)
#:use-module (ice-9 debugging steps)
#:use-module (ice-9 debugging traps)
#:export (trace-trap
trace-port
set-trace-layout
trace/pid
trace/stack-id
trace/stack-depth
trace/stack-real-depth
trace/stack
trace/source-file-name
trace/source-line
trace/source-column
trace/source
trace/type
trace/real?
trace/info
trace-at-exit
trace-until-exit))
(cond ((string>=? (version) "1.7")
(use-modules (ice-9 debugger utils))))
(define trace-format-string #f)
(define trace-arg-procs #f)
(define (set-trace-layout format-string . arg-procs)
(set! trace-format-string format-string)
(set! trace-arg-procs arg-procs))
(define (trace/pid trap-context)
(getpid))
(define (trace/stack-id trap-context)
(stack-id (tc:stack trap-context)))
(define (trace/stack-depth trap-context)
(tc:depth trap-context))
(define (trace/stack-real-depth trap-context)
(tc:real-depth trap-context))
(define (trace/stack trap-context)
(format #f "~a:~a+~a"
(stack-id (tc:stack trap-context))
(tc:real-depth trap-context)
(- (tc:depth trap-context) (tc:real-depth trap-context))))
(define (trace/source-file-name trap-context)
(cond ((frame->source-position (tc:frame trap-context)) => car)
(else "")))
(define (trace/source-line trap-context)
(cond ((frame->source-position (tc:frame trap-context)) => cadr)
(else 0)))
(define (trace/source-column trap-context)
(cond ((frame->source-position (tc:frame trap-context)) => caddr)
(else 0)))
(define (trace/source trap-context)
(cond ((frame->source-position (tc:frame trap-context))
=>
(lambda (pos)
(format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
(else "")))
(define (trace/type trap-context)
(case (tc:type trap-context)
((#:application) "APP")
((#:evaluation) "EVA")
((#:return) "RET")
((#:error) "ERR")
(else "???")))
(define (trace/real? trap-context)
(if (frame-real? (tc:frame trap-context)) " " "t"))
(define (trace/info trap-context)
(with-output-to-string
(lambda ()
(if (memq (tc:type trap-context) '(#:application #:evaluation))
((if (tc:expression trap-context)
write-frame-short/expression
write-frame-short/application) (tc:frame trap-context))
(begin
(display "=>")
(write (tc:return-value trap-context)))))))
(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info)
;;; trace-trap
;;;
;;; Trace the current location, and install a hook to trace the return
;;; value when we exit the current frame.
(define (trace-trap trap-context)
(apply format
(trace-port)
trace-format-string
(map (lambda (arg-proc)
(arg-proc trap-context))
trace-arg-procs)))
(set! (behaviour-ordering trace-trap) 50)
;;; trace-port
;;;
;;; The port to which trace information is printed.
(define trace-port
(let ((port (current-output-port)))
(make-procedure-with-setter
(lambda () port)
(lambda (new) (set! port new)))))
;;; trace-at-exit
;;;
;;; Trace return value on exit from the current frame.
(define (trace-at-exit trap-context)
(at-exit (tc:depth trap-context) trace-trap))
;;; trace-until-exit
;;;
;;; Trace absolutely everything until exit from the current frame.
(define (trace-until-exit trap-context)
(let ((step-trap (make <step-trap> #:behaviour trace-trap)))
(install-trap step-trap)
(at-exit (tc:depth trap-context)
(lambda (trap-context)
(uninstall-trap step-trap)))))
;;; (ice-9 debugging trace) ends here.

1037
ice-9/debugging/traps.scm Executable file
View file

File diff suppressed because it is too large Load diff

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

@ -0,0 +1,63 @@
;;;; (ice-9 debugging trc) -- tracing for Guile debugger code
;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(define-module (ice-9 debugging trc)
#:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
(define *syms* #f)
(define (trc-set! syms)
(set! *syms* syms))
(define (trc-syms . syms)
(trc-set! syms))
(define (trc-all)
(trc-set! #f))
(define (trc-none)
(trc-set! '()))
(define (trc-add sym)
(trc-set! (cons sym *syms*)))
(define (trc-remove sym)
(trc-set! (delq1! sym *syms*)))
(define (trc sym . args)
(if (or (not *syms*)
(memq sym *syms*))
(let ((port (trc-port)))
(write sym port)
(display ":" port)
(for-each (lambda (arg)
(display " " port)
(write arg port))
args)
(newline port))))
(define trc-port
(let ((port (current-error-port)))
(make-procedure-with-setter
(lambda () port)
(lambda (p) (set! port p)))))
;; Default to no tracing.
(trc-none)
;;; (ice-9 debugging trc) ends here.

584
ice-9/gds-client.scm Executable file
View file

@ -0,0 +1,584 @@
(define-module (ice-9 gds-client)
#:use-module (oop goops)
#:use-module (oop goops describe)
#:use-module (ice-9 debugging trace)
#:use-module (ice-9 debugging traps)
#:use-module (ice-9 debugging trc)
#:use-module (ice-9 debugging steps)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 regex)
#:use-module (ice-9 session)
#:use-module (ice-9 string-fun)
#:export (gds-debug-trap
run-utility
gds-accept-input))
(cond ((string>=? (version) "1.7")
(use-modules (ice-9 debugger utils)))
(else
(define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
(module-export! the-ice-9-debugger-module
'(source-position
write-frame-short/application
write-frame-short/expression
write-frame-args-long
write-frame-long))))
(use-modules (ice-9 debugger))
(define gds-port #f)
;; Return an integer that somehow identifies the current thread.
(define (get-thread-id)
(let ((root (dynamic-root)))
(cond ((integer? root)
root)
((pair? root)
(object-address root))
(else
(error "Unexpected dynamic root:" root)))))
;; gds-debug-read is a high-priority read. The (debug-thread-id ID)
;; form causes the frontend to dismiss any reads from threads whose id
;; is not ID, until it receives the (thread-id ...) form with the same
;; id as ID. Dismissing the reads of any other threads (by sending a
;; form that is otherwise ignored) causes those threads to release the
;; read mutex, which allows the (gds-read) here to proceed.
(define (gds-debug-read)
(write-form `(debug-thread-id ,(get-thread-id)))
(gds-read))
(define (gds-debug-trap trap-context)
"Invoke the GDS debugger to explore the stack at the specified trap."
(connect-to-gds)
(start-stack 'debugger
(let* ((stack (tc:stack trap-context))
(flags1 (let ((trap-type (tc:type trap-context)))
(case trap-type
((#:return #:error)
(list trap-type
(tc:return-value trap-context)))
(else
(list trap-type)))))
(flags (if (tc:continuation trap-context)
(cons #:continuable flags1)
flags1))
(fired-traps (tc:fired-traps trap-context))
(special-index (and (= (length fired-traps) 1)
(is-a? (car fired-traps) <exit-trap>)
(eq? (tc:type trap-context) #:return)
(- (tc:depth trap-context)
(slot-ref (car fired-traps) 'depth)))))
;; Write current stack to the frontend.
(write-form (list 'stack
(or special-index 0)
(stack->emacs-readable stack)
(append (flags->emacs-readable flags)
(slot-ref trap-context
'handler-return-syms))))
;; Now wait for instruction.
(let loop ((protocol (gds-debug-read)))
;; Act on it.
(case (car protocol)
((tweak)
;; Request to tweak the handler return value.
(let ((tweaking (catch #t
(lambda ()
(list (with-input-from-string
(cadr protocol)
read)))
(lambda ignored #f))))
(if tweaking
(slot-set! trap-context
'handler-return-value
(cons 'instead (car tweaking)))))
(loop (gds-debug-read)))
((continue)
;; Continue (by exiting the debugger).
*unspecified*)
((evaluate)
;; Evaluate expression in specified frame.
(eval-in-frame stack (cadr protocol) (caddr protocol))
(loop (gds-debug-read)))
((info-frame)
;; Return frame info.
(let ((frame (stack-ref stack (cadr protocol))))
(write-form (list 'info-result
(with-output-to-string
(lambda ()
(write-frame-long frame))))))
(loop (gds-debug-read)))
((info-args)
;; Return frame args.
(let ((frame (stack-ref stack (cadr protocol))))
(write-form (list 'info-result
(with-output-to-string
(lambda ()
(write-frame-args-long frame))))))
(loop (gds-debug-read)))
((proc-source)
;; Show source of application procedure.
(let* ((frame (stack-ref stack (cadr protocol)))
(proc (frame-procedure frame))
(source (and proc (procedure-source proc))))
(write-form (list 'info-result
(if source
(sans-surrounding-whitespace
(with-output-to-string
(lambda ()
(pretty-print source))))
(if proc
"This procedure is coded in C"
"This frame has no procedure")))))
(loop (gds-debug-read)))
((traps-here)
;; Show the traps that fired here.
(write-form (list 'info-result
(with-output-to-string
(lambda ()
(for-each describe
(tc:fired-traps trap-context))))))
(loop (gds-debug-read)))
((step-into)
;; Set temporary breakpoint on next trap.
(at-step gds-debug-trap
1
#f
(if (memq #:return flags)
#f
(- (stack-length stack)
(cadr protocol)))))
((step-over)
;; Set temporary breakpoint on exit from
;; specified frame.
(at-exit (- (stack-length stack) (cadr protocol))
gds-debug-trap))
((step-file)
;; Set temporary breakpoint on next trap in same
;; source file.
(at-step gds-debug-trap
1
(frame-file-name (stack-ref stack
(cadr protocol)))
(if (memq #:return flags)
#f
(- (stack-length stack)
(cadr protocol)))))
(else
(safely-handle-nondebug-protocol protocol)
(loop (gds-debug-read))))))))
(define (connect-to-gds . application-name)
(or gds-port
(begin
(set! gds-port
(or (let ((s (socket PF_INET SOCK_STREAM 0))
(SOL_TCP 6)
(TCP_NODELAY 1))
(setsockopt s SOL_TCP TCP_NODELAY 1)
(catch #t
(lambda ()
(connect s AF_INET (inet-aton "127.0.0.1") 8333)
s)
(lambda _ #f)))
(let ((s (socket PF_UNIX SOCK_STREAM 0)))
(catch #t
(lambda ()
(connect s AF_UNIX "/tmp/.gds_socket")
s)
(lambda _ #f)))
(error "Couldn't connect to GDS by TCP or Unix domain socket")))
(write-form (list 'name (getpid) (apply client-name application-name))))))
(define (client-name . application-name)
(let loop ((args (append application-name (program-arguments))))
(if (null? args)
(format #f "PID ~A" (getpid))
(let ((arg (car args)))
(cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
(loop (cdr args)))
((string-match "^-" arg)
(loop (cdr args)))
(else
(format #f "~A (PID ~A)" arg (getpid))))))))
(if (not (defined? 'make-mutex))
(begin
(define (make-mutex) #f)
(define lock-mutex noop)
(define unlock-mutex noop)))
(define write-mutex (make-mutex))
(define (write-form form)
;; Write any form FORM to GDS.
(lock-mutex write-mutex)
(write form gds-port)
(newline gds-port)
(force-output gds-port)
(unlock-mutex write-mutex))
(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 frame))
(list 'evaluation
(with-output-to-string
(lambda ()
(display (if (frame-real? frame) " " "t "))
(write-frame-short/expression frame)))
(source->emacs-readable frame))))
(define (source->emacs-readable frame)
;; Return Emacs-readable representation of the filename, line and
;; column source properties of SOURCE.
(or (frame->source-position frame) 'nil))
(define (flags->emacs-readable flags)
;; Return Emacs-readable representation of trap FLAGS.
(let ((prev #f))
(map (lambda (flag)
(let ((erf (if (and (keyword? flag)
(not (eq? prev #:return)))
(keyword->symbol flag)
(format #f "~S" flag))))
(set! prev flag)
erf))
flags)))
(define (eval-in-frame stack index expr)
(write-form
(list 'eval-result
(format #f "~S"
(catch #t
(lambda ()
(local-eval (with-input-from-string expr read)
(memoized-environment
(frame-source (stack-ref stack
index)))))
(lambda args
(cons 'ERROR args)))))))
(set! (behaviour-ordering gds-debug-trap) 100)
;;; Code below here adds support for interaction between the GDS
;;; client program and the Emacs frontend even when not stopped in the
;;; debugger.
;; A mutex to control attempts by multiple threads to read protocol
;; back from the frontend.
(define gds-read-mutex (make-mutex))
;; Read a protocol instruction from the frontend.
(define (gds-read)
;; Acquire the read mutex.
(lock-mutex gds-read-mutex)
;; Tell the front end something that identifies us as a thread.
(write-form `(thread-id ,(get-thread-id)))
;; Now read, then release the mutex and return what was read.
(let ((x (catch #t
(lambda () (read gds-port))
(lambda ignored the-eof-object))))
(unlock-mutex gds-read-mutex)
x))
(define (gds-accept-input exit-on-continue)
;; If reading from the GDS connection returns EOF, we will throw to
;; this catch.
(catch 'server-eof
(lambda ()
(let loop ((protocol (gds-read)))
(if (or (eof-object? protocol)
(and exit-on-continue
(eq? (car protocol) 'continue)))
(throw 'server-eof))
(safely-handle-nondebug-protocol protocol)
(loop (gds-read))))
(lambda ignored #f)))
(define (safely-handle-nondebug-protocol protocol)
;; This catch covers any internal errors in the GDS code or
;; protocol.
(catch #t
(lambda ()
(lazy-catch #t
(lambda ()
(handle-nondebug-protocol protocol))
save-lazy-trap-context-and-rethrow))
(lambda (key . args)
(write-form
`(eval-results (error . ,(format #f "~s" protocol))
,(if last-lazy-trap-context 't 'nil)
"GDS Internal Error
Please report this to <neil@ossau.uklinux.net>, ideally including:
- a description of the scenario in which this error occurred
- which versions of Guile and guile-debugging you are using
- the error stack, which you can get by clicking on the link below,
and then cut and paste into your report.
Thanks!\n\n"
,(list (with-output-to-string
(lambda ()
(write key)
(display ": ")
(write args)
(newline)))))))))
;; The key that is used to signal a read error changes from 1.6 to
;; 1.8; here we cover all eventualities by discovering the key
;; dynamically.
(define read-error-key
(catch #t
(lambda ()
(with-input-from-string "(+ 3 4" read))
(lambda (key . args)
key)))
(define (handle-nondebug-protocol protocol)
(case (car protocol)
((eval)
(set! last-lazy-trap-context #f)
(apply (lambda (correlator module port-name line column 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-key
(lambda ()
(let loop ((exprs '()) (x (read)))
(if (eof-object? x)
;; Expressions to be evaluated have all
;; been read. Now evaluate them.
(let loop2 ((exprs (reverse! exprs))
(results '())
(n 1))
(if (null? exprs)
(write-form `(eval-results ,correlator
,(if last-lazy-trap-context 't 'nil)
,@results))
(loop2 (cdr exprs)
(append results (gds-eval (car exprs) m
(if (and (null? (cdr exprs))
(= n 1))
#f n)))
(+ n 1))))
;; Another complete expression read; add
;; it to the list.
(loop (cons x exprs) (read)))))
(lambda (key . args)
(write-form `(eval-results
,correlator
,(if last-lazy-trap-context 't 'nil)
,(with-output-to-string
(lambda ()
(display ";;; Reading expressions")
(display " to evaluate\n")
(apply display-error #f
(current-output-port) args)))
("error-in-read")))))))))
(cdr protocol)))
((complete)
(let ((matches (apropos-internal
(string-append "^" (regexp-quote (cadr protocol))))))
(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 protocol))
(write-form `(completion-result
,(map symbol->string matches)))
(write-form `(completion-result
,match))))))))
((debug-lazy-trap-context)
(if last-lazy-trap-context
(gds-debug-trap last-lazy-trap-context)
(error "There is no stack available to show")))
(else
(error "Unexpected protocol:" protocol))))
(define (resolve-module-from-root name)
(save-module-excursion
(lambda ()
(set-current-module the-root-module)
(resolve-module name))))
(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 expression ~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
(lambda ()
(lazy-catch #t
do-eval
save-lazy-trap-context-and-rethrow))
(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))))
(define last-lazy-trap-context #f)
(define (save-lazy-trap-context-and-rethrow key . args)
(set! last-lazy-trap-context
(throw->trap-context key args save-lazy-trap-context-and-rethrow))
(apply throw key args))
(define (run-utility)
(connect-to-gds)
(write (getpid))
(newline)
(force-output)
(named-module-use! '(guile-user) '(ice-9 session))
(gds-accept-input #f))
(define-method (trap-description (trap <trap>))
(let loop ((description (list (class-name (class-of trap))))
(next 'installed?))
(case next
((installed?)
(loop (if (slot-ref trap 'installed)
(cons 'installed description)
description)
'conditional?))
((conditional?)
(loop (if (slot-ref trap 'condition)
(cons 'conditional description)
description)
'skip-count))
((skip-count)
(loop (let ((skip-count (slot-ref trap 'skip-count)))
(if (zero? skip-count)
description
(cons* skip-count 'skip-count description)))
'single-shot?))
((single-shot?)
(loop (if (slot-ref trap 'single-shot)
(cons 'single-shot description)
description)
'done))
(else
(reverse! description)))))
(define-method (trap-description (trap <procedure-trap>))
(let ((description (next-method)))
(set-cdr! description
(cons (procedure-name (slot-ref trap 'procedure))
(cdr description)))
description))
(define-method (trap-description (trap <source-trap>))
(let ((description (next-method)))
(set-cdr! description
(cons (format #f "~s" (slot-ref trap 'expression))
(cdr description)))
description))
(define-method (trap-description (trap <location-trap>))
(let ((description (next-method)))
(set-cdr! description
(cons* (slot-ref trap 'file-regexp)
(slot-ref trap 'line)
(slot-ref trap 'column)
(cdr description)))
description))
(define (gds-trace-trap trap-context)
(connect-to-gds)
(gds-do-trace trap-context)
(at-exit (tc:depth trap-context) gds-do-trace))
(define (gds-do-trace trap-context)
(write-form (list 'trace
(format #f
"~3@a: ~a"
(trace/stack-real-depth trap-context)
(trace/info trap-context)))))
(define (gds-trace-subtree trap-context)
(connect-to-gds)
(gds-do-trace trap-context)
(let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
(install-trap step-trap)
(at-exit (tc:depth trap-context)
(lambda (trap-context)
(uninstall-trap step-trap)))))
;;; (ice-9 gds-client) ends here.

193
ice-9/gds-server.scm Normal file
View file

@ -0,0 +1,193 @@
;;;; 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 (ice-9 gds-server)
#: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 connection->id (make-object-property))
(define (run-server port-or-path)
(or (integer? port-or-path)
(string? port-or-path)
(error "port-or-path should be an integer (port number) or a string (file name)"
port-or-path))
(let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
SOCK_STREAM
0)))
;; Initialize server socket.
(if (integer? port-or-path)
(begin
(setsockopt server SOL_SOCKET SO_REUSEADDR 1)
(bind server AF_INET INADDR_ANY port-or-path))
(begin
(catch #t
(lambda () (delete-file port-or-path))
(lambda _ #f))
(bind server AF_UNIX port-or-path)))
;; Start listening.
(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 (connection->id 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)
(let ((new-port (car (accept server))))
;; Read the client's ID.
(let ((name-form (read new-port)))
;; Absorb the following newline character.
(read-char new-port)
;; Check that we have a name form.
(or (eq? (car name-form) 'name)
(error "Invalid name form:" name-form))
;; Store an association from the connection to the ID.
(set! (connection->id new-port) (cadr name-form))
;; Pass the name form on to Emacs.
(write-to-ui (cons (connection->id new-port) name-form)))
;; Add the new connection to the set that we select on.
(cons new-port 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 (connection->id port) 'closed))
(close port)
(delq port clients))
((char=? next-char #\()
(write-to-ui (cons (connection->id 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))))))
;; What happens if there are multiple copies of Emacs running on the
;; same machine, and they all try to start up the GDS server? They
;; can't all listen on the same TCP port, so the short answer is that
;; all of them except the first will get an EADDRINUSE error when
;; trying to bind.
;;
;; We want to be able to handle this scenario, though, so that Scheme
;; code can be evaluated, and help invoked, in any of those Emacsen.
;; So we introduce the idea of a "slave server". When a new GDS
;; server gets an EADDRINUSE bind error, the implication is that there
;; is already a GDS server running, so the new server instead connects
;; to the existing one (by issuing a connect to the GDS port number).
;;
;; Let's call the first server the "master", and the new one the
;; "slave". In principle the master can now proxy any GDS client
;; connections through to the slave, so long as there is sufficient
;; information in the protocol for it to decide when and how to do
;; this.
;;
;; The basic information and mechanism that we need for this is as
;; follows.
;;
;; - A unique ID for each Emacs; this can be each Emacs's PID. When a
;; slave server connects to the master, it announces itself by sending
;; the protocol (emacs ID).
;;
;; - A way for a client to indicate which Emacs it wants to use. At
;; the protocol level, this is an extra argument in the (name ...)
;; protocol. (The absence of this argument means "no preference". A
;; simplistic master server might then decide to use its own Emacs; a
;; cleverer one might monitor which Emacs appears to be most in use,
;; and use that one.) At the API level this can be an optional
;; argument to the `gds-connect' procedure, and the Emacs GDS code
;; would obviously set this argument when starting a client from
;; within Emacs.
;;
;; We also want a strategy for continuing seamlessly if the master
;; server shuts down.
;;
;; - Each slave server will detect this as an error on the connection
;; to the master socket. Each server then tries to bind to the GDS
;; port again (a race which the OS will resolve), and if that fails,
;; connect again. The result of this is that there should be a new
;; master, and the others all slaves connected to the new master.
;;
;; - Each client will also detect this as an error on the connection
;; to the (master) server. Either the client should try to connect
;; again (perhaps after a short delay), or the reconnection can be
;; delayed until the next time that the client requires the server.
;; (Probably the latter, all done within `gds-read'.)
;;
;; (Historical note: Before this master-slave idea, clients were
;; identified within gds-server.scm and gds*.el by an ID which was
;; actually the file descriptor of their connection to the server.
;; That is no good in the new scheme, because each client's ID must
;; persist when the master server changes, so we now use the client's
;; PID instead. We didn't use PID before because the client/server
;; code was written to be completely asynchronous, which made it
;; tricky for the server to discover each client's PID and associate
;; it with a particular connection. Now we solve that problem by
;; handling the initial protocol exchange synchronously.)
(define (run-slave-server port)
'not-implemented)