diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/Makefile.am | 38 | ||||
| -rw-r--r-- | emacs/gds-client.scm | 726 | ||||
| -rw-r--r-- | emacs/gds-server.scm | 98 | ||||
| -rw-r--r-- | emacs/gds.el | 1626 | ||||
| -rw-r--r-- | emacs/gud-guile.el | 4 | ||||
| -rw-r--r-- | emacs/guile-c.el | 4 | ||||
| -rw-r--r-- | emacs/guile-emacs.scm | 4 | ||||
| -rw-r--r-- | emacs/guile-scheme.el | 4 | ||||
| -rw-r--r-- | emacs/guile.el | 4 | ||||
| -rw-r--r-- | emacs/multistring.el | 4 | ||||
| -rw-r--r-- | emacs/patch.el | 4 | ||||
| -rw-r--r-- | emacs/ppexpand.el | 4 | ||||
| -rw-r--r-- | emacs/update-changelog.el | 4 |
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: |