Moved all gds files here; plus ongoing work on them.

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))))))