(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)
(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))
(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!
HCoop / bpt / guile.git / blobdiff