/[guile]/guile/guile-core/emacs/gds.el
ViewVC logotype

Diff of /guile/guile-core/emacs/gds.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by ossau, Tue Nov 11 23:40:38 2003 UTC revision 1.6 by ossau, Wed Nov 19 01:22:06 2003 UTC
# Line 26  Line 26 
26  (require 'scheme)  (require 'scheme)
27    
28    
 ;;;; Debugging (of this code!).  
   
 (defsubst dmessage (msg &rest args)  
   ;;(apply (function message) msg args)  
   )  
   
   
29  ;;;; Customization group setup.  ;;;; Customization group setup.
30    
31  (defgroup gds nil  (defgroup gds nil
# Line 122  Line 115 
115  ;; competing for user attention.  ;; competing for user attention.
116  ;;  ;;
117  ;; - `gds-waiting' holds a list of clients that want attention but  ;; - `gds-waiting' holds a list of clients that want attention but
118  ;; haven't yet got it.  A client is added to this list for two  ;;   haven't yet got it.  A client is added to this list for two
119  ;; reasons.  (1) When it is blocked waiting for user input.  (2) When  ;;   reasons.  (1) When it is blocked waiting for user input.
120  ;; it first connects to GDS, even if not blocked.  ;;   (2) When it first connects to GDS, even if not blocked.
121  ;;  ;;
122  ;; - `gds-focus-client' holds the client, if any, that currently has  ;; - `gds-focus-client' holds the client, if any, that currently has
123  ;; the user's attention.  A client can be given the focus if  ;;   the user's attention.  A client can be given the focus if
124  ;; `gds-focus-client' is nil at the time that the client wants  ;;   `gds-focus-client' is nil at the time that the client wants
125  ;; attention, or if another client relinquishes it.  A client can  ;;   attention, or if another client relinquishes it.  A client can
126  ;; relinquish the focus in two ways.  (1) If the client application  ;;   relinquish the focus in two ways.  (1) If the client application
127  ;; says that it is no longer blocked, and a small time passes without  ;;   says that it is no longer blocked, and a small time passes without
128  ;; it becoming blocked again.  (2) If the user explicitly `quits' that  ;;   it becoming blocked again.  (2) If the user explicitly `quits'
129  ;; client.  ;;   that client.
130  (defvar gds-focus-client nil)  (defvar gds-focus-client nil)
131  (defvar gds-waiting nil)  (defvar gds-waiting nil)
132    
 ;; Sometimes we want to display a client buffer immediately even if it  
 ;; isn't already in the selected window.  To do we this, we bind the  
 ;; following variable to non-nil.  
 (defvar gds-immediate-display nil)  
   
133  (defun gds-request-focus (client)  (defun gds-request-focus (client)
134    (cond ((eq client gds-focus-client)    (cond ((eq client gds-focus-client)
135           ;; CLIENT already has the focus.  Display its buffer.           ;; CLIENT already has the focus.  Display its buffer.
# Line 162  Line 150 
150            (not (gds-client-blocked))            (not (gds-client-blocked))
151            (y-or-n-p            (y-or-n-p
152             "Client is blocked and no others are waiting.  Still quit? "))             "Client is blocked and no others are waiting.  Still quit? "))
153        (let ((gds-immediate-display        (progn
              (eq (window-buffer (selected-window)) (current-buffer))))  
154          (bury-buffer (current-buffer))          (bury-buffer (current-buffer))
155          ;; Pass on the focus.          ;; Pass on the focus.
156          (setq gds-focus-client (car gds-waiting)          (setq gds-focus-client (car gds-waiting)
# Line 176  Line 163 
163              (gds-request-focus gds-focus-client)))))              (gds-request-focus gds-focus-client)))))
164    
165    
166    ;;;; GDS protocol dispatch.
167    
168    ;; General dispatch function called by the subprocess filter.
169    (defun gds-handle-input (form)
170      (let ((client (car form)))
171        (or (eq client '*)
172            (let* ((proc (cadr form))
173                   (args (cddr form))
174                   (buf (gds-client-buffer client proc args)))
175              (if buf (gds-handle-client-input buf client proc args))))))
176    
177    (defun gds-handle-client-input (buf client proc args)
178      (with-current-buffer buf
179        (with-current-buffer gds-transcript
180          (goto-char (point-max))
181          (let ((inhibit-read-only t))
182            (insert (format "<%S %S %S>" client proc args) "\n")))
183        (cond (;; (name ...) - Client name.
184               (eq proc 'name)
185               (setq gds-pid (cadr args))
186               (gds-promote-view 'interaction)
187               (gds-request-focus client))
188    
189              (;; (current-module ...) - Current module.
190               (eq proc 'current-module)
191               (setq gds-current-module (car args)))
192    
193              (;; (stack ...) - Stack at an error or breakpoint.
194               (eq proc 'stack)
195               (setq gds-stack args)
196               (gds-promote-view 'stack))
197    
198              (;; (modules ...) - Application's loaded modules.
199               (eq proc 'modules)
200               (while args
201                 (or (assoc (car args) gds-modules)
202                     (setq gds-modules (cons (list (car args)) gds-modules)))
203                 (setq args (cdr args))))
204    
205              (;; (output ...) - Last printed output.
206               (eq proc 'output)
207               (setq gds-output (car args))
208               (gds-add-view 'messages))
209    
210              (;; (status ...) - Application status indication.
211               (eq proc 'status)
212               (setq gds-status (car args))
213               (if (eq gds-status 'running)
214                   (gds-delete-view 'browser)
215                 (gds-add-view 'browser))
216               (if (eq gds-status 'waiting-for-input)
217                   (progn
218                     (gds-promote-view 'stack)
219                     (gds-update-buffers)
220                     (gds-request-focus client))
221                 (setq gds-stack nil)
222                 (gds-delete-view 'stack)
223                 (gds-update-buffers-in-a-while)))
224    
225              (;; (module MODULE ...) - The specified module's bindings.
226               (eq proc 'module)
227               (let ((minfo (assoc (car args) gds-modules)))
228                 (if minfo
229                     (setcdr (cdr minfo) (cdr args)))))
230    
231              (;; (closed) - Client has gone away.
232               (eq proc 'closed)
233               (setq gds-status 'closed)
234               (gds-update-buffers)
235               (setq gds-buffers
236                     (delq (assq client gds-buffers) gds-buffers))
237               (if (eq client gds-focus-client)
238                   (gds-quit)))
239    
240              (;; (eval-results ...) - Results of evaluation.
241               (eq proc 'eval-results)
242               (gds-display-results client args))
243    
244              ((eq proc 'completion-result)
245               (setq gds-completion-results (or (car args) t)))
246    
247              )))
248    
249    
250  ;;;; Per-client buffer state.  ;;;; Per-client buffer state.
251    
252    ;; This section contains code that is specific to each Guile client's
253    ;; buffer but independent of any particular `view'.
254    
255    ;; Alist mapping each client port number to corresponding buffer.
256    (defvar gds-buffers nil)
257    
258  (define-derived-mode gds-mode  (define-derived-mode gds-mode
259    scheme-mode    scheme-mode
260    "Guile Interaction"    "Guile Interaction"
# Line 187  Line 264 
264    "GDS client's port number.")    "GDS client's port number.")
265  (make-variable-buffer-local 'gds-client)  (make-variable-buffer-local 'gds-client)
266    
267  (defvar gds-current-module "()"  (defvar gds-status nil
268    "GDS client's current module.")    "GDS client's latest status, one of the following symbols.
269  (make-variable-buffer-local 'gds-current-module)  `running' - Application is running.
270    `waiting-for-input' - Application is blocked waiting for instruction
271                          from the frontend.
272    `ready-for-input' - Application is not blocked but can also accept
273                        asynchronous instructions from the frontend.")
274    (make-variable-buffer-local 'gds-status)
275    
276  (defvar gds-stack nil  (defvar gds-transcript nil
277    "GDS client's stack when last stopped.")    "Transcript buffer for this GDS client.")
278  (make-variable-buffer-local 'gds-stack)  (make-variable-buffer-local 'gds-transcript)
279    
280  (defvar gds-modules nil  ;; Return client buffer for specified client and protocol input.
281    "GDS client's module information.  (defun gds-client-buffer (client proc args)
282  Alist mapping module names to their symbols and related information.    (if (eq proc 'name)
283  This looks like:        ;; Introduction from client - create a new buffer.
284          (with-current-buffer (generate-new-buffer (car args))
285            (gds-mode)
286            (setq gds-client client)
287            (setq gds-transcript
288                  (find-file-noselect
289                   (expand-file-name (concat "~/.gds-transcript-" (car args)))))
290            (with-current-buffer gds-transcript
291              (goto-char (point-max))
292              (insert "\nTranscript:\n"))
293            (setq gds-buffers
294                  (cons (cons client (current-buffer))
295                        gds-buffers))
296            (current-buffer))
297        ;; Otherwise there should be an existing buffer that we can
298        ;; return.
299        (let ((existing (assq client gds-buffers)))
300          (if (buffer-live-p (cdr existing))
301              (cdr existing)
302            (setq gds-buffers (delq existing gds-buffers))
303            (gds-client-buffer client 'name '("(GDS buffer killed)"))))))
304    
305   (((guile) t sym1 sym2 ...)  (defun gds-client-blocked ()
306    ((guile-user))    (eq gds-status 'waiting-for-input))
   ((ice-9 debug) nil sym3 sym4)  
   ...)  
307    
308  The `t' or `nil' after the module name indicates whether the module is  (defvar gds-delayed-update-timer nil)
 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)  
309    
310  (defvar gds-output nil  (defvar gds-delayed-update-buffers nil)
   "GDS client's recent output (printed).")  
 (make-variable-buffer-local 'gds-output)  
311    
312  (defvar gds-status nil  (defun gds-update-delayed-update-buffers ()
313    "GDS client's latest status, one of the following symbols.    (while gds-delayed-update-buffers
314        (with-current-buffer (car gds-delayed-update-buffers)
315          (setq gds-delayed-update-buffers
316                (cdr gds-delayed-update-buffers))
317          (gds-update-buffers))))
318          
319    (defun gds-update-buffers ()
320      (if (timerp gds-delayed-update-timer)
321          (cancel-timer gds-delayed-update-timer))
322      (setq gds-delayed-update-timer nil)
323      (let ((view (car gds-views))
324            (inhibit-read-only t))
325        (cond ((eq view 'stack)
326               (gds-insert-stack))
327              ((eq view 'interaction)
328               (gds-insert-interaction))
329              ((eq view 'browser)
330               (gds-insert-modules))
331              ((eq view 'messages)
332               (gds-insert-messages))
333              (t
334               (error "Bad GDS view %S" view)))
335        ;; Finish off.
336        (widget-setup)
337        (force-mode-line-update t)))
338    
339  `running' - application is running.  (defun gds-update-buffers-in-a-while ()
340      (or (memq (current-buffer) gds-delayed-update-buffers)
341          (setq gds-delayed-update-buffers
342                (cons (current-buffer) gds-delayed-update-buffers)))
343      (if (timerp gds-delayed-update-timer)
344          nil
345        (setq gds-delayed-update-timer
346              (run-at-time 0.5 nil (function gds-update-delayed-update-buffers)))))
347    
348  `waiting-for-input' - application is blocked waiting for instruction  (defun gds-display-buffers ()
349  from the frontend.    (if gds-focus-client
350          (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers))))
351            ;; If there's already a window showing the buffer, use it.
352            (let ((window (get-buffer-window gds-focus-buffer t)))
353              (if window
354                  (progn
355                    (make-frame-visible (window-frame window))
356                    (select-frame (window-frame window))
357                    (select-window window))
358                ;(select-window (display-buffer gds-focus-buffer))
359                (display-buffer gds-focus-buffer)))
360            ;; If there is an associated source buffer, display it as well.
361            (if (and (eq (car gds-views) 'stack)
362                     gds-frame-source-overlay
363                     (> (overlay-end gds-frame-source-overlay) 0))
364                (let ((window (display-buffer
365                               (overlay-buffer gds-frame-source-overlay))))
366                  (set-window-point window
367                                    (overlay-start gds-frame-source-overlay)))))))
368    
369  `ready-for-input' - application is not blocked but can also accept  
370  asynchronous instructions from the frontend.")  ;;;; Management of `views'.
371  (make-variable-buffer-local 'gds-status)  
372    ;; The idea here is to keep the buffer describing a Guile client
373    ;; relatively uncluttered by only showing one kind of information
374    ;; about that client at a time.  Menu items and key sequences are
375    ;; provided to switch easily between the available views.
376    
377    (defvar gds-views nil
378      "List of available views for a GDS client.  Each element is one of
379    the following symbols.
380    `interaction' - Interaction with running client.
381    `stack' - Call stack view.
382    `browser' - Modules and bindings browser view.
383    `breakpoints' - List of set breakpoints.
384    `messages' - Non-GDS-protocol output from the debugger.")
385    (make-variable-buffer-local 'gds-views)
386    
387    (defun gds-promote-view (view)
388      (setq gds-views (cons view (delq view gds-views))))
389    
390    (defun gds-switch-to-view (view)
391      (or (memq view gds-views)
392          (error "View %S is not available" view))
393      (gds-promote-view view)
394      (gds-update-buffers))
395    
396    (defun gds-add-view (view)
397      (or (memq view gds-views)
398          (setq gds-views (append gds-views (list view)))))
399    
400    (defun gds-delete-view (view)
401      (setq gds-views (delq view gds-views)))
402    
403    
404    ;;;; `Interaction' view.
405    
406    ;; This view provides interaction with a normally running Guile
407    ;; client, in other words one that is not stopped in the debugger but
408    ;; is still available to take input from GDS (usually via a thread for
409    ;; that purpose).  The view supports evaluation, help requests,
410    ;; control of `debug-on-exception' function, and methods for breaking
411    ;; into the running code.
412    
413    (defvar gds-current-module "()"
414      "GDS client's current module.")
415    (make-variable-buffer-local 'gds-current-module)
416    
417  (defvar gds-pid nil  (defvar gds-pid nil
418    "GDS client's process ID.")    "GDS client's process ID.")
# Line 239  asynchronous instructions from the front Line 426  asynchronous instructions from the front
426    "The exception keys for which to debug a GDS client.")    "The exception keys for which to debug a GDS client.")
427  (make-variable-buffer-local 'gds-exception-keys)  (make-variable-buffer-local 'gds-exception-keys)
428    
429  ;; Cached display variables for `gds-update-buffers'.  (defun gds-insert-interaction ()
430  (defvar gds-displayed-modules nil)    (erase-buffer)
431  (make-variable-buffer-local 'gds-displayed-modules)    ;; Insert stuff for interacting with a running (non-blocked) Guile
432      ;; client.
433  ;; Types of display areas in the *Guile* buffer.    (widget-insert (buffer-name)
434  (defvar gds-display-types '("\\`"                   ", "
435                              "^Modules:"                   (cdr (assq gds-status
436                              "^Transcript:"))                              '((running . "running (cannot accept input)")
437  (defvar gds-display-type-regexp                                (waiting-for-input . "waiting for input")
438    (concat "\\("                                (ready-for-input . "running")
439            (substring (apply (function concat)                                (closed . "closed"))))
440                              (mapcar (lambda (type)                   ", in "
441                                        (concat "\\|" type))                   gds-current-module
442                                      gds-display-types))                   "\n")
443                       2)    (widget-create 'push-button
444            "\\)"))                   :notify (function gds-sigint)
445                     "SIGINT")
446  (defun gds-maybe-delete-region (regexp)    (widget-insert " ")
447    (let ((beg (save-excursion    (widget-create 'push-button
448                 (goto-char (point-min))                   :notify (function gds-async-break)
449                 (and (re-search-forward regexp nil t)                   "Break")
450                      (match-beginning 0)))))    (widget-insert "\n")
451      (if beg    (widget-create 'checkbox
452          (delete-region beg                   :notify (function gds-toggle-debug-exceptions)
453                         (save-excursion                   gds-debug-exceptions)
454                           (goto-char beg)    (widget-insert " Debug exception keys: ")
455                           (end-of-line)    (widget-create 'editable-field
456                           (or (and (re-search-forward gds-display-type-regexp                   :notify (function gds-set-exception-keys)
457                                                       nil t)                   gds-exception-keys)
458                                    (match-beginning 0))    (widget-insert "\n"))
                              (point-max)))))))  
   
 (defun gds-maybe-skip-region (regexp)  
   (if (looking-at regexp)  
       (if (re-search-forward gds-display-type-regexp nil t 2)  
           (beginning-of-line)  
         (goto-char (point-max)))))  
   
 (defun gds-update-buffers (client)  
   (dmessage "gds-update-buffers")  
   ;; Avoid continually popping up the last associated source buffer  
   ;; unless it really is still current.  
   (setq gds-selected-frame-source-buffer nil)  
   (set-buffer (cdr (assq client gds-buffers)))  
   (force-mode-line-update t)  
   (let ((inhibit-read-only t)  
         (p (if (eq client gds-focus-client)  
                (point)  
              (point-min)))  
         stack-changed)  
     ;; Start at top of buffer.  
     (goto-char (point-min))  
     ;; Display status; too simple to be worth caching.  
     (gds-maybe-delete-region (concat "\\`" (regexp-quote (buffer-name))))  
     (widget-insert (buffer-name)  
                    ", "  
                    (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")  
     (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)  
     (widget-insert "\n")  
 ;     (widget-insert "\n\n")  
 ;     (if (> (length gds-output) 0)  
 ;       (widget-insert gds-output "\n\n"))  
     ;; Display stack.  
     (dmessage "insert stack")  
     (let ((stack gds-stack)  
           (buf (get-buffer-create (concat (buffer-name) " - stack"))))  
       (with-current-buffer buf  
         (if (equal stack gds-stack)  
             ;; No change needed.  
             nil  
           (erase-buffer)  
           (gds-mode)  
           ;; Insert new stack.                  
           (if stack (gds-insert-stack stack))  
           ;; Record displayed stack.  
           (setq gds-stack stack))))        
     ;; Display module list.  
     (dmessage "insert modules")  
     (if (equal gds-modules gds-displayed-modules)  
         (gds-maybe-skip-region "^Modules:")  
       ;; Delete existing module list.  
       (gds-maybe-delete-region "^Modules:")  
       ;; Insert new list.  
       (if gds-modules (gds-insert-modules gds-modules))  
       ;; Record displayed list.  
       (setq gds-displayed-modules (copy-tree gds-modules)))  
     ;; Finish off.  
     (dmessage "widget-setup")  
     (widget-setup)  
     (if stack-changed  
         ;; Stack is being seen for the first time, so make sure top of  
         ;; buffer is visible.  
         (progn  
           (goto-char (point-min))  
           (forward-line (+ 1 (cadr gds-stack))))  
       ;; Restore point from before buffer was redrawn.  
       (goto-char p))))  
459    
460  (defun gds-sigint (w &rest ignore)  (defun gds-sigint (w &rest ignore)
461    (interactive)    (interactive)
# Line 378  asynchronous instructions from the front Line 477  asynchronous instructions from the front
477    (interactive)    (interactive)
478    (setq gds-exception-keys (widget-value w)))    (setq gds-exception-keys (widget-value w)))
479    
480  (defun gds-display-buffers ()  (defun gds-view-interaction ()
481    (if gds-focus-client    (interactive)
482        (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers))))    (gds-switch-to-view 'interaction))
483          ;; If there's already a window showing the buffer, use it.  
484          (let ((window (get-buffer-window gds-focus-buffer t)))  
485            (if window  ;;;; `Stack' view.
486                (progn  
487                  (make-frame-visible (window-frame window))  ;; This view shows the Guile call stack after the application has hit
488                  (select-frame (window-frame window))  ;; an error, or when it is stopped in the debugger.
489                  (select-window window))  
490              ;(select-window (display-buffer gds-focus-buffer))  (defvar gds-stack nil
491              (display-buffer gds-focus-buffer)))    "GDS client's stack when last stopped.")
492          ;; If there is an associated source buffer, display it as well.  (make-variable-buffer-local 'gds-stack)
493          (if gds-selected-frame-source-buffer  
494              (let ((window (display-buffer gds-selected-frame-source-buffer)))  (defun gds-insert-stack ()
495                (set-window-point window    (erase-buffer)
496                                  (overlay-start    (let ((frames (car gds-stack))
497                                   gds-selected-frame-source-overlay))))          (index (cadr gds-stack))
498          ;; If there is a stack to display, display it.          (flags (caddr gds-stack))
         (if gds-stack  
             (let ((buf (get-buffer (concat (buffer-name) " - stack"))))  
               (if (get-buffer-window buf)  
                   nil  
                 (split-window)  
                 (set-window-buffer (selected-window) buf)))))))  
   
 (defun gds-insert-stack (stack)  
   (let ((frames (car stack))  
         (index (cadr stack))  
         (flags (caddr stack))  
499          frame items)          frame items)
500      (cond ((memq 'application flags)      (cond ((memq 'application flags)
501             (widget-insert "Calling procedure:\n"))             (widget-insert "Calling procedure:\n"))
# Line 436  asynchronous instructions from the front Line 524  asynchronous instructions from the front
524               :value (cadr (nth index items))               :value (cadr (nth index items))
525               :notify (function gds-select-stack-frame)               :notify (function gds-select-stack-frame)
526               items)               items)
527      (widget-insert "\n")))      (widget-insert "\n")
528        (goto-char (point-min))))
529    
530  (defun gds-select-stack-frame (widget &rest ignored)  (defun gds-select-stack-frame (widget &rest ignored)
531    (let* ((s (widget-value widget))    (let* ((s (widget-value widget))
# Line 447  asynchronous instructions from the front Line 536  asynchronous instructions from the front
536    
537  ;; Overlay used to highlight the source expression corresponding to  ;; Overlay used to highlight the source expression corresponding to
538  ;; the selected frame.  ;; the selected frame.
539  (defvar gds-selected-frame-source-overlay nil)  (defvar gds-frame-source-overlay nil)
   
 ;; Buffer containing source for the selected frame.  
 (defvar gds-selected-frame-source-buffer nil)  
540    
541  (defun gds-show-selected-frame (source)  (defun gds-show-selected-frame (source)
542    ;; Highlight the frame source, if possible.    ;; Highlight the frame source, if possible.
543    (if (and source    (if (and source
544             (file-readable-p (car source)))             (file-readable-p (car source)))
545        (with-current-buffer (find-file-noselect (car source))        (with-current-buffer (find-file-noselect (car source))
546          (if gds-selected-frame-source-overlay          (if gds-frame-source-overlay
547              nil              nil
548            (setq gds-selected-frame-source-overlay (make-overlay 0 0))            (setq gds-frame-source-overlay (make-overlay 0 0))
549            (overlay-put gds-selected-frame-source-overlay 'face 'highlight))            (overlay-put gds-frame-source-overlay 'face 'highlight))
550          ;; Move to source line.  Note that Guile line numbering is          ;; Move to source line.  Note that Guile line numbering is
551          ;; 0-based, while Emacs numbering is 1-based.          ;; 0-based, while Emacs numbering is 1-based.
552          (save-restriction          (save-restriction
553            (widen)            (widen)
554            (goto-line (+ (cadr source) 1))            (goto-line (+ (cadr source) 1))
555            (move-to-column (caddr source))            (move-to-column (caddr source))
556            (move-overlay gds-selected-frame-source-overlay            (move-overlay gds-frame-source-overlay
557                          (point)                          (point)
558                          (if (not (looking-at ")"))                          (if (not (looking-at ")"))
559                              (save-excursion (forward-sexp 1) (point))                              (save-excursion (forward-sexp 1) (point))
# Line 476  asynchronous instructions from the front Line 562  asynchronous instructions from the front
562                            ;; the sexp rather than the beginning...                            ;; the sexp rather than the beginning...
563                            (save-excursion (forward-char 1)                            (save-excursion (forward-char 1)
564                                            (backward-sexp 1) (point)))                                            (backward-sexp 1) (point)))
565                          (current-buffer)))                          (current-buffer))))
566          (setq gds-selected-frame-source-buffer (current-buffer)))      (if gds-frame-source-overlay
567      (if gds-selected-frame-source-overlay          (move-overlay gds-frame-source-overlay 0 0))))
568          (move-overlay gds-selected-frame-source-overlay 0 0))))  
569    (defun gds-view-stack ()
570      (interactive)
571      (gds-switch-to-view 'stack))
572    
573    
574    ;;;; `Breakpoints' view.
575    
576    ;; This view shows a list of breakpoints.
577    
578    (defun gds-view-breakpoints ()
579      (interactive)
580      (gds-switch-to-view 'breakpoints))
581    
582    
583    ;;;; `Browser' view.
584    
585    ;; This view shows a list of modules and module bindings.
586    
587  (defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))  (defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
588    "Specification of which Guile modules the debugger should display.    "Specification of which Guile modules the debugger should display.
# Line 510  not of primary interest when debugging a Line 613  not of primary interest when debugging a
613              (gds-show-module-p (cdr name)))              (gds-show-module-p (cdr name)))
614          default))))          default))))
615    
616  (defun gds-insert-modules (modules)  (defvar gds-modules nil
617    (insert "Modules:\n")    "GDS client's module information.
618    (while modules  Alist mapping module names to their symbols and related information.
619      (let ((minfo (car modules)))  This looks like:
620        (if (gds-show-module-p (car minfo))  
621            (let ((w (widget-create 'push-button   (((guile) t sym1 sym2 ...)
622                                    :notify (function gds-module-notify)    ((guile-user))
623                                    (if (and (cdr minfo)    ((ice-9 debug) nil sym3 sym4)
624                                             (cadr minfo))    ...)
625                                        "-" "+"))))  
626              (widget-put w :module (cons client (car minfo)))  The `t' or `nil' after the module name indicates whether the module is
627              (widget-insert " " (prin1-to-string (car minfo)) "\n")  displayed in expanded form (that is, showing the bindings in that
628              (if (cadr minfo)  module).  The syms are actually all strings because some Guile symbols
629                  (let ((syms (cddr minfo)))  are not readable by Emacs.")
630                    (while syms  (make-variable-buffer-local 'gds-modules)
631                      (widget-insert " > " (car syms) "\n")  
632                      (setq syms (cdr syms))))))))  (defun gds-insert-modules ()
633      (setq modules (cdr modules)))    (let ((p (if (eq (window-buffer (selected-window)) (current-buffer))
634    (insert "\n"))                 (point)
635                 (point-min)))
636            (modules gds-modules))
637        (erase-buffer)
638        (insert "Modules:\n")
639        (while modules
640          (let ((minfo (car modules)))
641            (if (gds-show-module-p (car minfo))
642                (let ((w (widget-create 'push-button
643                                        :notify (function gds-module-notify)
644                                        (if (and (cdr minfo)
645                                                 (cadr minfo))
646                                            "-" "+"))))
647                  (widget-put w :module (cons gds-client (car minfo)))
648                  (widget-insert " " (prin1-to-string (car minfo)) "\n")
649                  (if (cadr minfo)
650                      (let ((syms (cddr minfo)))
651                        (while syms
652                          (widget-insert " > " (car syms) "\n")
653                          (setq syms (cdr syms))))))))
654          (setq modules (cdr modules)))
655        (insert "\n")
656        (goto-char p)))
657    
658  (defun gds-module-notify (w &rest ignore)  (defun gds-module-notify (w &rest ignore)
659    (let* ((module (widget-get w :module))    (let* ((module (widget-get w :module))
# Line 539  not of primary interest when debugging a Line 664  not of primary interest when debugging a
664          ;; Just toggle expansion state.          ;; Just toggle expansion state.
665          (progn          (progn
666            (setcar (cdr minfo) (not (cadr minfo)))            (setcar (cdr minfo) (not (cadr minfo)))
667            (gds-update-buffers client))            (gds-update-buffers))
668        ;; Set flag to indicate module expanded.        ;; Set flag to indicate module expanded.
669        (setcdr minfo (list t))        (setcdr minfo (list t))
670        ;; Get symlist from Guile.        ;; Get symlist from Guile.
# Line 549  not of primary interest when debugging a Line 674  not of primary interest when debugging a
674    (interactive)    (interactive)
675    (gds-send (format "(%S query-modules)\n" gds-focus-client)))    (gds-send (format "(%S query-modules)\n" gds-focus-client)))
676    
677    (defun gds-view-browser ()
678      (interactive)
679      (or gds-modules (gds-query-modules))
680      (gds-switch-to-view 'browser))
681    
 ;;;; Handling debugging instructions.  
   
 ;; Alist mapping each client port number to corresponding buffer.  
 (defvar gds-buffers nil)  
   
 ;; 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)  
         (insert "Transcript:\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)"))))))  
   
 ;; General dispatch function called by the subprocess filter.  
 (defun gds-handle-input (form)  
   (dmessage "Form: %S" 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  
     (save-excursion  
       (goto-char (point-max))  
       (let ((inhibit-read-only t))  
         (insert (format "<%S %S %S>" client proc args) "\n")))  
     (dmessage "Buffer: %S" (current-buffer))  
     (cond (;; (name ...) - Client name.  
            (eq proc 'name)  
            (setq gds-pid (cadr args))  
            (gds-request-focus client))  
   
           (;; (current-module ...) - Current module.  
            (eq proc 'current-module)  
            (setq gds-current-module (car args))  
            (dmessage "Current module: %S" gds-current-module))  
   
           (;; (stack ...) - Stack at an error or breakpoint.  
            (eq proc 'stack)  
            (setq gds-stack args))  
   
           (;; (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)))  
   
           (;; (status ...) - Application status indication.  
            (eq proc 'status)  
            (setq gds-status (car args))  
            (or (eq gds-status 'waiting-for-input)  
                (setq gds-stack nil))  
            (gds-update-buffers client)  
            (if (eq gds-status 'waiting-for-input)  
                (gds-request-focus client)  
              (setq gds-stack nil)))  
   
           (;; (module MODULE ...) - The specified module's bindings.  
            (eq proc 'module)  
            (let ((minfo (assoc (car args) gds-modules)))  
              (if minfo  
                  (setcdr (cdr minfo) (cdr args)))))  
682    
683            (;; (closed) - Client has gone away.  ;;;; `Messages' view.
            (eq proc 'closed)  
            (setq gds-status 'closed)  
            (gds-update-buffers client)  
            (setq gds-buffers  
                  (delq (assq client gds-buffers) gds-buffers))  
            (if (eq client gds-focus-client)  
                (gds-quit)))  
684    
685            (;; (eval-results ...) - Results of evaluation.  ;; This view shows recent non-GDS-protocol messages output from the
686             (eq proc 'eval-results)  ;; (ice-9 debugger) code.
            (gds-display-results client args))  
687    
688            ((eq proc 'completion-result)  (defvar gds-output nil
689             (setq gds-completion-results (or (car args) t)))    "GDS client's recent output (printed).")
690    (make-variable-buffer-local 'gds-output)
691    
692            )))  (defun gds-insert-messages ()
693      (erase-buffer)
694      ;; Insert recent non-protocol output from (ice-9 debugger).
695      (insert gds-output)
696      (goto-char (point-min)))
697    
698    (defun gds-view-messages ()
699      (interactive)
700      (gds-switch-to-view 'messages))
701    
 ;;;; Guile Debugging keymap.  
702    
703  (set-keymap-parent gds-mode-map widget-keymap)  ;;;; Debugger commands.
 (define-key gds-mode-map "g" (function gds-go))  
 (define-key gds-mode-map "b" (function gds-set-breakpoint))  
 (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 "M" (function gds-query-modules))  
704    
705  (defun gds-client-blocked ()  ;; Typically but not necessarily used from the `stack' view.
   (eq gds-status 'waiting-for-input))  
706    
707  (defun gds-go ()  (defun gds-go ()
708    (interactive)    (interactive)
# Line 704  not of primary interest when debugging a Line 739  not of primary interest when debugging a
739    (interactive)    (interactive)
740    (gds-send (format "(%S debugger-command info-args)\n" gds-focus-client)))    (gds-send (format "(%S debugger-command info-args)\n" gds-focus-client)))
741    
742    
743    ;;;; Setting breakpoints.
744    
745  (defun gds-set-breakpoint ()  (defun gds-set-breakpoint ()
746    (interactive)    (interactive)
747    (cond ((gds-in-source-buffer)    (cond ((gds-in-source-buffer)
# Line 1025  Used for determining the default for the Line 1063  Used for determining the default for the
1063    (setq client (gds-choose-client client))    (setq client (gds-choose-client client))
1064    (gds-send (format "(%S load %S)\n" client file-name)))    (gds-send (format "(%S load %S)\n" client file-name)))
1065    
1066  ;; Install the process communication commands in the scheme-mode keymap.  
1067    ;;;; Scheme mode keymap items.
1068    
1069  (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention  (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention
1070  (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention  (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention
1071  (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)  (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
# Line 1036  Used for determining the default for the Line 1076  Used for determining the default for the
1076  (define-key scheme-mode-map "\e\t" 'gds-complete-symbol)  (define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
1077    
1078    
1079  ;;;; Menu bar entries.  ;;;; GDS (Guile Interaction) mode keymap and menu items.
1080    
1081    (set-keymap-parent gds-mode-map widget-keymap)
1082    
1083    (define-key gds-mode-map "M" (function gds-query-modules))
1084    
1085    (define-key gds-mode-map "g" (function gds-go))
1086    (define-key gds-mode-map "q" (function gds-quit))
1087    (define-key gds-mode-map " " (function gds-next))
1088    (define-key gds-mode-map "e" (function gds-evaluate))
1089    (define-key gds-mode-map "i" (function gds-step-in))
1090    (define-key gds-mode-map "o" (function gds-step-out))
1091    (define-key gds-mode-map "t" (function gds-trace-finish))
1092    (define-key gds-mode-map "I" (function gds-frame-info))
1093    (define-key gds-mode-map "A" (function gds-frame-args))
1094    
1095    (define-key gds-mode-map "b" (function gds-set-breakpoint))
1096    
1097    (define-key gds-mode-map "vi" (function gds-view-interaction))
1098    (define-key gds-mode-map "vs" (function gds-view-stack))
1099    (define-key gds-mode-map "vb" (function gds-view-breakpoints))
1100    (define-key gds-mode-map "vB" (function gds-view-browser))
1101    (define-key gds-mode-map "vm" (function gds-view-messages))
1102    
1103    (defvar gds-view-menu nil
1104      "GDS view menu.")
1105    (if gds-view-menu
1106        nil
1107      (setq gds-view-menu (make-sparse-keymap "View"))
1108      (define-key gds-view-menu [messages]
1109        '(menu-item "Messages" gds-view-messages
1110                    :enable (memq 'messages gds-views)))
1111      (define-key gds-view-menu [browser]
1112        '(menu-item "Browser" gds-view-browser
1113                    :enable (memq 'browser gds-views)))
1114      (define-key gds-view-menu [breakpoints]
1115        '(menu-item "Breakpoints" gds-view-breakpoints
1116                    :enable (memq 'breakpoints gds-views)))
1117      (define-key gds-view-menu [stack]
1118        '(menu-item "Stack" gds-view-stack
1119                    :enable (memq 'stack gds-views)))
1120      (define-key gds-view-menu [interaction]
1121        '(menu-item "Interaction" gds-view-interaction
1122                    :enable (memq 'interaction gds-views))))
1123    
1124  (defvar gds-debug-menu nil  (defvar gds-debug-menu nil
1125    "GDS debugging menu.")    "GDS debugging menu.")
# Line 1106  Used for determining the default for the Line 1189  Used for determining the default for the
1189      (cons "Advanced" gds-advanced-menu))      (cons "Advanced" gds-advanced-menu))
1190    (define-key gds-menu [separator-1]    (define-key gds-menu [separator-1]
1191      '("--"))      '("--"))
1192      (define-key gds-menu [view]
1193        `(menu-item "View" ,gds-view-menu :enable gds-views))
1194    (define-key gds-menu [debug]    (define-key gds-menu [debug]
1195      `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client      `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client
1196                                                       (gds-client-blocked))))                                                       (gds-client-blocked))))

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26