/[cmucl]/src/hemlock/debug.lisp
ViewVC logotype

Diff of /src/hemlock/debug.lisp

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

revision 1.3 by chiles, Thu Jun 13 15:05:31 1991 UTC revision 1.4 by chiles, Sat Oct 12 20:57:29 1991 UTC
# Line 101  Line 101 
101    :error)    :error)
102    
103  (define-debugger-command "Backtrace"  (define-debugger-command "Backtrace"
104    "Executes the previous abort restart."    "Executes the debugger's BACKTRACE command."
105    :backtrace)    :backtrace)
106    
107  (define-debugger-command "Print"  (define-debugger-command "Print"
# Line 146  Line 146 
146  (defvar *debug-editor-source-data* nil)  (defvar *debug-editor-source-data* nil)
147    
148  (defcommand "Debug Edit Source" (p)  (defcommand "Debug Edit Source" (p)
149    "Give the \"Current Eval Server\"'s current debugger frame, place the user    "Given the \"Current Eval Server\"'s current debugger frame, place the user
150     at the location's source in the editor."     at the location's source in the editor."
151    "Give the \"Current Eval Server\"'s current debugger frame, place the user    "Given the \"Current Eval Server\"'s current debugger frame, place the user
152     at the location's source in the editor."     at the location's source in the editor."
153    (declare (ignore p))    (declare (ignore p))
154    (let* ((server-info (get-current-eval-server t))    (let* ((server-info (get-current-eval-server t))
# Line 215  Line 215 
215                                     (s (region point (buffer-end-mark buffer)))                                     (s (region point (buffer-end-mark buffer)))
216                                   (read s))                                   (read s))
217                                 tlf-offset)                                 tlf-offset)
218                                form-number)))))                                form-number))))))
               (quote-or-function nil))  
