mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Remove everything to do with GDS Breakpoints

Browse source 
(which I now regard as an unsuccesful experiment)

This commit makes all affected files the same in master as they are in branch_release-1-8.

* doc/ref/api-debug.texi (Breakpoints): Removed.

* doc/ref/scheme-using.texi (GDS Introduction, GDS Getting Started,
  Displaying the Scheme Stack): Remove mentions of breakpoints.
  (Setting Specific Breakpoints, Setting GDS-managed Breakpoints,
  Setting and Managing Breakpoints, Listing and Deleting Breakpoints,
  Moving and Losing Breakpoints): Removed.

* emacs/gds-scheme.el (gds-bufferless-breakpoints,
  gds-bpdef:behaviour, gds-bpdef:type, gds-bpdef:file-name,
  gds-bpdef:proc-name, gds-bpdef:lc, gds-breakpoint-number,
  gds-breakpoint-buffers, gds-breakpoint-programming,
  gds-breakpoint-cache, gds-breakpoint-face,
  gds-breakpoints-file-name, gds-delete-lost-breakpoints,
  gds-bpdefs-cache, gds-read-breakpoints-file, gds-adopt-breakpoints,
  gds-adopt-breakpoint, gds-make-breakpoint-overlay,
  gds-send-breakpoint-to-client, gds-default-breakpoint-type,
  gds-set-breakpoint, gds-defun-name-region,
  gds-breakpoint-overlays-at, gds-write-breakpoints-file,
  gds-fold-breakpoints, gds-delete-breakpoints, gds-delete-breakpoint,
  gds-breakpoint-at-point, gds-union, gds-user-selected-breakpoint,
  gds-describe-breakpoints, gds-describe-breakpoint,
  gds-after-save-update-breakpoints, gds-breakpoint-map): Removed.
  (gds-nondebug-protocol): Removed handling for `breakpoint' and
  `get-breakpoints'.

* emacs/gds.el (gds-scheme-first-load): Removed.

* ice-9/debugging/Makefile.am (ice9_debugging_sources): Removed
  breakpoints.scm and load-hooks.scm.

* ice-9/debugging/breakpoints.scm: Removed.

* ice-9/debugging/load-hooks.scm: Removed.

* ice-9/gds-client.scm (handle-nondebug-protocol): Remove everything
  to do with breakpoints.
  (breakpoints, set-gds-breakpoints): Removed.
  (run-utility): Call `connect-to-gds' instead of `set-gds-breakpoints'.
This commit is contained in:
Neil Jerram 2008-12-09 23:56:51 +00:00
parent e00634774a
commit 69986e21d3
8 changed files with 26 additions and 1371 deletions
Download patch file Download diff file Expand all files Collapse all files

521
emacs/gds-scheme.el
View file

