diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/ChangeLog | 7 | ||||
| -rw-r--r-- | emacs/Makefile.am | 31 | ||||
| -rw-r--r-- | emacs/README.GDS | 0 | ||||
| -rw-r--r-- | emacs/gds-client.scm | 464 | ||||
| -rw-r--r-- | emacs/gds-server.scm | 98 |
5 files changed, 600 insertions, 0 deletions
diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 4d7b0bf53..eb6820a32 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,10 @@ +2003-11-11 Neil Jerram <neil@ossau.uklinux.net> + + * Makefile.am, README.GDS: New. + + * gds-client.scm, gds-server.scm: New (moved here from + ice-9/debugger/ui-{client,server}.scm). + 2003-08-20 Neil Jerram <neil@ossau.uklinux.net> * guileint: New subdirectory. diff --git a/emacs/Makefile.am b/emacs/Makefile.am new file mode 100644 index 000000000..e281ff03c --- /dev/null +++ b/emacs/Makefile.am @@ -0,0 +1,31 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2003 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 +ELCFILES = + +ETAGS_ARGS = $(subpkgdata_DATA) $(lisp_LISP) +EXTRA_DIST = $(subpkgdata_DATA) $(lisp_LISP) diff --git a/emacs/README.GDS b/emacs/README.GDS new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/emacs/README.GDS diff --git a/emacs/gds-client.scm b/emacs/gds-client.scm new file mode 100644 index 000000000..a560a2cd1 --- /dev/null +++ b/emacs/gds-client.scm @@ -0,0 +1,464 @@ +;;;; Guile Debugger UI client + +;;; 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-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 state) + #: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) + +;; The TCP port number that the UI server listens for application +;; connections on. +(define gds-port-number 8333) + +;; Once connected, the TCP socket port to the UI server. +(define gds-port #f) + +(define* (gds-connect name debug #:optional host) + "Connect to the debug UI server as @var{name}, a string that should +be sufficient to describe the calling application to the debug UI +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 stuff written to it is + ;; accumulated for sending to the debug server. + (set! (debugger-output-port) + (make-soft-port (vector accumulate-output + accumulate-output + #f #f #f #f) + "w")) + ;; Write initial context to debug server. + (write-form (list 'name name (getpid))) + (write-form (cons 'modules (map module-name (loaded-modules)))) + ;; Start the asynchronous UI thread. + (start-async-gds-thread) + ;; If `debug' is true, debug immediately. + (if debug + (debug-stack (make-stack #t gds-connect) #:continuable)) +; (gds-command-loop #f) + ) + +(define gds-disable-async-thread noop) +(define gds-continue-async-thread noop) +(define async-gds-thread #f) + +(define (start-async-gds-thread) + (let ((mutex (make-mutex)) + (condition (make-condition-variable)) + (admin (pipe))) + ;; Start the asynchronous UI thread. + (begin-thread + (set! async-gds-thread (current-thread)) + (lock-mutex mutex) + ;;(write (cons admin gds-port)) + ;;(newline) + (catch 'server-died + (lambda () + (let loop ((avail '())) + ;;(write avail) + ;;(newline) + (cond ((not gds-port)) ; exit loop + ((null? avail) + (write-status 'ready-for-input) + (loop (car (select (list gds-port (car admin)) + '() '())))) + (else + (let ((port (car avail))) + (if (eq? port gds-port) + (handle-instruction #f (read gds-port)) + (begin + ;; Notification from debugger that it + ;; wants to take over. Read the + ;; notification char. + (read-char (car admin)) + ;; Wait on condition variable - this allows the + ;; debugger thread to grab the mutex. + (wait-condition-variable condition mutex))) + ;; Loop. + (loop (cdr avail))))))) + (lambda args #f)) + (set! gds-disable-async-thread noop) + (set! gds-continue-async-thread noop) + (set! async-gds-thread #f) + (unlock-mutex mutex)) + ;; Redefine procs used by debugger thread to take control. + (set! gds-disable-async-thread + (lambda () + (write-char #\x (cdr admin)) + (force-output (cdr admin)) + ;;(display "gds-disable-async-thread: locking mutex...\n" + ;; (current-error-port)) + (lock-mutex mutex))) + (set! gds-continue-async-thread + (lambda () + (unlock-mutex mutex) + (signal-condition-variable condition))))) + +(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)) + +(define (gds-connected?) + "Return @code{#t} if a UI server connected has been made; else @code{#f}." + (not (not gds-port))) + +(define (gds-command-loop state) + "Interact with the UI frontend." + (or (gds-connected?) + (error "Not connected to UI server.")) + (gds-disable-async-thread) + (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*)) + (gds-continue-async-thread)) + +(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 (write-form form) + ;; Write any form FORM to UI frontend. + (write form gds-port) + (newline gds-port) + (force-output gds-port)) + +(define (stack->emacs-readable stack) + ;; Return Emacs-readable representation of STACK. + (map (lambda (index) + (frame->emacs-readable (stack-ref stack index))) + (iota (stack-length stack)))) + +(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)) + +(define the-ice-9-debugger-commands-module + (resolve-module '(ice-9 debugger commands))) + +(define internal-error-stack #f) + +(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 "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 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 name)) + string<?)))) + state) + ((debugger-command) + (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 (cadr ins)) (caddr ins))) + state) + ((eval) + (apply (lambda (module port-name line column code) + (with-input-from-string code + (lambda () + (set-port-filename! (current-input-port) port-name) + (set-port-line! (current-input-port) line) + (set-port-column! (current-input-port) column) + (let ((m (and module (resolve-module module)))) + (let loop ((results '()) (x (read))) + (if (eof-object? x) + (write-form `(eval-results ,@results)) + (loop (append results (gds-eval x m)) + (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 async-gds-thread (all-threads))))) + (write (cons 'target-thread thread)) + (newline) + (write (cons 'async-thread async-gds-thread)) + (newline) + (system-async-mark (lambda () + (debug-stack (make-stack #t 3) #:continuable)) + thread)) + state) + (else state))) + +(define (gds-eval x m) + ;; 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))) + (let ((value #f)) + (let* ((do-eval (if m + (lambda () + (display "Evaluating in module ") + (write (module-name m)) + (newline) + (set! value + (call-with-values (lambda () + (eval x m)) + value-consumer))) + (lambda () + (display "Evaluating in current module ") + (write (module-name (current-module))) + (newline) + (set! value + (call-with-values (lambda () + (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)))) + +(define (write-status status) + (write-form (list 'current-module + (format #f "~S" (module-name (current-module))))) + (write-form (list 'status status))) + +(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)))))) + +;;; (emacs gds-client) ends here. diff --git a/emacs/gds-server.scm b/emacs/gds-server.scm new file mode 100644 index 000000000..c472ee359 --- /dev/null +++ b/emacs/gds-server.scm @@ -0,0 +1,98 @@ +;;;; 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)))))) |