219            ;;            ;;
220            ;; Walk down to the form.            ;; Walk down to the form.  Change to buffer in case we get an error
221              ;; while finding the form.
222            (change-to-buffer buffer)            (change-to-buffer buffer)
223            (pre-command-parse-check point)            (mark-to-debug-source-path point path)))))
           (dolist (n path)  
             (when quote-or-function  
               (editor-error  
                "Apparently settled on the symbol QUOTE or FUNCTION via their ~  
                 read macros, which is odd, but furthermore there seems to be ~  
                 more source-path left."))  
             (unless (form-offset point 1)  
               ;; Want to use the following and delete the next FORM-OFFSET -1.  
               ;; (scan-direction-valid point t (or :open-paren :prefix))  
               (editor-error  
                "Ran out of text in buffer with more source-path remaining."))  
             (form-offset point -1)  
             (ecase (next-character point)  
               (#\(  
                (mark-after point)  
                (form-offset point n))  
               (#\'  
                (case n  
                  (0 (setf quote-or-function t))  
                  (1 (mark-after point))  
                  (t (editor-error "Next form is QUOTE, but source-path index ~  
                                    is other than zero or one."))))  
               (#\#  
                (case (next-character (mark-after point))  
                  (#\'  
                   (case n  
                     (0 (setf quote-or-function t))  
                     (1 (mark-after point))  
                     (t (editor-error "Next form is FUNCTION, but source-path ~  
                                       index is other than zero or one."))))  
                  (t (editor-error  
                      "Can only parse ' and #' read macros."))))))  
           ;; Get to the beginning of the form.  
           (form-offset point 1)  
           (form-offset point -1)))))  
224    (setf *debug-editor-source-data* t)    (setf *debug-editor-source-data* t)
225    ;;    ;;
226    ;; While Hemlock was setting up the source edit, the user could have typed    ;; While Hemlock was setting up the source edit, the user could have typed
# Line 270  Line 235 
235  (defun cannot-edit-source-location ()  (defun cannot-edit-source-location ()
236    (throw 'editor-top-level nil))    (throw 'editor-top-level nil))
237    
238  #|  
239    
240    ;;;; Breakpoints.
241    
242    ;;;
243    ;;; Breakpoint information for editor management.
244    ;;;
245    
246    ;;; This holds all the stuff we might want to know about a breakpoint in some
247    ;;; slave.
248    ;;;
249    (defstruct (breakpoint-info (:print-function print-breakpoint-info)
250                                (:constructor make-breakpoint-info
251                                              (slave buffer remote-object name)))
252      (slave nil :type server-info)
253      (buffer nil :type buffer)
254      (remote-object nil :type wire:remote-object)
255      (name nil :type simple-string))
256    ;;;
257    (defun print-breakpoint-info (obj str n)
258      (declare (ignore n))
259      (format str "#<Breakpoint-Info for ~S>" (breakpoint-info-name obj)))
260    
261    (defvar *breakpoints* nil)
262    
263    (macrolet ((frob (name accessor)
264                 `(defun ,name (key)
265                    (let ((res nil))
266                      (dolist (bpt-info *breakpoints* res)
267                        (when (eq (,accessor bpt-info) key)
268                          (push bpt-info res)))))))
269      (frob slave-breakpoints breakpoint-info-slave)
270      (frob buffer-breakpoints breakpoint-info-buffer))
271    
272    (defun delete-breakpoints-buffer-hook (buffer)
273      (let ((server-info (value current-eval-server)))
274        (when server-info
275          (let ((bpts (buffer-breakpoints buffer))
276                (wire (server-info-wire server-info)))
277            (dolist (b bpts)
278              (setf *breakpoints* (delete b *breakpoints*))
279              (wire:remote wire
280                (di:delete-breakpoint (breakpoint-info-remote-object b))))
281            (wire:wire-force-output wire)))))
282    ;;;
283    (add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook)
284    
285    ;;;
286    ;;; Setting breakpoints.
287    ;;;
288    
289    ;;; "Debug Breakpoint" uses this to prompt for :function-end and
290    ;;; :function-start breakpoints.
291    ;;;
292    (defvar *function-breakpoint-strings*
293      (make-string-table :initial-contents
294                         '(("Start" . :function-start) ("End" . :function-end))))
295    ;;;
296    ;;; Maybe this should use the wire level directly and hold onto remote-objects
297    ;;; identifying the breakpoints.  Then we could write commands to show where
298    ;;; the breakpoints were and to individually deactivate or delete them.  As it
299    ;;; is now we probably have to delete all for a given function.  What about
300    ;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a
301    ;;; nice set such as something to simply print all locals at a certain
302    ;;; location.
303    ;;;
304  (defcommand "Debug Breakpoint" (p)  (defcommand "Debug Breakpoint" (p)
305    "This tries to set a breakpoint in the \"Current Eval Server\" at the    "This tries to set a breakpoint in the \"Current Eval Server\" at the
306     location designated by the current point.  If there is no known code     location designated by the current point.  If there is no known code
307     location at the point, then this moves the point to the closest location     location at the point, then this moves the point to the closest location
308     before the point."     before the point.  With an argument, this sets a breakpoint at the start
309       or end of the function, prompting the user for which one to use."
310    "This tries to set a breakpoint in the \"Current Eval Server\" at the    "This tries to set a breakpoint in the \"Current Eval Server\" at the
311     location designated by the current point.  If there is no known code     location designated by the current point.  If there is no known code
312     location at the point, then this moves the point to the closest location     location at the point, then this moves the point to the closest location
313     before the point."     before the point.  With an argument, this sets a breakpoint at the start
314       or end of the function, prompting the user for which one to use."
315      (let ((point (current-point)))
316        (pre-command-parse-check point)
317        (let ((name (find-defun-for-breakpoint point)))
318          (if p
319              (multiple-value-bind (str place)
320                                   (prompt-for-keyword
321                                    (list *function-breakpoint-strings*)
322                                    :prompt "Set breakpoint at function: "
323                                    :default :start :default-string "Start")
324                (declare (ignore str))
325                (set-breakpoint-in-slave (get-current-eval-server t) name place))
326              (let* ((path (find-path-for-breakpoint point))
327                     (server-info (get-current-eval-server t))
328                     (res (set-breakpoint-in-slave server-info name path)))
329                (cond ((not res)
330                       (message "No code locations correspond with point."))
331                      ((wire:remote-object-p res)
332                       (push (make-breakpoint-info server-info (current-buffer)
333                                                   res name)
334                             *breakpoints*)
335                       (message "Breakpoint set."))
336                      (t
337                       (resolve-ambiguous-breakpoint-location server-info
338                                                              name res))))))))
339    
340    ;;; FIND-PATH-FOR-BREAKPOINT -- Internal.
341    ;;;
342    ;;; This walks up from point to the beginning of its containing DEFUN to return
343    ;;; the pseudo source-path (no form-number, no top-level form offset, and in
344    ;;; descent order from start of the DEFUN).
345    ;;;
346    (defun find-path-for-breakpoint (point)
347      (with-mark ((m point)
348                  (end point))
349        (let ((path nil))
350          (top-level-offset end -1)
351          (with-mark ((containing-form m))
352            (loop
353              (when (mark= m end) (return))
354              (backward-up-list containing-form)
355              (do ((count 0 (1+ count)))
356                  ((mark= m containing-form)
357                   ;; Count includes moving from the first form inside the
358                   ;; containing-form paren to the outside of the containing-form
359                   ;; paren -- one too many.
360                   (push (1- count) path))
361                (form-offset m -1))))
362          path)))
363    
364    ;;; SET-BREAKPOINT-IN-SLAVE -- Internal.
365    ;;;
366    ;;; This tells the slave to set a breakpoint for name.  Path is a modified
367    ;;; source-path (with no form-number or top-level-form offset) or a symbol
368    ;;; (:function-start or :function-end).  If the server dies while evaluating
369    ;;; form, then this signals an editor-error.
370    ;;;
371    (defun set-breakpoint-in-slave (server-info name path)
372      (when (server-info-notes server-info)
373        (editor-error "Server ~S is currently busy.  See \"List Operations\"."
374                      (server-info-name server-info)))
375      (multiple-value-bind (res error)
376                           (wire:remote-value (server-info-wire server-info)
377                             (di:set-breakpoint-for-editor (value current-package)
378                                                           name path))
379        (when error (editor-error "The server died before finishing."))
380        res))
381    
382    ;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal.
383    ;;;
384    ;;; This helps the user select an ambiguous code location for "Debug
385    ;;; Breakpoint".
386    ;;;
387    (defun resolve-ambiguous-breakpoint-location (server-info name locs)
388      (declare (list locs))
389      (let ((point (current-point))
390            (loc-num (length locs))
391            (count 1)
392            (cur-loc locs))
393        (flet ((show-loc ()
394                 (top-level-offset point -1)
395                 (mark-to-debug-source-path point (cdar cur-loc))))
396          (show-loc)
397          (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num)
398                          :help "Pick a location to set a breakpoint."
399                          :change-window nil)
400            (#\space "Move point to next possible location."
401              (setf cur-loc (cdr cur-loc))
402              (cond (cur-loc
403                     (incf count))
404                    (t
405                     (setf cur-loc locs)
406                     (setf count 1)))
407              (show-loc)
408              (reprompt))
409            (:confirm "Choose the current location."
410              (let ((res (wire:remote-value (server-info-wire server-info)
411                           (di:set-location-breakpoint-for-editor (caar cur-loc)))))
412                (unless (wire:remote-object-p res)
413                  (editor-error "Couldn't set breakpoint from location?"))
414                (push (make-breakpoint-info server-info (current-buffer) res name)
415                      *breakpoints*))
416              (message "Breakpoint set."))))))
417    
418    ;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal.
419    ;;;
420    ;;; This takes a mark at the beginning of a top-level form and modified debugger
421    ;;; source-path.  Path has no form number or top-level-form offset element, and
422    ;;; it has been reversed to actually be usable.
423    ;;;
424    (defun mark-to-debug-source-path (mark path)
425      (let ((quote-or-function nil))
426        (pre-command-parse-check mark)
427        (dolist (n path)
428          (when quote-or-function
429            (editor-error
430             "Apparently settled on the symbol QUOTE or FUNCTION via their ~
431              read macros, which is odd, but furthermore there seems to be ~
432              more source-path left."))
433          (unless (form-offset mark 1)
434            ;; Want to use the following and delete the next FORM-OFFSET -1.
435            ;; (scan-direction-valid mark t (or :open-paren :prefix))
436            (editor-error
437             "Ran out of text in buffer with more source-path remaining."))
438          (form-offset mark -1)
439          (ecase (next-character mark)
440            (#\(
441             (mark-after mark)
442             (form-offset mark n))
443            (#\'
444             (case n
445               (0 (setf quote-or-function t))
446               (1 (mark-after mark))
447               (t (editor-error "Next form is QUOTE, but source-path index ~
448                                 is other than zero or one."))))
449            (#\#
450             (case (next-character (mark-after mark))
451               (#\'
452                (case n
453                  (0 (setf quote-or-function t))
454                  (1 (mark-after mark))
455                  (t (editor-error "Next form is FUNCTION, but source-path ~
456                                    index is other than zero or one."))))
457               (t (editor-error
458                   "Can only parse ' and #' read macros."))))))
459        ;; Get to the beginning of the form.
460        (form-offset mark 1)
461        (form-offset mark -1)))
462    
463    ;;;
464    ;;; Deleting breakpoints.
465    ;;;
466    
467    (defhvar "Delete Breakpoints Confirm"
468      "This determines whether \"Debug Delete Breakpoints\" should ask for
469       confirmation before deleting breakpoints."
470      :value t)
471    
472    (defcommand "Debug Delete Breakpoints" (p)
473      "This deletes all breakpoints for the named DEFUN containing the point.
474       This affects the \"Current Eval Server\"."
475      "This deletes all breakpoints for the named DEFUN containing the point.
476       This affects the \"Current Eval Server\"."
477    (declare (ignore p))    (declare (ignore p))
478    (with-mark ((m (current-point)))    (let* ((server-info (get-current-eval-server t))
479      (           (wire (server-info-wire server-info))
480  |#           (name (find-defun-for-breakpoint (current-point)))
481             (bpts (slave-breakpoints server-info)))
482        (cond ((not bpts)
483               (message "No breakpoints recorded for ~A." name))
484              ((or (not (value delete-breakpoints-confirm))
485                   (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name)
486                                      :default t
487                                      :default-string "Y"))
488               (dolist (b bpts)
489                 (when (string= name (breakpoint-info-name b))
490                   (setf *breakpoints* (delete b *breakpoints*))
491                   (wire:remote wire
492                     (di:delete-breakpoint-for-editor
493                      (breakpoint-info-remote-object b)))))
494               (wire:wire-force-output wire)))))
495    
496    ;;;
497    ;;; Breakpoint utilities.
498    ;;;
499    
500    ;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal.
501    ;;;
502    ;;; This returns as a string the name of the DEFUN containing point.  It
503    ;;; signals any errors necessary to ensure "we are in good form".
504    ;;;
505    (defun find-defun-for-breakpoint (point)
506      (with-mark ((m1 point)
507                  (m2 point))
508        (unless (top-level-offset m2 -1)
509          (editor-error "Must be inside a DEFUN."))
510        ;;
511        ;; Check for DEFUN.
512        (mark-after (move-mark m1 m2))
513        (unless (find-attribute m1 :whitespace #'zerop)
514          (editor-error "Must be inside a DEFUN."))
515        (word-offset (move-mark m2 m1) 1)
516        (unless (string-equal (region-to-string (region m1 m2)) "defun")
517          (editor-error "Must be inside a DEFUN."))
518        ;;
519        ;; Find name.
520        (unless (find-attribute m2 :whitespace #'zerop)
521          (editor-error "Function unnamed?"))
522        (form-offset (move-mark m1 m2) 1)
523        (region-to-string (region m2 m1))))
524    
525    
526    
527  ;;;; Miscellaneous commands.  ;;;; Miscellaneous commands.
528    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5