summaryrefslogtreecommitdiff
path: root/emacs
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2005-05-23 19:57:22 +0000
committerMarius Vollmer <mvo@zagadka.de>2005-05-23 19:57:22 +0000
commit92205699d01f918a0f8808d8cbbe55ba2568f058 (patch)
tree7893aa8fe5d7200a3ba94f6486100de9c4684f0b /emacs
parent5ae1bd9109070f0233b7839b6a2b7c09becd49b0 (diff)
downloadguile-92205699d01f918a0f8808d8cbbe55ba2568f058.tar.gz
The FSF has a new address.
Diffstat (limited to 'emacs')
-rw-r--r--emacs/Makefile.am38
-rw-r--r--emacs/gds-client.scm726
-rw-r--r--emacs/gds-server.scm98
-rw-r--r--emacs/gds.el1626
-rw-r--r--emacs/gud-guile.el4
-rw-r--r--emacs/guile-c.el4
-rw-r--r--emacs/guile-emacs.scm4
-rw-r--r--emacs/guile-scheme.el4
-rw-r--r--emacs/guile.el4
-rw-r--r--emacs/multistring.el4
-rw-r--r--emacs/patch.el4
-rw-r--r--emacs/ppexpand.el4
-rw-r--r--emacs/update-changelog.el4
13 files changed, 18 insertions, 2506 deletions
diff --git a/emacs/Makefile.am b/emacs/Makefile.am
index bef23935c..e69de29bb 100644
--- a/emacs/Makefile.am
+++ b/emacs/Makefile.am
@@ -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
diff --git a/emacs/gds-client.scm b/emacs/gds-client.scm
index c1714a22d..e69de29bb 100644
--- a/emacs/gds-client.scm
+++ b/emacs/gds-client.scm
@@ -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.
diff --git a/emacs/gds-server.scm b/emacs/gds-server.scm
index c472ee359..e69de29bb 100644
--- a/emacs/gds-server.scm
+++ b/emacs/gds-server.scm
@@ -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))))))
diff --git a/emacs/gds.el b/emacs/gds.el
index d5f607a32..e69de29bb 100644
--- a/emacs/gds.el
+++ b/emacs/gds.el
@@ -1,1626 +0,0 @@
-;;; gds.el -- frontend for Guile development in Emacs
-
-;;;; 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
-
-
-;;;; Prerequisites.
-
-(require 'widget)
-(require 'wid-edit)
-(require 'scheme)
-(require 'cl)
-(require 'comint)
-(require 'info)
-
-
-;;;; Customization group setup.
-
-(defgroup gds nil
- "Customization options for Guile Emacs frontend."
- :group 'scheme)
-
-
-;;;; Communication with the (emacs gds-server) subprocess.
-
-;; The subprocess object.
-(defvar gds-process nil)
-
-;; 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 and captive client
-;; processes.
-(defcustom gds-guile-program "guile"
- "*The guile executable used by GDS, specifically by its server and
-captive client processes."
- :type 'string
- :group 'gds)
-
-(defun gds-start ()
- "Start (or restart, if already running) the GDS subprocess."
- (interactive)
- (gds-kill-captive)
- (if gds-process (gds-shutdown))
- (with-current-buffer (get-buffer-create "*GDS Process*")
- (erase-buffer)
- (setq gds-process
- (let ((process-connection-type nil)) ; use a pipe
- (start-process "gds"
- (current-buffer)
- gds-guile-program
- "-q"
- "--debug"
- "-c"
- "(begin (use-modules (emacs gds-server)) (run-server))"))))
- (setq gds-read-cursor (point-min))
- (set-process-filter gds-process (function gds-filter))
- (set-process-sentinel gds-process (function gds-sentinel))
- (set-process-coding-system gds-process 'latin-1-unix)
- (process-kill-without-query gds-process))
-
-;; Shutdown the subprocess and cleanup all associated data.
-(defun gds-shutdown ()
- "Shut down the GDS subprocess."
- (interactive)
- ;; Reset variables.
- (setq gds-buffers nil)
- ;; Kill the subprocess.
- (condition-case nil
- (progn
- (kill-process gds-process)
- (accept-process-output gds-process 0 200))
- (error))
- (setq gds-process nil))
-
-;; 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-handle-input'.
-(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
- (gds-handle-input 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)
- )
-
-;; Send input to the subprocess.
-(defun gds-send (string client)
- (process-send-string gds-process (format "(%S %s)\n" client string))
- (let ((buf (gds-client-ref 'gds-transcript)))
- (if buf
- (with-current-buffer buf
- (goto-char (point-max))
- (let ((inhibit-read-only t))
- (insert (format "tx (%S %s)\n" client string)))))))
-
-
-;;;; Focussing in and out on interaction with a particular client.
-
-;;;; The slight possible problems here are that popping up a client's
-;;;; interaction windows when that client wants attention might
-;;;; interrupt something else that the Emacs user was working on at
-;;;; the time, and that if multiple clients are being debugged at the
-;;;; same time, their popping up of interaction windows might become
-;;;; confusing. For this reason, we allow GDS's behavior to be
-;;;; customized via the variables `gds-focus-in-function' and
-;;;; `gds-focus-out-function'.
-;;;;
-;;;; That said, the default policy, which is probably OK for most
-;;;; users most of the time, is very simple: when a client wants
-;;;; attention, its interaction windows are popped up immediately.
-
-(defun gds-request-focus (client)
- (funcall gds-focus-in-function client))
-
-(defcustom gds-focus-in-function (function gds-focus-in)
- "Function to call when a GDS client program wants user attention.
-The function is called with one argument, the CLIENT in question."
- :type 'function
- :group 'gds)
-
-(defun gds-focus-in (client)
- (gds-display-buffers client))
-
-(defun gds-quit ()
- (interactive)
- (funcall gds-focus-out-function))
-
-(defcustom gds-focus-out-function (function gds-focus-out)
- "Function to call when user quits interacting with a GDS client."
- :type 'function
- :group 'gds)
-
-(defun gds-focus-out ()
- (if (if (gds-client-blocked)
- (y-or-n-p "Client is waiting for input. Quit anyway? ")
- t)
- (bury-buffer (current-buffer))))
-
-
-;;;; Multiple client focus -- an alternative implementation.
-
-;;;; The following code is provided as an alternative example of how a
-;;;; customized GDS could schedule the display of multiple clients
-;;;; that are competing for user attention.
-
-;; - `gds-waiting' holds a list of clients that want attention but
-;; haven't yet got it. A client is added to this list for two
-;; reasons. (1) When it is blocked waiting for user input.
-;; (2) When it first connects to GDS, even if not blocked.
-;;
-;; - `gds-focus-client' holds the client, if any, that currently has
-;; the user's attention. A client can be given the focus if
-;; `gds-focus-client' is nil at the time that the client wants
-;; attention, or if another client relinquishes it. A client can
-;; relinquish the focus in two ways. (1) If the client application
-;; says that it is no longer blocked, and a small time passes without
-;; it becoming blocked again. (2) If the user explicitly `quits'
-;; that client.
-;;
-;; (defvar gds-focus-client nil)
-;; (defvar gds-waiting nil)
-;;
-;; (defun gds-focus-in-alternative (client)
-;; (cond ((eq client gds-focus-client)
-;; ;; CLIENT already has the focus. Display its buffer.
-;; (gds-display-buffers client))
-;; (gds-focus-client
-;; ;; Another client has the focus. Add CLIENT to `gds-waiting'.
-;; (or (memq client gds-waiting)
-;; (setq gds-waiting (append gds-waiting (list client)))))
-;; (t
-;; ;; Give focus to CLIENT and display its buffer.
-;; (setq gds-focus-client client)
-;; (gds-display-buffers client))))
-;;
-;; (defun gds-focus-out-alternative ()
-;; (if (or (car gds-waiting)
-;; (not (gds-client-blocked))
-;; (y-or-n-p
-;; "Client is blocked and no others are waiting. Still quit? "))
-;; (progn
-;; (bury-buffer (current-buffer))
-;; ;; Pass on the focus.
-;; (setq gds-focus-client (car gds-waiting)
-;; gds-waiting (cdr gds-waiting))
-;; ;; If this client is blocked, add it back into the waiting list.
-;; (if (gds-client-blocked)
-;; (gds-request-focus gds-client))
-;; ;; If there is a new focus client, request display for it.
-;; (if gds-focus-client
-;; (gds-request-focus gds-focus-client)))))
-
-
-;;;; GDS protocol dispatch.
-
-;; General dispatch function called by the subprocess filter.
-(defun gds-handle-input (form)
- (let ((client (car form)))
- (or (eq client '*)
- (let* ((proc (cadr form))
- (args (cddr form))
- (buf (gds-client-buffer client proc args)))
- (if buf (gds-handle-client-input buf client proc args))))))
-
-(defun gds-handle-client-input (buf client proc args)
- (with-current-buffer buf
- (with-current-buffer gds-transcript
- (goto-char (point-max))
- (let ((inhibit-read-only t))
- (insert (format "rx %S" (cons client (cons proc args))) "\n")))
-
- (cond (;; (name ...) - Client name.
- (eq proc 'name)
- (setq gds-pid (cadr args))
- (gds-promote-view 'interaction)
- (gds-request-focus client))
-
- (;; (current-module ...) - Current module.
- (eq proc 'current-module)
- (setq gds-current-module (car args)))
-
- (;; (stack ...) - Stack at an error or breakpoint.
- (eq proc 'stack)
- (setq gds-stack args)
- (gds-promote-view 'stack))
-
- (;; (modules ...) - Application's loaded modules.
- (eq proc 'modules)
- (while args
- (or (assoc (car args) gds-modules)
- (setq gds-modules (cons (list (car args)) gds-modules)))
- (setq args (cdr args))))
-
- (;; (output ...) - Last printed output.
- (eq proc 'output)
- (setq gds-output (car args))
- (gds-add-view 'messages))
-
- (;; (status ...) - Application status indication.
- (eq proc 'status)
- (setq gds-status (car args))
- (if (eq gds-status 'running)
- (gds-delete-view 'browser)
- (gds-add-view 'browser))
- (if (eq gds-status 'waiting-for-input)
- (progn
- (gds-promote-view 'stack)
- (gds-update-buffers)
- (gds-request-focus client))
- (setq gds-stack nil)
- (gds-delete-view 'stack)
- (gds-update-buffers-in-a-while)))
-
- (;; (module MODULE ...) - The specified module's bindings.
- (eq proc 'module)
- (let ((minfo (assoc (car args) gds-modules)))
- (if minfo
- (setcdr (cdr minfo) (cdr args)))))
-
- (;; (closed) - Client has gone away.
- (eq proc 'closed)
- (setq gds-status 'closed)
- (gds-update-buffers)
- (setq gds-buffers
- (delq (assq client gds-buffers) gds-buffers)))
-
- (;; (eval-results ...) - Results of evaluation.
- (eq proc 'eval-results)
- (gds-display-results client (car args) (cdr args)))
-
- (;; (completion-result ...) - Available completions.
- (eq proc 'completion-result)
- (setq gds-completion-results (or (car args) t)))
-
- (;; (breakpoint-set FILE LINE COLUMN INFO) - Breakpoint set.
- (eq proc 'breakpoint-set)
- (let ((file (nth 0 args))
- (line (nth 1 args))
- (column (nth 2 args))
- (info (nth 3 args)))
- (with-current-buffer (find-file-noselect file)
- (save-excursion
- (goto-char (point-min))
- (or (zerop line)
- (forward-line line))
- (move-to-column column)
- (let ((os (overlays-at (point))) o)
- (while os
- (if (and (overlay-get (car os) 'gds-breakpoint-info)
- (= (overlay-start (car os)) (point)))
- (progn
- (overlay-put (car os)
- 'gds-breakpoint-info
- info)
- (overlay-put (car os)
- 'before-string
- gds-active-breakpoint-before-string)
- (overlay-put (car os)
- 'after-string
- gds-active-breakpoint-after-string)
- (setq os nil))
- (setq os (cdr os)))))))))
-
- (;; (thread-status THREAD-TYPE THREAD-NUMBER STATUS [CORRELATOR])
- (eq proc 'thread-status)
- (if (eq (car args) 'eval)
- (let ((number (nth 1 args))
- (status (nth 2 args))
- (correlator (nth 3 args)))
- (if (eq status 'busy)
- (progn
- (setq gds-evals-in-progress
- (append gds-evals-in-progress
- (list (cons number correlator))))
- (run-at-time 0.5 nil
- (function gds-display-slow-eval)
- buf number correlator)
- (gds-promote-view 'interaction))
- (let ((existing (assq number gds-evals-in-progress)))
- (if existing
- (setq gds-evals-in-progress
- (delq existing gds-evals-in-progress)))))
- (gds-update-buffers))))
-
- )))
-
-(defun gds-display-slow-eval (buf number correlator)
- (with-current-buffer buf
- (let ((entry (assq number gds-evals-in-progress)))
- (if (and entry
- (eq (cdr entry) correlator))
- (progn
- (gds-promote-view 'interaction)
- (gds-request-focus gds-client))))))
-
-
-;;;; Per-client buffer state.
-
-;; This section contains code that is specific to each Guile client's
-;; buffer but independent of any particular `view'.
-
-;; Alist mapping each client port number to corresponding buffer.
-(defvar gds-buffers nil)
-
-(define-derived-mode gds-mode
- scheme-mode
- "Guile Interaction"
- "Major mode for interacting with a Guile client application."
- (widget-minor-mode 1))
-
-(defvar gds-client nil
- "GDS client's port number.")
-(make-variable-buffer-local 'gds-client)
-
-(defvar gds-status nil
- "GDS client's latest status, one of the following symbols.
-`running' - Application is running.
-`waiting-for-input' - Application is blocked waiting for instruction
- from the frontend.
-`ready-for-input' - Application is not blocked but can also accept
- asynchronous instructions from the frontend.")
-(make-variable-buffer-local 'gds-status)
-
-(defvar gds-transcript nil
- "Transcript buffer for this GDS client.")
-(make-variable-buffer-local 'gds-transcript)
-
-;; Return client buffer for specified client and protocol input.
-(defun gds-client-buffer (client proc args)
- (if (eq proc 'name)
- ;; Introduction from client - create a new buffer.
- (with-current-buffer (generate-new-buffer (car args))
- (gds-mode)
- (setq gds-client client)
- (setq gds-transcript
- (find-file-noselect
- (expand-file-name (concat "~/.gds-transcript-" (car args)))))
- (with-current-buffer gds-transcript
- (goto-char (point-max))
- (insert "\nTranscript:\n"))
- (setq gds-buffers
- (cons (cons client (current-buffer))
- gds-buffers))
- (current-buffer))
- ;; Otherwise there should be an existing buffer that we can
- ;; return.
- (let ((existing (assq client gds-buffers)))
- (if (buffer-live-p (cdr existing))
- (cdr existing)
- (setq gds-buffers (delq existing gds-buffers))
- (gds-client-buffer client 'name '("(GDS buffer killed)"))))))
-
-;; Get the current buffer's associated client's value of SYM.
-(defun gds-client-ref (sym &optional client)
- (and (or client gds-client)
- (let ((buf (assq (or client gds-client) gds-buffers)))
- (and buf
- (cdr buf)
- (buffer-live-p (cdr buf))
- (with-current-buffer (cdr buf)
- (symbol-value sym))))))
-
-(defun gds-client-blocked ()
- (eq (gds-client-ref 'gds-status) 'waiting-for-input))
-
-(defvar gds-delayed-update-timer nil)
-
-(defvar gds-delayed-update-buffers nil)
-
-(defun gds-update-delayed-update-buffers ()
- (while gds-delayed-update-buffers
- (with-current-buffer (car gds-delayed-update-buffers)
- (setq gds-delayed-update-buffers
- (cdr gds-delayed-update-buffers))
- (gds-update-buffers))))
-
-(defun gds-update-buffers ()
- (if (timerp gds-delayed-update-timer)
- (cancel-timer gds-delayed-update-timer))
- (setq gds-delayed-update-timer nil)
- (let ((view (car gds-views))
- (inhibit-read-only t))
- (cond ((eq view 'stack)
- (gds-insert-stack))
- ((eq view 'interaction)
- (gds-insert-interaction))
- ((eq view 'browser)
- (gds-insert-modules))
- ((eq view 'messages)
- (gds-insert-messages))
- (t
- (error "Bad GDS view %S" view)))
- ;; Finish off.
- (force-mode-line-update t)))
-
-(defun gds-update-buffers-in-a-while ()
- (or (memq (current-buffer) gds-delayed-update-buffers)
- (setq gds-delayed-update-buffers
- (cons (current-buffer) gds-delayed-update-buffers)))
- (if (timerp gds-delayed-update-timer)
- nil
- (setq gds-delayed-update-timer
- (run-at-time 0.5 nil (function gds-update-delayed-update-buffers)))))
-
-(defun gds-display-buffers (client)
- (let ((buf (cdr (assq client gds-buffers))))
- ;; If there's already a window showing the buffer, use it.
- (let ((window (get-buffer-window buf t)))
- (if window
- (make-frame-visible (window-frame window))
- (display-buffer buf)))
- ;; If there is an associated source buffer, display it as well.
- (if (and (eq (car gds-views) 'stack)
- gds-frame-source-overlay
- (> (overlay-end gds-frame-source-overlay) 1))
- (let ((window (display-buffer
- (overlay-buffer gds-frame-source-overlay))))
- (set-window-point window
- (overlay-start gds-frame-source-overlay))))))
-
-
-;;;; Management of `views'.
-
-;; The idea here is to keep the buffer describing a Guile client
-;; relatively uncluttered by only showing one kind of information
-;; about that client at a time. Menu items and key sequences are
-;; provided to switch easily between the available views.
-
-(defvar gds-views nil
- "List of available views for a GDS client. Each element is one of
-the following symbols.
-`interaction' - Interaction with running client.
-`stack' - Call stack view.
-`browser' - Modules and bindings browser view.
-`breakpoints' - List of set breakpoints.
-`messages' - Non-GDS-protocol output from the debugger.")
-(make-variable-buffer-local 'gds-views)
-
-(defun gds-promote-view (view)
- (setq gds-views (cons view (delq view gds-views))))
-
-(defun gds-switch-to-view (view)
- (or (memq view gds-views)
- (error "View %S is not available" view))
- (gds-promote-view view)
- (gds-update-buffers))
-
-(defun gds-add-view (view)
- (or (memq view gds-views)
- (setq gds-views (append gds-views (list view)))))
-
-(defun gds-delete-view (view)
- (setq gds-views (delq view gds-views)))
-
-
-;;;; `Interaction' view.
-
-;; This view provides interaction with a normally running Guile
-;; client, in other words one that is not stopped in the debugger but
-;; is still available to take input from GDS (usually via a thread for
-;; that purpose). The view supports evaluation, help requests,
-;; control of `debug-on-exception' function, and methods for breaking
-;; into the running code.
-
-(defvar gds-current-module "()"
- "GDS client's current module.")
-(make-variable-buffer-local 'gds-current-module)
-
-(defvar gds-pid nil
- "GDS client's process ID.")
-(make-variable-buffer-local 'gds-pid)
-
-(defvar gds-debug-exceptions nil
- "Whether to debug exceptions.")
-(make-variable-buffer-local 'gds-debug-exceptions)
-
-(defvar gds-exception-keys "signal misc-error"
- "The exception keys for which to debug a GDS client.")
-(make-variable-buffer-local 'gds-exception-keys)
-
-(defvar gds-evals-in-progress nil
- "Alist describing evaluations in progress.")
-(make-variable-buffer-local 'gds-evals-in-progress)
-
-(defvar gds-results nil
- "Last help or evaluation results.")
-(make-variable-buffer-local 'gds-results)
-
-(defcustom gds-heading-face 'info-menu-header
- "*Face used for headings in Guile Interaction buffers."
- :type 'face
- :group 'gds)
-
-(defun gds-insert-interaction ()
- (erase-buffer)
- ;; Insert stuff for interacting with a running (non-blocked) Guile
- ;; client.
- (gds-heading-insert (buffer-name))
- (widget-insert " "
- (cdr (assq gds-status
- '((running . "running (cannot accept input)")
- (waiting-for-input . "waiting for input")
- (ready-for-input . "running")
- (closed . "closed"))))
- ", in "
- gds-current-module
- "\n\n")
- (widget-create 'push-button
- :notify (function gds-sigint)
- "SIGINT")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (function gds-async-break)
- "Break")
- (widget-insert "\n")
- (widget-create 'checkbox
- :notify (function gds-toggle-debug-exceptions)
- gds-debug-exceptions)
- (widget-insert " Debug exception keys: ")
- (widget-create 'editable-field
- :notify (function gds-set-exception-keys)
- gds-exception-keys)
- ;; Evaluation report area.
- (widget-insert "\n")
- (gds-heading-insert "Recent Evaluations")
- (widget-insert " To run an evaluation, see the Guile->Evaluate menu.\n")
- (if gds-results
- (widget-insert "\n" (cdr gds-results)))
- (let ((evals gds-evals-in-progress))
- (while evals
- (widget-insert "\n" (cddar evals) " - running ")
- (let ((w (widget-create 'push-button
- :notify (function gds-interrupt-eval)
- "Interrupt")))
- (widget-put w :thread-number (caar evals)))
- (widget-insert "\n")
- (setq evals (cdr evals)))))
-
-(defun gds-heading-insert (text)
- (let ((start (point)))
- (widget-insert text)
- (let ((o (make-overlay start (point))))
- (overlay-put o 'face gds-heading-face)
- (overlay-put o 'evaporate t))))
-
-(defun gds-sigint (w &rest ignore)
- (interactive)
- (signal-process gds-pid 2))
-
-(defun gds-async-break (w &rest ignore)
- (interactive)
- (gds-send "async-break" gds-client))
-
-(defun gds-interrupt-eval (w &rest ignore)
- (interactive)
- (gds-send (format "interrupt-eval %S" (widget-get w :thread-number))
- gds-client))
-
-(defun gds-toggle-debug-exceptions (w &rest ignore)
- (interactive)
- (setq gds-debug-exceptions (widget-value w))
- (gds-eval-expression (concat "(use-modules (ice-9 debugger))"
- "(debug-on-error '("
- gds-exception-keys
- "))")))
-
-(defun gds-set-exception-keys (w &rest ignore)
- (interactive)
- (setq gds-exception-keys (widget-value w)))
-
-(defun gds-view-interaction ()
- (interactive)
- (gds-switch-to-view 'interaction))
-
-
-;;;; `Stack' view.
-
-;; This view shows the Guile call stack after the application has hit
-;; an error, or when it is stopped in the debugger.
-
-(defvar gds-stack nil
- "GDS client's stack when last stopped.")
-(make-variable-buffer-local 'gds-stack)
-
-(defun gds-insert-stack ()
- (erase-buffer)
- (let ((frames (car gds-stack))
- (index (cadr gds-stack))
- (flags (caddr gds-stack))
- frame items)
- (cond ((memq 'application flags)
- (widget-insert "Calling procedure:\n"))
- ((memq 'evaluation flags)
- (widget-insert "Evaluating expression:\n"))
- ((memq 'return flags)
- (widget-insert "Return value: "
- (cadr (memq 'return flags))
- "\n"))
- (t
- (widget-insert "Stack: " (prin1-to-string flags) "\n")))
- (let ((i -1))
- (gds-show-selected-frame (caddr (nth index frames)))
- (while frames
- (setq frame (car frames)
- frames (cdr frames)
- i (+ i 1)
- items (cons (list 'item
- (let ((s (cadr frame)))
- (put-text-property 0 1 'index i s)
- s))
- items))))
- (setq items (nreverse items))
- (apply (function widget-create)
- 'radio-button-choice
- :value (cadr (nth index items))
- :notify (function gds-select-stack-frame)
- items)
- (widget-insert "\n")
- (goto-char (point-min))))
-
-(defun gds-select-stack-frame (widget &rest ignored)
- (let* ((s (widget-value widget))
- (ind (memq 'index (text-properties-at 0 s))))
- (gds-send (format "debugger-command frame %d" (cadr ind))
- gds-client)))
-
-;; Overlay used to highlight the source expression corresponding to
-;; the selected frame.
-(defvar gds-frame-source-overlay nil)
-
-(defun gds-show-selected-frame (source)
- ;; Highlight the frame source, if possible.
- (if (and source
- (file-readable-p (car source)))
- (with-current-buffer (find-file-noselect (car source))
- (if gds-frame-source-overlay
- nil
- (setq gds-frame-source-overlay (make-overlay 0 0))
- (overlay-put gds-frame-source-overlay 'face 'highlight))
- ;; 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))))
- (if gds-frame-source-overlay
- (move-overlay gds-frame-source-overlay 0 0))))
-
-(defun gds-view-stack ()
- (interactive)
- (gds-switch-to-view 'stack))
-
-
-;;;; `Breakpoints' view.
-
-;; This view shows a list of breakpoints.
-
-(defun gds-view-breakpoints ()
- (interactive)
- (gds-switch-to-view 'breakpoints))
-
-
-;;;; `Browser' view.
-
-;; This view shows a list of modules and module bindings.
-
-(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
- "Specification of which Guile modules the debugger should display.
-This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where
-DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL
-DEFAULT EXCEPTION EXCEPTION...).
-
-A Guile module name `(x y z)' is matched against this filter as
-follows. If one of the top level EXCEPTIONs has SYMBOL `x', continue
-by matching the rest of the module name, in this case `(y z)', against
-that SYMBOL's DEFAULT and next level EXCEPTION list. Otherwise, if
-the current DEFAULT is `t' display the module, and if the current
-DEFAULT is `nil', don't display it.
-
-This variable is usually set to exclude Guile system modules that are
-not of primary interest when debugging application code."
- :type 'sexp
- :group 'gds)
-
-(defun gds-show-module-p (name)
- ;; Determine whether to display the NAMEd module by matching NAME
- ;; against `gds-module-filter'.
- (let ((default (car gds-module-filter))
- (exceptions (cdr gds-module-filter)))
- (let ((exception (assq (car name) exceptions)))
- (if exception
- (let ((gds-module-filter (cdr exception)))
- (gds-show-module-p (cdr name)))
- default))))
-
-(defvar gds-modules nil
- "GDS client's module information.
-Alist mapping module names to their symbols and related information.
-This looks like:
-
- (((guile) t sym1 sym2 ...)
- ((guile-user))
- ((ice-9 debug) nil sym3 sym4)
- ...)
-
-The `t' or `nil' after the module name indicates whether the module is
-displayed in expanded form (that is, showing the bindings in that
-module). The syms are actually all strings because some Guile symbols
-are not readable by Emacs.")
-(make-variable-buffer-local 'gds-modules)
-
-(defun gds-insert-modules ()
- (let ((p (if (eq (window-buffer (selected-window)) (current-buffer))
- (point)
- (point-min)))
- (modules gds-modules))
- (erase-buffer)
- (insert "Modules:\n")
- (while modules
- (let ((minfo (car modules)))
- (if (gds-show-module-p (car minfo))
- (let ((w (widget-create 'push-button
- :notify (function gds-module-notify)
- (if (and (cdr minfo)
- (cadr minfo))
- "-" "+"))))
- (widget-put w :module (cons gds-client (car minfo)))
- (widget-insert " " (prin1-to-string (car minfo)) "\n")
- (if (cadr minfo)
- (let ((syms (cddr minfo)))
- (while syms
- (widget-insert " > " (car syms) "\n")
- (setq syms (cdr syms))))))))
- (setq modules (cdr modules)))
- (insert "\n")
- (goto-char p)))
-
-(defun gds-module-notify (w &rest ignore)
- (let* ((module (widget-get w :module))
- (client (car module))
- (name (cdr module))
- (minfo (assoc name gds-modules)))
- (if (cdr minfo)
- ;; Just toggle expansion state.
- (progn
- (setcar (cdr minfo) (not (cadr minfo)))
- (gds-update-buffers))
- ;; Set flag to indicate module expanded.
- (setcdr minfo (list t))
- ;; Get symlist from Guile.
- (gds-send (format "query-module %S" name) client))))
-
-(defun gds-query-modules ()
- (interactive)
- (gds-send "query-modules" gds-client))
-
-(defun gds-view-browser ()
- (interactive)
- (or gds-modules (gds-query-modules))
- (gds-switch-to-view 'browser))
-
-
-;;;; `Messages' view.
-
-;; This view shows recent non-GDS-protocol messages output from the
-;; (ice-9 debugger) code.
-
-(defvar gds-output nil
- "GDS client's recent output (printed).")
-(make-variable-buffer-local 'gds-output)
-
-(defun gds-insert-messages ()
- (erase-buffer)
- ;; Insert recent non-protocol output from (ice-9 debugger).
- (insert gds-output)
- (goto-char (point-min)))
-
-(defun gds-view-messages ()
- (interactive)
- (gds-switch-to-view 'messages))
-
-
-;;;; Debugger commands.
-
-;; Typically but not necessarily used from the `stack' view.
-
-(defun gds-go ()
- (interactive)
- (gds-send "debugger-command continue" gds-client))
-
-(defun gds-next ()
- (interactive)
- (gds-send "debugger-command next 1" gds-client))
-
-(defun gds-evaluate (expr)
- (interactive "sEvaluate (in this stack frame): ")
- (gds-send (format "debugger-command evaluate %s" (prin1-to-string expr))
- gds-client))
-
-(defun gds-step-in ()
- (interactive)
- (gds-send "debugger-command step 1" gds-client))
-
-(defun gds-step-out ()
- (interactive)
- (gds-send "debugger-command finish" gds-client))
-
-(defun gds-trace-finish ()
- (interactive)
- (gds-send "debugger-command trace-finish" gds-client))
-
-(defun gds-frame-info ()
- (interactive)
- (gds-send "debugger-command info-frame" gds-client))
-
-(defun gds-frame-args ()
- (interactive)
- (gds-send "debugger-command info-args" gds-client))
-
-(defun gds-debug-trap-hooks ()
- (interactive)
- (gds-send "debugger-command debug-trap-hooks" gds-client))
-
-(defun gds-up ()
- (interactive)
- (gds-send "debugger-command up 1" gds-client))
-
-(defun gds-down ()
- (interactive)
- (gds-send "debugger-command down 1" gds-client))
-
-
-;;;; Setting breakpoints.
-
-(defun gds-set-breakpoint ()
- (interactive)
- (cond ((gds-in-source-buffer)
- (gds-set-source-breakpoint))
- ((gds-in-stack)
- (gds-set-stack-breakpoint))
- ((gds-in-modules)
- (gds-set-module-breakpoint))
- (t
- (error "No way to set a breakpoint from here"))))
-
-(defun gds-in-source-buffer ()
- ;; Not yet worked out what will be available in Scheme source
- ;; buffers.
- nil)
-
-(defun gds-in-stack ()
- (save-excursion
- (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
- (looking-at "Stack"))))
-
-(defun gds-in-modules ()
- (save-excursion
- (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
- (looking-at "Modules"))))
-
-(defun gds-set-module-breakpoint ()
- (let ((sym (save-excursion
- (beginning-of-line)
- (and (looking-at " > \\([^ \n\t]+\\)")
- (match-string 1))))
- (module (save-excursion
- (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t)
- (match-string 1)))))
- (or sym
- (error "Couldn't find procedure name on current line"))
- (or module
- (error "Couldn't find module name for current line"))
- (let ((behaviour
- (completing-read
- (format "Behaviour for breakpoint at %s:%s (default debug-here): "
- module sym)
- '(("debug-here")
- ("trace-here")
- ("trace-subtree"))
- nil
- t
- nil
- nil
- "debug-here")))
- (gds-send (format "set-breakpoint %s %s %s"
- module
- sym
- behaviour)
- gds-client))))
-
-
-;;;; Scheme source breakpoints.
-
-(defcustom gds-breakpoint-face 'default
- "*Face used to highlight the location of a source breakpoint.
-Specifically, this face highlights the opening parenthesis of the
-form where the breakpoint is set."
- :type 'face
- :group 'gds)
-
-(defcustom gds-new-breakpoint-before-string ""
- "*String used to show the presence of a new source breakpoint.
-`New' means that the breakpoint has been set but isn't yet known to
-Guile because the containing code hasn't been reevaluated yet.
-This string appears before the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear after the
-opening parenthesis, make this string empty and use
-`gds-new-breakpoint-after-string'."
- :type 'string
- :group 'gds)
-
-(defcustom gds-new-breakpoint-after-string "=?= "
- "*String used to show the presence of a new source breakpoint.
-`New' means that the breakpoint has been set but isn't yet known to
-Guile because the containing code hasn't been reevaluated yet.
-This string appears after the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear before the
-opening parenthesis, make this string empty and use
-`gds-new-breakpoint-before-string'."
- :type 'string
- :group 'gds)
-
-(defcustom gds-active-breakpoint-before-string ""
- "*String used to show the presence of a source breakpoint.
-`Active' means that the breakpoint is known to Guile.
-This string appears before the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear after the
-opening parenthesis, make this string empty and use
-`gds-active-breakpoint-after-string'."
- :type 'string
- :group 'gds)
-
-(defcustom gds-active-breakpoint-after-string "=|= "
- "*String used to show the presence of a source breakpoint.
-`Active' means that the breakpoint is known to Guile.
-This string appears after the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear before the
-opening parenthesis, make this string empty and use
-`gds-active-breakpoint-before-string'."
- :type 'string
- :group 'gds)
-
-(defun gds-source-breakpoint-pos ()
- "Return the position of the starting parenthesis of the innermost
-Scheme pair around point."
- (if (eq (char-syntax (char-after)) ?\()
- (point)
- (save-excursion
- (condition-case nil
- (while t (forward-sexp -1))
- (error))
- (forward-char -1)
- (while (not (eq (char-syntax (char-after)) ?\())
- (forward-char -1))
- (point))))
-
-(defun gds-source-breakpoint-overlay-at (pos)
- "Return the source breakpoint overlay at POS, if any."
- (let* (o (os (overlays-at pos)))
- (while os
- (if (and (overlay-get (car os) 'gds-breakpoint-info)
- (= (overlay-start (car os)) pos))
- (setq o (car os)
- os nil))
- (setq os (cdr os)))
- o))
-
-(defun gds-set-source-breakpoint ()
- (interactive)
- (let* ((pos (gds-source-breakpoint-pos))
- (o (gds-source-breakpoint-overlay-at pos)))
- (if o
- (error "There is already a breakpoint here!")
- (setq o (make-overlay pos (+ pos 1)))
- (overlay-put o 'evaporate t)
- (overlay-put o 'face gds-breakpoint-face)
- (overlay-put o 'gds-breakpoint-info 0)
- (overlay-put o 'before-string gds-new-breakpoint-before-string)
- (overlay-put o 'after-string gds-new-breakpoint-after-string))))
-
-(defun gds-delete-source-breakpoint ()
- (interactive)
- (let* ((pos (gds-source-breakpoint-pos))
- (o (gds-source-breakpoint-overlay-at pos)))
- (or o
- (error "There is no breakpoint here to delete!"))
- (delete-overlay o)))
-
-(defun gds-region-breakpoint-info (beg end)
- "Return an alist of breakpoints in REGION.
-The car of each alist element is a cons (LINE . COLUMN) giving the
-source location of the breakpoint. The cdr is information describing
-breakpoint properties. Currently `information' is just the breakpoint
-index, for an existing Guile breakpoint, or 0 for a breakpoint that
-isn't yet known to Guile."
- (interactive "r")
- (let ((os (overlays-in beg end))
- info o)
- (while os
- (setq o (car os)
- os (cdr os))
- (if (overlay-get o 'gds-breakpoint-info)
- (progn
- (setq info
- (cons (cons (save-excursion
- (goto-char (overlay-start o))
- (cons (save-excursion
- (beginning-of-line)
- (count-lines (point-min) (point)))
- (current-column)))
- (overlay-get o 'gds-breakpoint-info))
- info))
- ;; Also now mark the breakpoint as `new'. It will become
- ;; `active' (again) when we receive a notification from
- ;; Guile that the breakpoint has been set.
- (overlay-put o 'gds-breakpoint-info 0)
- (overlay-put o 'before-string gds-new-breakpoint-before-string)
- (overlay-put o 'after-string gds-new-breakpoint-after-string))))
- (nreverse info)))
-
-
-;;;; 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. In
-;; the common case where GDS is only managing one client program, a
-;; buffer's value of `gds-client' is set automatically to point to
-;; that program the first time that an evaluation (or help or
-;; completion) is requested. If there are multiple GDS clients
-;; running at that time, GDS asks the user which one is intended.
-
-(defun gds-read-client ()
- (let* ((def (and gds-client (cdr (assq gds-client gds-names))))
- (prompt (if def
- (concat "Application for eval (default "
- def
- "): ")
- "Application for eval: "))
- (name
- (completing-read prompt
- (mapcar (function list)
- (mapcar (function cdr) gds-names))
- nil t nil nil
- def)))
- (let (client (names gds-names))
- (while (and names (not client))
- (if (string-equal (cdar names) name)
- (setq client (caar names)))
- (setq names (cdr names)))
- client)))
-
-(defun gds-choose-client (client)
- ;; Only keep the supplied client number if it is still valid.
- (if (integerp client)
- (setq client (gds-client-ref 'gds-client client)))
- ;; Only keep the current buffer's setting of `gds-client' if it is
- ;; still valid.
- (if gds-client
- (setq gds-client (gds-client-ref 'gds-client)))
-
- (or ;; If client is an integer, it is the port number of the
- ;; intended client.
- (if (integerp client)
- client)
- ;; Any other non-nil value indicates invocation with a prefix
- ;; arg, which forces asking the user which application is
- ;; intended.
- (if client
- (setq gds-client (gds-read-client)))
- ;; If ask not forced, and current buffer is associated with a
- ;; client, use that client.
- gds-client
- ;; If there are no clients at this point, and we are
- ;; allowed to autostart a captive Guile, do so.
- (and (null gds-buffers)
- gds-autostart-captive
- (progn
- (gds-start-captive t)
- (while (null gds-buffers)
- (accept-process-output (get-buffer-process gds-captive)
- 0 100000))
- (setq gds-client (caar gds-buffers))))
- ;; If there is only one known client, use that one.
- (if (and (car gds-buffers)
- (null (cdr gds-buffers)))
- (setq gds-client (caar gds-buffers)))
- ;; Last resort - ask the user.
- (setq gds-client (gds-read-client))
- ;; Signal an error.
- (error "No application chosen.")))
-
-(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)))
-
-(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 (buffer-file-name)
- (concat "Emacs buffer: " (buffer-name))))
-
-(defun gds-eval-region (start end &optional client)
- "Evaluate the current region."
- (interactive "r\nP")
- (setq client (gds-choose-client client))
- (let ((module (gds-module-name start end))
- (port-name (gds-port-name start end))
- line column)
- (save-excursion
- (goto-char start)
- (setq column (current-column)) ; 0-based
- (beginning-of-line)
- (setq line (count-lines (point-min) (point)))) ; 0-based
- (let ((code (buffer-substring-no-properties start end)))
- (gds-send (format "eval (region . %S) %s %S %d %d %s %S"
- (gds-abbreviated code)
- (if module (prin1-to-string module) "#f")
- port-name line column
- (let ((bpinfo (gds-region-breakpoint-info start end)))
- ;; Make sure that "no bpinfo" is represented
- ;; as "()", not "nil", as Scheme doesn't
- ;; understand "nil".
- (if bpinfo (format "%S" bpinfo) "()"))
- code)
- client))))
-
-(defun gds-eval-expression (expr &optional client correlator)
- "Evaluate the supplied EXPR (a string)."
- (interactive "sEvaluate expression: \nP")
- (setq client (gds-choose-client client))
- (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)
- 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 (&optional client)
- "Evaluate the defun (top-level form) at point."
- (interactive "P")
- (save-excursion
- (end-of-defun)
- (let ((end (point)))
- (beginning-of-defun)
- (gds-eval-region (point) end client))))
-
-(defun gds-eval-last-sexp (&optional client)
- "Evaluate the sexp before point."
- (interactive "P")
- (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client))
-
-
-;;;; Help.
-
-;; Help is implemented as a special case of evaluation, identified by
-;; the evaluation correlator 'help.
-
-(defun gds-help-symbol (sym &optional client)
- "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)
- current-prefix-arg)))
- (gds-eval-expression (format "(help %s)" sym) client 'help))
-
-(defun gds-apropos (regex &optional client)
- "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)
- current-prefix-arg)))
- (set-text-properties 0 (length regex) nil regex)
- (gds-eval-expression (format "(apropos %S)" regex) client 'help))
-
-(defvar gds-completion-results nil)
-
-(defun gds-complete-symbol (&optional client)
- "Complete the Guile symbol before point. Returns `t' if anything
-interesting happened, `nil' if not."
- (interactive "P")
- (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 client (gds-choose-client client))
- (setq gds-completion-results nil)
- (gds-send (format "complete %s"
- (prin1-to-string
- (buffer-substring-no-properties (- (point) chars)
- (point))))
- client)
- (while (null gds-completion-results)
- (accept-process-output gds-process 0 200))
- (cond ((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)))))
-
-
-;;;; Display of evaluation and help results.
-
-(defun gds-display-results (client correlator results)
- (let ((helpp (eq (car correlator) 'help)))
- (let ((buf (get-buffer-create (if helpp
- "*Guile Help*"
- "*Guile Results*"))))
- (setq gds-results
- (save-excursion
- (set-buffer buf)
- (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)))
- (goto-char (point-min))
- (if (and helpp (looking-at "Evaluating in "))
- (delete-region (point) (progn (forward-line 1) (point))))
- (cons correlator (buffer-string))))
- ;;(pop-to-buffer buf)
- ;;(run-hooks 'temp-buffer-show-hook)
- ;;(other-window 1)
- ))
- (gds-promote-view 'interaction)
- (gds-request-focus client))
-
-
-;;;; Loading (evaluating) a whole Scheme file.
-
-(defcustom gds-source-modes '(scheme-mode)
- "*Used to determine if a buffer contains Scheme source code.
-If it's loaded into a buffer that is in one of these major modes, it's
-considered a scheme source file by `gds-load-file'."
- :type '(repeat function)
- :group 'gds)
-
-(defvar gds-prev-load-dir/file nil
- "Holds the last (directory . file) pair passed to `gds-load-file'.
-Used for determining the default for the next `gds-load-file'.")
-
-(defun gds-load-file (file-name &optional client)
- "Load a Scheme file into the inferior Scheme process."
- (interactive (list (car (comint-get-source "Load Scheme file: "
- gds-prev-load-dir/file
- gds-source-modes t))
- ; T because LOAD needs an
- ; exact name
- current-prefix-arg))
- (comint-check-source file-name) ; Check to see if buffer needs saved.
- (setq gds-prev-load-dir/file (cons (file-name-directory file-name)
- (file-name-nondirectory file-name)))
- (setq client (gds-choose-client client))
- (gds-send (format "load %S" file-name) client))
-
-
-;;;; Scheme mode keymap items.
-
-(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention
-(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention
-(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-c\C-l" 'gds-load-file)
-(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 "\e\t" 'gds-complete-symbol)
-(define-key scheme-mode-map "\C-x " 'gds-set-source-breakpoint)
-(define-key scheme-mode-map "\C-x\e " 'gds-delete-source-breakpoint)
-
-
-;;;; Guile Interaction mode keymap and menu items.
-
-(define-key gds-mode-map "M" (function gds-query-modules))
-
-(define-key gds-mode-map "g" (function gds-go))
-(define-key gds-mode-map "q" (function gds-quit))
-(define-key gds-mode-map " " (function gds-next))
-(define-key gds-mode-map "e" (function gds-evaluate))
-(define-key gds-mode-map "i" (function gds-step-in))
-(define-key gds-mode-map "o" (function gds-step-out))
-(define-key gds-mode-map "t" (function gds-trace-finish))
-(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 "H" (function gds-debug-trap-hooks))
-(define-key gds-mode-map "u" (function gds-up))
-(define-key gds-mode-map "d" (function gds-down))
-(define-key gds-mode-map "b" (function gds-set-breakpoint))
-
-(define-key gds-mode-map "vi" (function gds-view-interaction))
-(define-key gds-mode-map "vs" (function gds-view-stack))
-(define-key gds-mode-map "vb" (function gds-view-breakpoints))
-(define-key gds-mode-map "vB" (function gds-view-browser))
-(define-key gds-mode-map "vm" (function gds-view-messages))
-
-(defvar gds-view-menu nil
- "GDS view menu.")
-(if gds-view-menu
- nil
- (setq gds-view-menu (make-sparse-keymap "View"))
- (define-key gds-view-menu [messages]
- '(menu-item "Messages" gds-view-messages
- :enable (memq 'messages gds-views)))
- (define-key gds-view-menu [browser]
- '(menu-item "Browser" gds-view-browser
- :enable (memq 'browser gds-views)))
- (define-key gds-view-menu [breakpoints]
- '(menu-item "Breakpoints" gds-view-breakpoints
- :enable (memq 'breakpoints gds-views)))
- (define-key gds-view-menu [stack]
- '(menu-item "Stack" gds-view-stack
- :enable (memq 'stack gds-views)))
- (define-key gds-view-menu [interaction]
- '(menu-item "Interaction" gds-view-interaction
- :enable (memq 'interaction gds-views))))
-
-(defvar gds-debug-menu nil
- "GDS debugging menu.")
-(if gds-debug-menu
- nil
- (setq gds-debug-menu (make-sparse-keymap "Debug"))
- (define-key gds-debug-menu [go]
- '(menu-item "Go" gds-go))
- (define-key gds-debug-menu [down]
- '(menu-item "Move Down 1 Frame" gds-down))
- (define-key gds-debug-menu [up]
- '(menu-item "Move Up 1 Frame" gds-up))
- (define-key gds-debug-menu [trace-finish]
- '(menu-item "Trace This Frame" gds-trace-finish))
- (define-key gds-debug-menu [step-out]
- '(menu-item "Finish This Frame" gds-step-out))
- (define-key gds-debug-menu [next]
- '(menu-item "Next" gds-next))
- (define-key gds-debug-menu [step-in]
- '(menu-item "Single Step" gds-step-in))
- (define-key gds-debug-menu [eval]
- '(menu-item "Eval In This Frame..." gds-evaluate)))
-
-(defvar gds-breakpoint-menu nil
- "GDS breakpoint menu.")
-(if gds-breakpoint-menu
- nil
- (setq gds-breakpoint-menu (make-sparse-keymap "Breakpoint"))
- (define-key gds-breakpoint-menu [last-sexp]
- '(menu-item "Delete Breakpoint" gds-delete-source-breakpoint))
- (define-key gds-breakpoint-menu [set]
- '(menu-item "Set Breakpoint" gds-set-source-breakpoint)))
-
-(defvar gds-eval-menu nil
- "GDS evaluation menu.")
-(if gds-eval-menu
- nil
- (setq gds-eval-menu (make-sparse-keymap "Evaluate"))
- (define-key gds-eval-menu [load-file]
- '(menu-item "Load Scheme File" gds-load-file))
- (define-key gds-eval-menu [defun]
- '(menu-item "Defun At Point" gds-eval-defun))
- (define-key gds-eval-menu [region]
- '(menu-item "Region" gds-eval-region))
- (define-key gds-eval-menu [last-sexp]
- '(menu-item "Sexp Before Point" gds-eval-last-sexp))
- (define-key gds-eval-menu [expr]
- '(menu-item "Expression..." gds-eval-expression)))
-
-(defvar gds-help-menu nil
- "GDS help menu.")
-(if gds-help-menu
- nil
- (setq gds-help-menu (make-sparse-keymap "Help"))
- (define-key gds-help-menu [apropos]
- '(menu-item "Apropos..." gds-apropos))
- (define-key gds-help-menu [sym]
- '(menu-item "Symbol..." gds-help-symbol)))
-
-(defvar gds-advanced-menu nil
- "Menu of rarely needed GDS operations.")
-(if gds-advanced-menu
- nil
- (setq gds-advanced-menu (make-sparse-keymap "Advanced"))
- (define-key gds-advanced-menu [run-captive]
- '(menu-item "Run Captive Guile" gds-start-captive
- :enable (not (comint-check-proc gds-captive))))
- (define-key gds-advanced-menu [restart-gds]
- '(menu-item "Restart IDE" gds-start :enable gds-process))
- (define-key gds-advanced-menu [kill-gds]
- '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process))
- (define-key gds-advanced-menu [start-gds]
- '(menu-item "Start IDE" gds-start :enable (not gds-process))))
-
-(defvar gds-menu nil
- "Global menu for GDS commands.")
-(if gds-menu
- nil
- (setq gds-menu (make-sparse-keymap "Guile"))
- (define-key gds-menu [advanced]
- (cons "Advanced" gds-advanced-menu))
- (define-key gds-menu [separator-1]
- '("--"))
- (define-key gds-menu [view]
- `(menu-item "View" ,gds-view-menu :enable gds-views))
- (define-key gds-menu [debug]
- `(menu-item "Debug" ,gds-debug-menu :enable (and gds-client
- (gds-client-blocked))))
- (define-key gds-menu [breakpoint]
- `(menu-item "Breakpoints" ,gds-breakpoint-menu :enable t))
- (define-key gds-menu [eval]
- `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers
- gds-autostart-captive)))
- (define-key gds-menu [help]
- `(menu-item "Help" ,gds-help-menu :enable (or gds-buffers
- gds-autostart-captive)))
- (setq menu-bar-final-items
- (cons 'guile menu-bar-final-items))
- (define-key scheme-mode-map [menu-bar guile]
- (cons "Guile" gds-menu)))
-
-
-;;;; Autostarting the GDS server.
-
-(defcustom gds-autostart-server t
- "Whether to automatically start the GDS server when `gds.el' is loaded."
- :type 'boolean
- :group 'gds)
-
-
-;;;; `Captive' Guile - a Guile process that is started when needed to
-;;;; provide help, completion, evaluations etc.
-
-(defcustom gds-autostart-captive t
- "Whether to automatically start a `captive' Guile process when needed."
- :type 'boolean
- :group 'gds)
-
-(defvar gds-captive nil
- "Buffer of captive Guile.")
-
-(defun gds-start-captive (&optional restart)
- (interactive)
- (if (and restart
- (comint-check-proc gds-captive))
- (gds-kill-captive))
- (if (comint-check-proc gds-captive)
- nil
- (let ((process-connection-type nil))
- (setq gds-captive (make-comint "captive-guile"
- gds-guile-program
- nil
- "-q")))
- (let ((proc (get-buffer-process gds-captive)))
- (process-kill-without-query proc)
- (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n")
- (comint-send-string proc "(debug-enable 'backtrace)\n")
- (comint-send-string proc "(use-modules (emacs gds-client))\n")
- (comint-send-string proc "(gds-connect \"Captive Guile\" #f)\n"))))
-
-(defun gds-kill-captive ()
- (if gds-captive
- (condition-case nil
- (progn
- (kill-process (get-buffer-process gds-captive))
- (accept-process-output gds-process 0 200))
- (error))))
-
-
-;;;; If requested, autostart the server after loading.
-
-(if (and gds-autostart-server
- (not gds-process))
- (gds-start))
-
-
-;;;; The end!
-
-(provide 'gds)
-
-;;; gds.el ends here.
diff --git a/emacs/gud-guile.el b/emacs/gud-guile.el
index a0a70fabe..036194663 100644
--- a/emacs/gud-guile.el
+++ b/emacs/gud-guile.el
@@ -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
diff --git a/emacs/guile-c.el b/emacs/guile-c.el
index fe05159ec..af74b81e0 100644
--- a/emacs/guile-c.el
+++ b/emacs/guile-c.el
@@ -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:
diff --git a/emacs/guile-emacs.scm b/emacs/guile-emacs.scm
index 78b897e31..000d0cc2e 100644
--- a/emacs/guile-emacs.scm
+++ b/emacs/guile-emacs.scm
@@ -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:
diff --git a/emacs/guile-scheme.el b/emacs/guile-scheme.el
index 10ea10db7..5bd9a7c24 100644
--- a/emacs/guile-scheme.el
+++ b/emacs/guile-scheme.el
@@ -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:
diff --git a/emacs/guile.el b/emacs/guile.el
index 15f866fbb..e85c81c29 100644
--- a/emacs/guile.el
+++ b/emacs/guile.el
@@ -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:
diff --git a/emacs/multistring.el b/emacs/multistring.el
index 7b0ef30c1..25141ac58 100644
--- a/emacs/multistring.el
+++ b/emacs/multistring.el
@@ -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>
diff --git a/emacs/patch.el b/emacs/patch.el
index 868310a80..735a5468b 100644
--- a/emacs/patch.el
+++ b/emacs/patch.el
@@ -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
diff --git a/emacs/ppexpand.el b/emacs/ppexpand.el
index 39e113fba..2beb3bff6 100644
--- a/emacs/ppexpand.el
+++ b/emacs/ppexpand.el
@@ -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>
diff --git a/emacs/update-changelog.el b/emacs/update-changelog.el
index f9e4ff2ac..96db255b2 100644
--- a/emacs/update-changelog.el
+++ b/emacs/update-changelog.el
@@ -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: