source: trunk/source/cocoa-ide/hemlock/src/killcoms.lisp @ 14812

Last change on this file since 14812 was 14812, checked in by svspire, 10 years ago

Invert sense of arg in "Exchange Point and Mark" to be more like Fred.
Add "I-Search Yank Selection" plus (commented-out) binding to control-y
to provide Fred-like capability to select a string then control-s control-y
control-s to search for other instances of that string.
Left binding commented out for people who depend on current binding of control-y.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.5 KB
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
7#+CMU (ext:file-comment
8  "$Header$")
10;;; **********************************************************************
12;;; Killing and unkilling things.
14;;; Written by Bill Chiles and Rob MacLachlan.
17(in-package :hemlock)
19(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.")
23;;;; Active Regions.
25(defhvar "Active Regions Enabled"
26  "When set, some commands that affect the current region only work when the
27   region is active."
28  :value t)
30(defhvar "Highlight Active Region"
31  "When set, the active region will be highlighted on the display if possible."
32  :value t)
35(defvar *ephemerally-active-command-types* (list :ephemerally-active)
36  "This is a list of command types that permit the current region to be active
37   for the immediately following command.")
39(declaim (inline activate-region deactivate-region region-active-p))
41(defun %buffer-activate-region (buffer)
42  (setf (hi::buffer-region-active buffer) (buffer-signature buffer)))
44(defun activate-region ()
45  "Make the current region active."
46  (%buffer-activate-region (current-buffer)))
48(defun %buffer-deactivate-region (buffer)
49  (setf (hi::buffer-region-active buffer) nil))
51(defun deactivate-region ()
52  "Make the current region not active, in the current buffer."
53  (%buffer-deactivate-region (current-buffer)))
55(defun %buffer-region-active-p (b)
56  (eql (buffer-signature b)
57       (hi::buffer-region-active b)))
59(defun region-active-p ()
60  "Returns t or nil, depending on whether the current region is active."
61  (%buffer-region-active-p (current-buffer)))
63(defun check-region-active ()
64  "Signals an error when active regions are enabled and the current region
65   is not active."
66  (when (and (value active-regions-enabled) (not (region-active-p)))
67    (editor-error "The current region is not active.")))
69(defun current-region (&optional (error-if-not-active t)
70                                 (deactivate-region t))
71  "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally
72   signalling an editor error if the current region is not active.  A new
73   region is cons'ed on each call.  This optionally deactivates the region."
74  (when error-if-not-active (check-region-active))
75  (when deactivate-region (deactivate-region))
76  (let ((point (current-point))
77        (mark (current-mark)))
78    (if (mark< mark point) (region mark point) (region point mark))))
83(defcommand "Activate Region" (p)
84  "Make the current region active.  ^G deactivates the region."
85  "Make the current region active."
86  (declare (ignore p))
87  (activate-region))
91(defun control-g-deactivate-region ()
92  (deactivate-region))
94(add-hook abort-hook 'control-g-deactivate-region)
98;;;; Buffer-Mark primitives and commands.
100;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the
101;;; stack for each buffer.
103(defun current-mark ()
104  "Returns the top of the current buffer's mark stack."
105  (buffer-mark (current-buffer)))
107(defun buffer-mark (buffer)
108  "Returns the top of buffer's mark stack."
109  (hi::buffer-%mark buffer))
111(defun pop-buffer-mark ()
112  "Pops the current buffer's mark stack, returning the mark.  If the stack
113   becomes empty, a mark is push on the stack pointing to the buffer's start.
114   This always makes the current region not active."
115  (let* ((ring (value buffer-mark-ring))
116         (buffer (current-buffer))
117         (mark (buffer-mark buffer)))
118    (deactivate-region)
119    (setf (hi::buffer-%mark buffer)
120          (if (zerop (ring-length ring))
121            (copy-mark
122             (buffer-start-mark (current-buffer)) :right-inserting)
123            (ring-pop ring)))
124    mark))
127(defun %buffer-push-buffer-mark (b mark activate-region)
128  (cond ((eq (mark-buffer mark) b)
129         (setf (mark-kind mark) :right-inserting)
130         (let* ((old-mark (hi::buffer-%mark b)))
131           (when old-mark
132             (ring-push old-mark (variable-value 'buffer-mark-ring :buffer b))))
133         (setf (hi::buffer-%mark b) mark))
134        (t (error "Mark not in the current buffer.")))
135  (when activate-region (%buffer-activate-region b))
136  mark)
139(defun push-buffer-mark (mark &optional (activate-region nil))
140  "Pushes mark into buffer's mark ring, ensuring that the mark is in the right
141   buffer and :right-inserting.  Optionally, the current region is made active.
142   This never deactivates the current region.  Mark is returned."
143  (%buffer-push-buffer-mark (current-buffer) mark activate-region))
145(defun push-new-buffer-mark (mark &optional (activate-region nil))
146  "Pushes a new mark at argument position"
147  (push-buffer-mark (copy-mark mark :right-inserting) activate-region))
149(defcommand "Set/Pop Mark" (p)
150  "Set or Pop the mark ring.
151   With no C-U's, pushes point as the mark, activating the current region.
152   With one C-U's, pops the mark into point, de-activating the current region.
153   With two C-U's, pops the mark and throws it away, de-activating the current
154   region."
155  "Set or Pop the mark ring."
156  (cond ((not p)
157         (push-new-buffer-mark (current-point) t)
158         (message "Mark pushed."))
159        ((= p (value universal-argument-default))
160         (pop-and-goto-mark-command nil))
161        ((= p (expt (value universal-argument-default) 2))
162         (delete-mark (pop-buffer-mark)))
163        (t (editor-error))))
165(defcommand "Pop and Goto Mark" (p)
166  "Pop mark into point, de-activating the current region."
167  "Pop mark into point."
168  (declare (ignore p))
169  (let ((mark (pop-buffer-mark)))
170    (move-mark (current-point) mark)
171    (delete-mark mark)))
173(defcommand "Pop Mark" (p)
174  "Pop mark and throw it away, de-activating the current region."
175  "Pop mark and throw it away."
176  (declare (ignore p))
177  (delete-mark (pop-buffer-mark)))
179(defcommand "Exchange Point and Mark" (p)
180  "Swap the positions of the point and the mark, deactivating region.
181   With a prefix argument, activates region"
182  (let ((point (current-point))
183        (mark (current-mark)))
184    (with-mark ((temp point))
185      (move-mark point mark)
186      (move-mark mark temp)))
187  (if p
188    (activate-region)
189    (deactivate-region)))
191(defcommand "Mark Whole Buffer"  (p)
192  "Set the region around the whole buffer, activating the region.
193   Pushes the point on the mark ring first, so two pops get it back.
194   With prefix argument, put mark at beginning and point at end."
195  "Put point at beginning and part at end of current buffer.
196  If P, do it the other way around."
197  (let* ((region (buffer-region (current-buffer)))
198         (start (region-start region))
199         (end (region-end region))
200         (point (current-point)))
201    (push-new-buffer-mark point)
202    (cond (p (push-new-buffer-mark start t)
203             (move-mark point end))
204          (t (push-new-buffer-mark end t)
205             (move-mark point start)))))
209;;;; KILL-REGION and KILL-CHARACTERS primitives.
211(declaim (special *delete-char-region*))
213;;; KILL-REGION first checks for any characters that may need to be added to
214;;; the region.  If there are some, we possibly push a region onto *kill-ring*,
215;;; and we use the top of *kill-ring*.  If there are no characters to deal
216;;; with, then we make sure the ring isn't empty; if it is, just push our
217;;; region.  If there is some region in *kill-ring*, then see if the last
218;;; command type was a region kill.  Otherwise, just push the region.
220(defun kill-region (region current-type)
221  "Kills the region saving it in *kill-ring*.  Current-type is either
222   :kill-forward or :kill-backward.  When LAST-COMMAND-TYPE is one of these,
223   region is appended or prepended, respectively, to the top of *kill-ring*.
224   The killing of the region is undo-able with \"Undo\".  LAST-COMMAND-TYPE
225   is set to current-type.  This interacts with KILL-CHARACTERS."
226  (let ((last-type (last-command-type))
227        (insert-mark (copy-mark (region-start region) :left-inserting)))
228    (cond ((or (eq last-type :char-kill-forward)
229               (eq last-type :char-kill-backward))
230           (when *delete-char-region*
231             (kill-ring-push *delete-char-region*)
232             (setf *delete-char-region* nil))
233           (setf region (kill-region-top-of-ring region current-type)))
234          ((zerop (ring-length *kill-ring*))
235           (setf region (delete-and-save-region region))
236           (kill-ring-push region))
237          ((or (eq last-type :kill-forward) (eq last-type :kill-backward))
238           (setf region (kill-region-top-of-ring region current-type)))
239          (t
240           (setf region (delete-and-save-region region))
241           (kill-ring-push region)))
242    (make-region-undo :insert "kill" (copy-region region) insert-mark)
243    (setf (last-command-type) current-type)))
245(defun kill-region-top-of-ring (region current-type)
246  (let ((r (ring-ref *kill-ring* 0)))
247    (ninsert-region (if (eq current-type :kill-forward)
248                        (region-end r)
249                        (region-start r))
250                    (delete-and-save-region region))
251    r))
253(defhvar "Character Deletion Threshold"
254  "When this many characters are deleted contiguously via KILL-CHARACTERS,
255   they are saved on the kill ring -- for example, \"Delete Next Character\",
256   \"Delete Previous Character\", or \"Delete Previous Character Expanding
257   Tabs\"."
258  :value 5)
260(defvar *delete-char-region* nil)
261(defvar *delete-char-count* 0)
263;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET.
264;;; If the last command type was a region kill, we just use the top region
265;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is
266;;; over the threshold.  We don't call KILL-REGION in this case to save making
267;;; undo's -- no good reason.  If we were just called, then increment our
268;;; global counter.  Otherwise, make an empty region to keep KILL-CHAR-REGION
269;;; happy and increment the global counter.
271(defun kill-characters (mark count)
272  "Kills count characters after mark if positive, before mark if negative.
273   If called multiple times contiguously such that the sum of the count values
274   equals \"Character Deletion Threshold\", then the characters are saved on
275   *kill-ring*.  This relies on setting LAST-COMMAND-TYPE, and it interacts
276   with KILL-REGION.  If there are not count characters in the appropriate
277   direction, no characters are deleted, and nil is returned; otherwise, mark
278   is returned."
279  (if (zerop count)
280      mark
281      (with-mark ((temp mark :left-inserting))
282        (if (character-offset temp count)
283            (let ((current-type (if (plusp count)
284                                    :char-kill-forward
285                                    :char-kill-backward))
286                  (last-type (last-command-type))
287                  (del-region (if (mark< temp mark)
288                                  (region temp mark)
289                                  (region mark temp))))
290              (cond ((or (eq last-type :kill-forward)
291                         (eq last-type :kill-backward))
292                     (setf *delete-char-count*
293                           (value character-deletion-threshold))
294                     (setf *delete-char-region* nil))
295                    ((or (eq last-type :char-kill-backward)
296                         (eq last-type :char-kill-forward))
297                     (incf *delete-char-count* (abs count)))
298                    (t
299                     (setf *delete-char-region* (make-empty-region))
300                     (setf *delete-char-count* (abs count))))
301              (kill-char-region del-region current-type)
302              mark)
303            nil))))
305(defun kill-char-region (region current-type)
306  (let ((deleted-region (delete-and-save-region region)))
307    (cond ((< *delete-char-count* (value character-deletion-threshold))
308           (ninsert-region (if (eq current-type :char-kill-forward)
309                               (region-end *delete-char-region*)
310                               (region-start *delete-char-region*))
311                           deleted-region)
312           (setf (last-command-type) current-type))
313          (t
314           (when *delete-char-region*
315             (kill-ring-push *delete-char-region*)
316             (setf *delete-char-region* nil))
317           (let ((r (ring-ref *kill-ring* 0)))
318             (ninsert-region (if (eq current-type :char-kill-forward)
319                                 (region-end r)
320                                 (region-start r))
321                             deleted-region))
322           (setf (last-command-type)
323                 (if (eq current-type :char-kill-forward)
324                     :kill-forward
325                     :kill-backward))))))
327(defun kill-ring-push (region)
328  (hi::region-to-clipboard region)
329  (ring-push region *kill-ring*))
335;;;; Commands.
337(defcommand "Kill Region" (p)
338  "Kill the region, pushing on the kill ring.
339   If the region is not active nor the last command a yank, signal an error."
340  "Kill the region, pushing on the kill ring."
341  (declare (ignore p))
342  (kill-region (current-region)
343                (if (mark< (current-mark) (current-point))
344                    :kill-backward
345                    :kill-forward)))
347(defcommand "Save Region" (p)
348  "Insert the region into the kill ring.
349   If the region is not active nor the last command a yank, signal an error."
350  "Insert the region into the kill ring."
351  (declare (ignore p))
352  (kill-ring-push (copy-region (current-region))))
354(defcommand "Kill Next Word" (p)
355  "Kill a word at the point.
356  With prefix argument delete that many words.  The text killed is
357  appended to the text currently at the top of the kill ring if it was
358  next to the text being killed."
359  "Kill p words at the point"
360  (let ((point (current-point-for-deletion)))
361    (when point
362      (let* ((num (or p 1)))
363        (with-mark ((mark point :temporary))
364          (if (word-offset mark num)
365            (if (minusp num)
366              (kill-region (region mark point) :kill-backward)
367              (kill-region (region point mark) :kill-forward))
368            (editor-error)))))))
370(defcommand "Kill Previous Word" (p)
371  "Kill a word before the point.
372  With prefix argument kill that many words before the point.  The text
373  being killed is appended to the text currently at the top of the kill
374  ring if it was next to the text being killed."
375  "Kill p words before the point"
376  (kill-next-word-command (- (or p 1))))
379(defcommand "Kill Line" (p)
380  "Kills the characters to the end of the current line.
381  If the line is empty then the line is deleted.  With prefix argument,
382  deletes that many lines past the point (or before if the prefix is negative)."
383  "Kills p lines after the point."
384  (let* ((point (current-point-for-deletion)))
385    (when point
386      (let* ((line (mark-line point)))
387        (with-mark ((mark point))
388          (cond 
389            (p
390             (when (and (/= (mark-charpos point) 0) (minusp p))
391               (incf p))
392             (unless (line-offset mark p 0)
393               (if (plusp p)
394                 (kill-region (region point (buffer-end mark)) :kill-forward)
395                 (kill-region (region (buffer-start mark) point) :kill-backward))
396               (editor-error))
397             (if (plusp p)
398               (kill-region (region point mark) :kill-forward)
399               (kill-region (region mark point) :kill-backward)))
400            (t
401             (cond ((not (blank-after-p mark))
402                    (line-end mark))
403                   ((line-next line)
404                    (line-start mark (line-next line)))
405                   ((not (end-line-p mark))
406                    (line-end mark))
407                   (t 
408                    (editor-error)))
409             (kill-region (region point mark) :kill-forward))))))))
411(defcommand "Backward Kill Line" (p)
412  "Kill from the point to the beginning of the line.
413  If at the beginning of the line, kill the newline and any trailing space
414  on the previous line.  With prefix argument, call \"Kill Line\" with
415  the argument negated."
416  "Kills p lines before the point."
417  (if p
418      (kill-line-command (- p))
419    (let* ((point (current-point-for-deletion)))
420      (when point
421        (with-mark ((m point))
422          (cond ((zerop (mark-charpos m))
423                 (mark-before m)
424                 (unless (reverse-find-attribute m :space #'zerop)
425                   (buffer-start m)))
426                (t
427                 (line-start m)))
428          (kill-region (region m (current-point)) :kill-backward))))))
431(defcommand "Delete Blank Lines" (p)
432  "On a blank line, deletes all surrounding blank lines, leaving just
433  one. On an isolated blank line, deletes that one. On a non-blank line,
434  deletes all blank following that one."
435  "Kill blank lines around the point"
436  (declare (ignore p))
437  (let ((point (current-point-for-deletion)))
438    (when point
439      (with-mark ((beg-mark point :left-inserting)
440                  (end-mark point :right-inserting))
441        ;; handle case when the current line is blank
442        (when (blank-line-p (mark-line point))
443          ;; back up to last non-whitespace character
444          (reverse-find-attribute beg-mark :whitespace #'zerop)
445          (when (previous-character beg-mark)
446            ;; that is, we didn't back up to the beginning of the buffer
447            (unless (same-line-p beg-mark end-mark)
448              (line-offset beg-mark 1 0)))
449          ;; if isolated, zap the line else zap the blank ones above
450          (cond ((same-line-p beg-mark end-mark)
451                 (line-offset end-mark 1 0))
452                (t
453                 (line-start end-mark)))
454          (delete-region (region beg-mark end-mark)))
455        ;; always delete all blank lines after the current line
456        (move-mark beg-mark point)
457        (when (line-offset beg-mark 1 0)
458          (move-mark end-mark beg-mark)
459          (find-attribute end-mark :whitespace #'zerop)
460          (when (next-character end-mark)
461            ;; that is, we didn't go all the way to the end of the buffer
462            (line-start end-mark))
463          (delete-region (region beg-mark end-mark)))))))
466(defcommand "Un-Kill" (p)
467  "Inserts the top item in the kill-ring at the point.
468  The mark is left mark before the insertion and the point after.  With prefix
469  argument inserts the prefix'th most recent item."
470  "Inserts the item with index p in the kill ring at the point, leaving
471  the mark before and the point after."
472  (let ((idx (1- (or p 1))))
473    (cond ((> (ring-length *kill-ring*) idx -1)
474           (let* ((region (ring-ref *kill-ring* idx))
475                  (point (current-point-for-insertion))
476                  (mark (push-new-buffer-mark point)))
477             (insert-region point region)
478             (make-region-undo :delete "Un-Kill"
479                               (region (copy-mark mark) (copy-mark point))))
480           (setf (last-command-type) :unkill))
481          (t (editor-error)))))
483(push :unkill *ephemerally-active-command-types*)
485(defcommand "Rotate Kill Ring" (p)
486  "Replace un-killed text with previously killed text.
487  Kills the current region, rotates the kill ring, and inserts the new top
488  item.  With prefix argument rotates the kill ring that many times."
489  "This function will not behave in any reasonable fashion when
490  called as a lisp function."
491  (let ((point (current-point))
492        (mark (current-mark)))
493    (cond ((or (not (eq (last-command-type) :unkill))
494               (zerop (ring-length *kill-ring*)))
495           (editor-error))
496          (t (delete-region (region mark point))
497             (rotate-ring *kill-ring* (or p 1))
498             (insert-region point (ring-ref *kill-ring* 0))
499             (make-region-undo :delete "Un-Kill"
500                               (region (copy-mark mark) (copy-mark point)))
501             (setf (last-command-type) :unkill)))))
Note: See TracBrowser for help on using the repository browser.