@ -484,483 +484,6 @@ interesting happened, `nil' if not."
(display-completion-list gds-completion-results))
t)))))
;;;; Breakpoints.
(defvar gds-bufferless-breakpoints nil
"The list of breakpoints that are not yet associated with a
particular buffer. Each element looks like (BPDEF BPNUM) where BPDEF
is the breakpoint definition and BPNUM the breakpoint's unique
GDS-assigned number. A breakpoint definition BPDEF is a list of the
form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug
or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file
where the breakpoint is (or will be) set, and TYPE-ARGS is:
- the name of the procedure to break in, if TYPE is 'in
- the line number and column number to break at, if TYPE is 'at.
If persistent breakpoints are enabled (by configuring
gds-breakpoints-file-name), this list is initialized when GDS is
loaded by reading gds-breakpoints-file-name.")
(defsubst gds-bpdef:behaviour (bpdef)
(nth 0 bpdef))
(defsubst gds-bpdef:type (bpdef)
(nth 1 bpdef))
(defsubst gds-bpdef:file-name (bpdef)
(nth 2 bpdef))
(defsubst gds-bpdef:proc-name (bpdef)
(nth 3 bpdef))
(defsubst gds-bpdef:lc (bpdef)
(nth 3 bpdef))
(defvar gds-breakpoint-number 0
"The last assigned breakpoint number. GDS increments this whenever
it creates a new breakpoint.")
(defvar gds-breakpoint-buffers nil
"The list of buffers that contain GDS breakpoints. When Emacs
visits a Scheme file, GDS checks to see if any of the breakpoints in
the bufferless list can be assigned to that file's buffer. If they
can, they are removed from the bufferless list and become breakpoint
overlays in that buffer. To retain the ability to enumerate all
breakpoints, therefore, we keep a list of all such buffers.")
(defvar gds-breakpoint-programming nil
"Information about how each breakpoint is actually programmed in the
Guile clients that GDS is connected to. This is an alist of the form
\((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint
number, CLIENT is the number of a GDS client, and TRAPLIST is the list
of traps that that client has created for the breakpoint concerned (in
an arbitrary but Emacs-readable format).")
(defvar gds-breakpoint-cache nil
"Buffer-local cache of breakpoints in a particular buffer. When a
breakpoint is represented as an overlay is a Scheme mode buffer, we
need to be able to detect when the user has caused that overlay to
evaporate by deleting a region of code that included it. We do this
detection when the buffer is next saved, by comparing the current set
of overlays with this cache. The cache is a list in which each
element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already
described. The handling of such breakpoints (which we call \"lost\")
is controlled by the setting of gds-delete-lost-breakpoints.")
(make-variable-buffer-local 'gds-breakpoint-cache)
(defface gds-breakpoint-face
'((((background dark)) (:background "red"))
(t (:background "pink")))
"*Face used to highlight the location of a breakpoint."
:group 'gds)
(defcustom gds-breakpoints-file-name "~/.gds-breakpoints"
"Name of file used to store GDS breakpoints between sessions.
You can disable breakpoint persistence by setting this to nil."
:group 'gds
:type '(choice (const :tag "nil" nil) file))
(defcustom gds-delete-lost-breakpoints nil
"Whether to delete lost breakpoints.
A non-nil value means that the Guile clients where lost breakpoints
were programmed will be told immediately to delete their breakpoints.
\"Immediately\" means when the lost breakpoints are detected, which
means when the buffer that previously contained them is saved. Thus,
even if the affected code (which the GDS user has deleted from his/her
buffer in Emacs) is still in use in the Guile clients, the breakpoints
that were previously set in that code will no longer take effect.
Nil (which is the default) means that GDS leaves such breakpoints
active in their Guile clients. This allows those breakpoints to
continue taking effect until the affected code is no longer used by
the Guile clients."
:group 'gds
:type 'boolean)
(defvar gds-bpdefs-cache nil)
(defun gds-read-breakpoints-file ()
"Read the persistent breakpoints file, and use its contents to
initialize GDS's global breakpoint variables."
(let ((bpdefs (condition-case nil
(with-current-buffer
(find-file-noselect gds-breakpoints-file-name)
(goto-char (point-min))
(read (current-buffer)))
(error nil))))
;; Cache the overall value so we don't unnecessarily modify the
;; breakpoints buffer when `gds-write-breakpoints-file' is called.
(setq gds-bpdefs-cache bpdefs)
;; Move definitions into the bufferless breakpoint list, assigning
;; breakpoint numbers as we go.
(setq gds-bufferless-breakpoints
(mapcar (function (lambda (bpdef)
(setq gds-breakpoint-number
(1+ gds-breakpoint-number))
(list bpdef gds-breakpoint-number)))
bpdefs))
;; Check each existing Scheme buffer to see if it wants to take
;; ownership of any of these breakpoints.
(mapcar (function (lambda (buffer)
(with-current-buffer buffer
(if (eq (derived-mode-class major-mode) 'scheme-mode)
(gds-adopt-breakpoints)))))
(buffer-list))))
(defun gds-adopt-breakpoints ()
"Take ownership of any of the breakpoints in the bufferless list
that match the current buffer."
(mapcar (function gds-adopt-breakpoint)
(copy-sequence gds-bufferless-breakpoints)))
(defun gds-adopt-breakpoint (bpdefnum)
"Take ownership of the specified breakpoint if it matches the
current buffer."
(let ((bpdef (car bpdefnum))
(bpnum (cadr bpdefnum)))
;; Check if breakpoint's file name matches. If it does, try to
;; convert the breakpoint definition to a breakpoint overlay in
;; the current buffer.
(if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name)
(gds-make-breakpoint-overlay bpdef bpnum))
;; That all succeeded, so this breakpoint is no longer
;; bufferless.
(setq gds-bufferless-breakpoints
(delq bpdefnum gds-bufferless-breakpoints)))))
(defun gds-make-breakpoint-overlay (bpdef &optional bpnum)
;; If no explicit number given, assign the next available breakpoint
;; number.
(or bpnum
(setq gds-breakpoint-number (+ gds-breakpoint-number 1)
bpnum gds-breakpoint-number))
;; First decide where the overlay should be, and create it there.
(let ((o (cond ((eq (gds-bpdef:type bpdef) 'at)
(save-excursion
(goto-line (+ (car (gds-bpdef:lc bpdef)) 1))
(move-to-column (cdr (gds-bpdef:lc bpdef)))
(make-overlay (point) (1+ (point)))))
((eq (gds-bpdef:type bpdef) 'in)
(save-excursion
(goto-char (point-min))
(and (re-search-forward (concat "^(define +(?\\("
(regexp-quote
(gds-bpdef:proc-name
bpdef))
"\\>\\)")
nil t)
(make-overlay (match-beginning 1) (match-end 1)))))
(t
(error "Bad breakpoint type")))))
;; If that succeeded, initialize the overlay's properties.
(if o
(progn
(overlay-put o 'evaporate t)
(overlay-put o 'face 'gds-breakpoint-face)
(overlay-put o 'gds-breakpoint-number bpnum)
(overlay-put o 'gds-breakpoint-definition bpdef)
(overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef))
(overlay-put o 'priority 1000)
;; Make sure that the current buffer is included in
;; `gds-breakpoint-buffers'.
(or (memq (current-buffer) gds-breakpoint-buffers)
(setq gds-breakpoint-buffers
(cons (current-buffer) gds-breakpoint-buffers)))
;; Add the new breakpoint to this buffer's cache.
(setq gds-breakpoint-cache
(cons (list bpdef bpnum) gds-breakpoint-cache))
;; If this buffer is associated with a client, tell the
;; client about the new breakpoint.
(if gds-client (gds-send-breakpoint-to-client bpnum bpdef))))
;; Return the overlay, or nil if we weren't able to convert the
;; breakpoint definition.
o))
(defun gds-send-breakpoint-to-client (bpnum bpdef)
"Send specified breakpoint to this buffer's Guile client."
(gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client))
(add-hook 'scheme-mode-hook (function gds-adopt-breakpoints))
(defcustom gds-default-breakpoint-type 'debug
"The type of breakpoint set by `C-x SPC'."
:group 'gds
:type '(choice (const :tag "debug" debug) (const :tag "trace" trace)))
(defun gds-set-breakpoint ()
"Create a new GDS breakpoint at point."
(interactive)
;; Set up beg and end according to whether the mark is active.
(if mark-active
;; Set new breakpoints on all opening parentheses in the region.
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
(goto-char beg)
(beginning-of-defun)
(let ((defun-start (point)))
(goto-char beg)
(while (search-forward "(" end t)
(let ((state (parse-partial-sexp defun-start (point)))
(pos (- (point) 1)))
(or (nth 3 state)
(nth 4 state)
(gds-breakpoint-overlays-at pos)
(gds-make-breakpoint-overlay (list gds-default-breakpoint-type
'at
buffer-file-name
(gds-line-and-column
pos)))))))))
;; Set a new breakpoint on the defun at point.
(let ((region (gds-defun-name-region)))
;; Complain if there is no defun at point.
(or region
(error "Point is not in a procedure definition"))
;; Don't create another breakpoint if there is already one here.
(if (gds-breakpoint-overlays-at (car region))
(error "There is already a breakpoint here"))
;; Create and return the new breakpoint overlay.
(gds-make-breakpoint-overlay (list gds-default-breakpoint-type
'in
buffer-file-name
(buffer-substring-no-properties
(car region)
(cdr region))))))
;; Update the persistent breakpoints file.
(gds-write-breakpoints-file))
(defun gds-defun-name-region ()
"If point is in a defun, return the beginning and end positions of
the identifier being defined."
(save-excursion
(let ((p (point)))
(beginning-of-defun)
;; Check that we are looking at some kind of procedure
;; definition.
(and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)")
(let ((beg (match-beginning 1))
(end (match-end 1)))
(end-of-defun)
;; Check here that we have reached past the original point
;; position.
(and (>= (point) p)
(cons beg end)))))))
(defun gds-breakpoint-overlays-at (pos)
"Return a list of GDS breakpoint overlays at the specified position."
(let ((os (overlays-at pos))
(breakpoint-os nil))
;; Of the overlays at POS, select all those that have a
;; gds-breakpoint-definition property.
(while os
(if (overlay-get (car os) 'gds-breakpoint-definition)
(setq breakpoint-os (cons (car os) breakpoint-os)))
(setq os (cdr os)))
breakpoint-os))
(defun gds-write-breakpoints-file ()
"Write the persistent breakpoints file, if configured."
(if gds-breakpoints-file-name
(let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init)
(cons bpdef init)))
t)))
(or (equal bpdefs gds-bpdefs-cache)
(with-current-buffer (find-file-noselect gds-breakpoints-file-name)
(erase-buffer)
(pp (reverse bpdefs) (current-buffer))
(setq gds-bpdefs-cache bpdefs)
(let ((auto-fill-function normal-auto-fill-function))
(newline)))))))
(defun gds-fold-breakpoints (fn &optional foldp init)
;; Run through bufferless breakpoints first.
(let ((bbs gds-bufferless-breakpoints))
(while bbs
(let ((bpnum (cadr (car bbs)))
(bpdef (caar bbs)))
(if foldp
(setq init (funcall fn bpnum bpdef init))
(funcall fn bpnum bpdef)))
(setq bbs (cdr bbs))))
;; Now run through breakpoint buffers.
(let ((outbuf (current-buffer))
(bpbufs gds-breakpoint-buffers))
(while bpbufs
(let ((buf (car bpbufs)))
(if (buffer-live-p buf)
(with-current-buffer buf
(save-restriction
(widen)
(let ((os (overlays-in (point-min) (point-max))))
(while os
(let ((bpnum (overlay-get (car os)
'gds-breakpoint-number))
(bpdef (overlay-get (car os)
'gds-breakpoint-definition)))
(if bpdef
(with-current-buffer outbuf
(if foldp
(setq init (funcall fn bpnum bpdef init))
(funcall fn bpnum bpdef)))))
(setq os (cdr os))))))))
(setq bpbufs (cdr bpbufs))))
init)
(defun gds-delete-breakpoints ()
"Delete GDS breakpoints in the region or at point."
(interactive)
(if mark-active
;; Delete all breakpoints in the region.
(let ((os (overlays-in (region-beginning) (region-end))))
(while os
(if (overlay-get (car os) 'gds-breakpoint-definition)
(gds-delete-breakpoint (car os)))
(setq os (cdr os))))
;; Delete the breakpoint "at point".
(call-interactively (function gds-delete-breakpoint))))
(defun gds-delete-breakpoint (o)
(interactive (list (or (gds-breakpoint-at-point)
(error "There is no breakpoint here"))))
(let ((bpdef (overlay-get o 'gds-breakpoint-definition))
(bpnum (overlay-get o 'gds-breakpoint-number)))
;; If this buffer is associated with a client, tell the client
;; that the breakpoint has been deleted.
(if (and bpnum gds-client)
(gds-send (format "delete-breakpoint %d" bpnum) gds-client))
;; Remove this breakpoint from the cache also, so it isn't later
;; detected as having been "lost".
(setq gds-breakpoint-cache
(delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache)))
;; Remove the overlay from its buffer.
(delete-overlay o)
;; If that was the last breakpoint in this buffer, remove this
;; buffer from gds-breakpoint-buffers.
(or gds-breakpoint-cache
(setq gds-breakpoint-buffers
(delq (current-buffer) gds-breakpoint-buffers)))
;; Update the persistent breakpoints file.
(gds-write-breakpoints-file))
(defun gds-breakpoint-at-point ()
"Find and return the overlay for a breakpoint `at' the current
cursor position. This is intended for use in other functions'
interactive forms, so it intentionally uses the minibuffer in some
situations."
(let* ((region (gds-defun-name-region))
(os (gds-union (gds-breakpoint-overlays-at (point))
(and region
(gds-breakpoint-overlays-at (car region))))))
;; Switch depending whether we found 0, 1 or more overlays.
(cond ((null os)
;; None found: return nil.
nil)
((= (length os) 1)
;; One found: return it.
(car os))
(t
;; More than 1 found: ask the user to choose.
(gds-user-selected-breakpoint os)))))
(defun gds-union (first second &rest others)
(if others
(gds-union first (apply 'gds-union second others))
(progn
(while first
(or (memq (car first) second)
(setq second (cons (car first) second)))
(setq first (cdr first)))
second)))
(defun gds-user-selected-breakpoint (os)
"Ask the user to choose one of the given list of breakpoints, and
return the one that they chose."
(let ((table (mapcar
(lambda (o)
(cons (format "%S"
(overlay-get o 'gds-breakpoint-definition))
o))
os)))
(cdr (assoc (completing-read "Which breakpoint do you mean? "
table nil t)
table))))
(defun gds-describe-breakpoints ()
"Describe all breakpoints and their programming status."
(interactive)
(with-current-buffer (get-buffer-create "*GDS Breakpoints*")
(erase-buffer)
(gds-fold-breakpoints (function gds-describe-breakpoint))
(display-buffer (current-buffer))))
(defun gds-describe-breakpoint (bpnum bpdef)
(insert (format "Breakpoint %d: %S\n" bpnum bpdef))
(let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming))))
(mapcar (lambda (clientprog)
(let ((client (car clientprog))
(traplist (cdr clientprog)))
(mapcar (lambda (trap)
(insert (format " Client %d: %S\n" client trap)))
traplist)))
bpproglist)))
(defun gds-after-save-update-breakpoints ()
"Function called when a buffer containing breakpoints is saved."
(if (eq (derived-mode-class major-mode) 'scheme-mode)
(save-restriction
(widen)
;; Get the current breakpoint overlays.
(let ((os (overlays-in (point-min) (point-max)))
(cache (copy-sequence gds-breakpoint-cache)))
;; Identify any overlays that have disappeared by comparing
;; against this buffer's definition cache, and
;; simultaneously rebuild the cache to reflect the current
;; set of overlays.
(setq gds-breakpoint-cache nil)
(while os
(let* ((o (car os))
(bpdef (overlay-get o 'gds-breakpoint-definition))
(bpnum (overlay-get o 'gds-breakpoint-number)))
(if bpdef
;; o and bpdef describe a current breakpoint.
(progn
;; Remove this breakpoint from the old cache list,
;; so we don't think it got lost.
(setq cache (delq (assq bpdef cache) cache))
;; Check whether this breakpoint's location has
;; moved. If it has, update the breakpoint
;; definition and the associated client.
(let ((lcnow (gds-line-and-column (overlay-start o))))
(if (equal lcnow (gds-bpdef:lc bpdef))
nil ; Breakpoint hasn't moved.
(gds-bpdef:setlc bpdef lcnow)
(if gds-client
(gds-send-breakpoint-to-client bpnum bpdef))))
;; Add this breakpoint to the new cache list.
(setq gds-breakpoint-cache
(cons (list bpdef bpnum) gds-breakpoint-cache)))))
(setq os (cdr os)))
;; cache now holds the set of lost breakpoints. If we are
;; supposed to explicitly delete these from the associated
;; client, do that now.
(if (and gds-delete-lost-breakpoints gds-client)
(while cache
(gds-send (format "delete-breakpoint %d" (cadr (car cache)))
gds-client)
(setq cache (cdr cache)))))
;; If this buffer now has no breakpoints, remove it from
;; gds-breakpoint-buffers.
(or gds-breakpoint-cache
(setq gds-breakpoint-buffers
(delq (current-buffer) gds-breakpoint-buffers)))
;; Update the persistent breakpoints file.
(gds-write-breakpoints-file))))
(add-hook 'after-save-hook (function gds-after-save-update-breakpoints))
;;;; Dispatcher for non-debug protocol.
(defun gds-nondebug-protocol (client proc args)
@ -977,28 +500,6 @@ return the one that they chose."
(eq proc 'completion-result)
(setq gds-completion-results (or (car args) t)))
(;; (breakpoint NUM STATUS) - Breakpoint set.
(eq proc 'breakpoint)
(let* ((bpnum (car args))
(traplist (cdr args))
(bpentry (assq bpnum gds-breakpoint-programming)))
(message "Breakpoint %d: %s" bpnum traplist)
(if bpentry
(let ((cliententry (assq client (cdr bpentry))))
(if cliententry
(setcdr cliententry traplist)
(setcdr bpentry
(cons (cons client traplist) (cdr bpentry)))))
(setq gds-breakpoint-programming
(cons (list bpnum (cons client traplist))
gds-breakpoint-programming)))))
(;; (get-breakpoints) - Set all breakpoints.
(eq proc 'get-breakpoints)
(let ((gds-client client))
(gds-fold-breakpoints (function gds-send-breakpoint-to-client)))
(gds-send "continue" client))
(;; (note ...) - For debugging only.
(eq proc 'note))
@ -1025,28 +526,6 @@ return the one that they chose."
(define-key scheme-mode-map "\C-hG" 'gds-apropos)
(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
(define-key scheme-mode-map "\C-x " 'gds-set-breakpoint)
(define-prefix-command 'gds-breakpoint-map)
(define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map)
(define-key gds-breakpoint-map " " 'gds-set-breakpoint)
(define-key gds-breakpoint-map "d"
(function (lambda ()
(interactive)
(let ((gds-default-breakpoint-type 'debug))
(gds-set-breakpoint)))))
(define-key gds-breakpoint-map "t"
(function (lambda ()
(interactive)
(let ((gds-default-breakpoint-type 'trace))
(gds-set-breakpoint)))))
(define-key gds-breakpoint-map "T"
(function (lambda ()
(interactive)
(let ((gds-default-breakpoint-type 'trace-subtree))
(gds-set-breakpoint)))))
(define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints)
(define-key gds-breakpoint-map "?" 'gds-describe-breakpoints)
;;;; The end!

12
emacs/gds.el
View file

@ -622,18 +622,6 @@ you would add an element to this alist to transform
(not gds-debug-server))
(gds-run-debug-server))
;; Things to do only when this file is loaded for the first time.
;; (And not, for example, when code is reevaluated by eval-buffer.)
(defvar gds-scheme-first-load t)
(if gds-scheme-first-load
(progn
;; Read the persistent breakpoints file, if configured.
(if gds-breakpoints-file-name
(gds-read-breakpoints-file))
;; Note that first time load is complete.
(setq gds-scheme-first-load nil)))
;;;; The end!
(provide 'gds)