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

Last change on this file since 8428 was 8428, checked in by gz, 12 years ago

Merge of the 'event-ide' branch. Hemlock's thread model has been changed
so that Hemlock commands now run in the Cocoa event thread -- see the
Hemlock file view.lisp for an overview.

IDE compilation has also been reorganized. Hemlock is now more fully
integrated into the IDE and cannot be compiled separately, sorry.

The hemlock-ext package has been repurposed to contain all interfaces
to window-system specific functionality.

There are also many many assorted other changes, cleanups and fixes.

The Hemlock documentation (Hemlock Command Implementor's Manual) in
http://trac.clozure.com/openmcl/wiki now correctly reflects the
implementation, although it doesn't (yet) describe the integration
with Cocoa or the threading model.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.5 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
2;;;
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.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Killing and unkilling things.
13;;;
14;;; Written by Bill Chiles and Rob MacLachlan.
15;;;
16
17(in-package :hemlock)
18
19(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.")
20
21
22
23;;;; Active Regions.
24
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)
29
30(defhvar "Highlight Active Region"
31  "When set, the active region will be highlighted on the display if possible."
32  :value t)
33
34
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.")
38
39(declaim (inline activate-region deactivate-region region-active-p))
40
41(defun %buffer-activate-region (buffer)
42  (setf (hi::buffer-region-active buffer) (buffer-signature buffer)))
43
44(defun activate-region ()
45  "Make the current region active."
46  (%buffer-activate-region (current-buffer)))
47
48(defun %buffer-deactivate-region (buffer)
49  (setf (hi::buffer-region-active buffer) nil))
50
51(defun deactivate-region ()
52  "Make the current region not active, in the current buffer."
53  (%buffer-deactivate-region (current-buffer)))
54
55(defun %buffer-region-active-p (b)
56  (eql (buffer-signature b)
57       (hi::buffer-region-active b)))
58
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)))
62
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.")))
68
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))))
79
80
81
82
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))
88
89
90
91(defun control-g-deactivate-region ()
92  (deactivate-region))
93;;;
94(add-hook abort-hook 'control-g-deactivate-region)
95
96
97
98;;;; Buffer-Mark primitives and commands.
99
100;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the
101;;; stack for each buffer.
102
103(defun current-mark ()
104  "Returns the top of the current buffer's mark stack."
105  (buffer-mark (current-buffer)))
106
107(defun buffer-mark (buffer)
108  "Returns the top of buffer's mark stack."
109  (hi::buffer-%mark buffer))
110
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))
125
126
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)
137       
138
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))
144
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))
148
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))))
164
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)))
172
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)))
178
179(defcommand "Exchange Point and Mark" (p)
180  "Swap the positions of the point and the mark, activating region"
181  "Swap the positions of the point and the mark."
182  (declare (ignore p))
183  (let ((point (current-point))
184        (mark (current-mark)))
185    (with-mark ((temp point))
186      (move-mark point mark)
187      (move-mark mark temp)))
188  (activate-region))
189
190(defcommand "Mark Whole Buffer"  (p)
191  "Set the region around the whole buffer, activating the region.
192   Pushes the point on the mark ring first, so two pops get it back.
193   With prefix argument, put mark at beginning and point at end."
194  "Put point at beginning and part at end of current buffer.
195  If P, do it the other way around."
196  (let* ((region (buffer-region (current-buffer)))
197         (start (region-start region))
198         (end (region-end region))
199         (point (current-point)))
200    (push-new-buffer-mark point)
201    (cond (p (push-new-buffer-mark start t)
202             (move-mark point end))
203          (t (push-new-buffer-mark end t)
204             (move-mark point start)))))
205
206
207
208;;;; KILL-REGION and KILL-CHARACTERS primitives.
209
210(declaim (special *delete-char-region*))
211
212;;; KILL-REGION first checks for any characters that may need to be added to
213;;; the region.  If there are some, we possibly push a region onto *kill-ring*,
214;;; and we use the top of *kill-ring*.  If there are no characters to deal
215;;; with, then we make sure the ring isn't empty; if it is, just push our
216;;; region.  If there is some region in *kill-ring*, then see if the last
217;;; command type was a region kill.  Otherwise, just push the region.
218;;;
219(defun kill-region (region current-type)
220  "Kills the region saving it in *kill-ring*.  Current-type is either
221   :kill-forward or :kill-backward.  When LAST-COMMAND-TYPE is one of these,
222   region is appended or prepended, respectively, to the top of *kill-ring*.
223   The killing of the region is undo-able with \"Undo\".  LAST-COMMAND-TYPE
224   is set to current-type.  This interacts with KILL-CHARACTERS."
225  (let ((last-type (last-command-type))
226        (insert-mark (copy-mark (region-start region) :left-inserting)))
227    (cond ((or (eq last-type :char-kill-forward)
228               (eq last-type :char-kill-backward))
229           (when *delete-char-region*
230             (kill-ring-push *delete-char-region*)
231             (setf *delete-char-region* nil))
232           (setf region (kill-region-top-of-ring region current-type)))
233          ((zerop (ring-length *kill-ring*))
234           (setf region (delete-and-save-region region))
235           (kill-ring-push region))
236          ((or (eq last-type :kill-forward) (eq last-type :kill-backward))
237           (setf region (kill-region-top-of-ring region current-type)))
238          (t
239           (setf region (delete-and-save-region region))
240           (kill-ring-push region)))
241    (make-region-undo :insert "kill" (copy-region region) insert-mark)
242    (setf (last-command-type) current-type)))
243
244(defun kill-region-top-of-ring (region current-type)
245  (let ((r (ring-ref *kill-ring* 0)))
246    (ninsert-region (if (eq current-type :kill-forward)
247                        (region-end r)
248                        (region-start r))
249                    (delete-and-save-region region))
250    r))
251
252(defhvar "Character Deletion Threshold"
253  "When this many characters are deleted contiguously via KILL-CHARACTERS,
254   they are saved on the kill ring -- for example, \"Delete Next Character\",
255   \"Delete Previous Character\", or \"Delete Previous Character Expanding
256   Tabs\"."
257  :value 5)
258
259(defvar *delete-char-region* nil)
260(defvar *delete-char-count* 0)
261
262;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET.
263;;; If the last command type was a region kill, we just use the top region
264;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is
265;;; over the threshold.  We don't call KILL-REGION in this case to save making
266;;; undo's -- no good reason.  If we were just called, then increment our
267;;; global counter.  Otherwise, make an empty region to keep KILL-CHAR-REGION
268;;; happy and increment the global counter.
269;;;
270(defun kill-characters (mark count)
271  "Kills count characters after mark if positive, before mark if negative.
272   If called multiple times contiguously such that the sum of the count values
273   equals \"Character Deletion Threshold\", then the characters are saved on
274   *kill-ring*.  This relies on setting LAST-COMMAND-TYPE, and it interacts
275   with KILL-REGION.  If there are not count characters in the appropriate
276   direction, no characters are deleted, and nil is returned; otherwise, mark
277   is returned."
278  (if (zerop count)
279      mark
280      (with-mark ((temp mark :left-inserting))
281        (if (character-offset temp count)
282            (let ((current-type (if (plusp count)
283                                    :char-kill-forward
284                                    :char-kill-backward))
285                  (last-type (last-command-type))
286                  (del-region (if (mark< temp mark)
287                                  (region temp mark)
288                                  (region mark temp))))
289              (cond ((or (eq last-type :kill-forward)
290                         (eq last-type :kill-backward))
291                     (setf *delete-char-count*
292                           (value character-deletion-threshold))
293                     (setf *delete-char-region* nil))
294                    ((or (eq last-type :char-kill-backward)
295                         (eq last-type :char-kill-forward))
296                     (incf *delete-char-count* (abs count)))
297                    (t
298                     (setf *delete-char-region* (make-empty-region))
299                     (setf *delete-char-count* (abs count))))
300              (kill-char-region del-region current-type)
301              mark)
302            nil))))
303
304(defun kill-char-region (region current-type)
305  (let ((deleted-region (delete-and-save-region region)))
306    (cond ((< *delete-char-count* (value character-deletion-threshold))
307           (ninsert-region (if (eq current-type :char-kill-forward)
308                               (region-end *delete-char-region*)
309                               (region-start *delete-char-region*))
310                           deleted-region)
311           (setf (last-command-type) current-type))
312          (t
313           (when *delete-char-region*
314             (kill-ring-push *delete-char-region*)
315             (setf *delete-char-region* nil))
316           (let ((r (ring-ref *kill-ring* 0)))
317             (ninsert-region (if (eq current-type :char-kill-forward)
318                                 (region-end r)
319                                 (region-start r))
320                             deleted-region))
321           (setf (last-command-type)
322                 (if (eq current-type :char-kill-forward)
323                     :kill-forward
324                     :kill-backward))))))
325
326(defun kill-ring-push (region)
327  (hi::region-to-clipboard region)
328  (ring-push region *kill-ring*))
329
330
331 
332
333
334;;;; Commands.
335
336(defcommand "Kill Region" (p)
337  "Kill the region, pushing on the kill ring.
338   If the region is not active nor the last command a yank, signal an error."
339  "Kill the region, pushing on the kill ring."
340  (declare (ignore p))
341  (kill-region (current-region)
342                (if (mark< (current-mark) (current-point))
343                    :kill-backward
344                    :kill-forward)))
345
346(defcommand "Save Region" (p)
347  "Insert the region into the kill ring.
348   If the region is not active nor the last command a yank, signal an error."
349  "Insert the region into the kill ring."
350  (declare (ignore p))
351  (kill-ring-push (copy-region (current-region))))
352
353(defcommand "Kill Next Word" (p)
354  "Kill a word at the point.
355  With prefix argument delete that many words.  The text killed is
356  appended to the text currently at the top of the kill ring if it was
357  next to the text being killed."
358  "Kill p words at the point"
359  (let ((point (current-point-for-deletion)))
360    (when point
361      (let* ((num (or p 1)))
362        (with-mark ((mark point :temporary))
363          (if (word-offset mark num)
364            (if (minusp num)
365              (kill-region (region mark point) :kill-backward)
366              (kill-region (region point mark) :kill-forward))
367            (editor-error)))))))
368
369(defcommand "Kill Previous Word" (p)
370  "Kill a word before the point.
371  With prefix argument kill that many words before the point.  The text
372  being killed is appended to the text currently at the top of the kill
373  ring if it was next to the text being killed."
374  "Kill p words before the point"
375  (kill-next-word-command (- (or p 1))))
376
377
378(defcommand "Kill Line" (p)
379  "Kills the characters to the end of the current line.
380  If the line is empty then the line is deleted.  With prefix argument,
381  deletes that many lines past the point (or before if the prefix is negative)."
382  "Kills p lines after the point."
383  (let* ((point (current-point-for-deletion)))
384    (when point
385      (let* ((line (mark-line point)))
386        (with-mark ((mark point))
387          (cond 
388            (p
389             (when (and (/= (mark-charpos point) 0) (minusp p))
390               (incf p))
391             (unless (line-offset mark p 0)
392               (if (plusp p)
393                 (kill-region (region point (buffer-end mark)) :kill-forward)
394                 (kill-region (region (buffer-start mark) point) :kill-backward))
395               (editor-error))
396             (if (plusp p)
397               (kill-region (region point mark) :kill-forward)
398               (kill-region (region mark point) :kill-backward)))
399            (t
400             (cond ((not (blank-after-p mark))
401                    (line-end mark))
402                   ((line-next line)
403                    (line-start mark (line-next line)))
404                   ((not (end-line-p mark))
405                    (line-end mark))
406                   (t 
407                    (editor-error)))
408             (kill-region (region point mark) :kill-forward))))))))
409
410(defcommand "Backward Kill Line" (p)
411  "Kill from the point to the beginning of the line.
412  If at the beginning of the line, kill the newline and any trailing space
413  on the previous line.  With prefix argument, call \"Kill Line\" with
414  the argument negated."
415  "Kills p lines before the point."
416  (if p
417      (kill-line-command (- p))
418    (let* ((point (current-point-for-deletion)))
419      (when point
420        (with-mark ((m point))
421          (cond ((zerop (mark-charpos m))
422                 (mark-before m)
423                 (unless (reverse-find-attribute m :space #'zerop)
424                   (buffer-start m)))
425                (t
426                 (line-start m)))
427          (kill-region (region m (current-point)) :kill-backward))))))
428
429
430(defcommand "Delete Blank Lines" (p)
431  "On a blank line, deletes all surrounding blank lines, leaving just
432  one. On an isolated blank line, deletes that one. On a non-blank line,
433  deletes all blank following that one."
434  "Kill blank lines around the point"
435  (declare (ignore p))
436  (let ((point (current-point-for-deletion)))
437    (when point
438      (with-mark ((beg-mark point :left-inserting)
439                  (end-mark point :right-inserting))
440        ;; handle case when the current line is blank
441        (when (blank-line-p (mark-line point))
442          ;; back up to last non-whitespace character
443          (reverse-find-attribute beg-mark :whitespace #'zerop)
444          (when (previous-character beg-mark)
445            ;; that is, we didn't back up to the beginning of the buffer
446            (unless (same-line-p beg-mark end-mark)
447              (line-offset beg-mark 1 0)))
448          ;; if isolated, zap the line else zap the blank ones above
449          (cond ((same-line-p beg-mark end-mark)
450                 (line-offset end-mark 1 0))
451                (t
452                 (line-start end-mark)))
453          (delete-region (region beg-mark end-mark)))
454        ;; always delete all blank lines after the current line
455        (move-mark beg-mark point)
456        (when (line-offset beg-mark 1 0)
457          (move-mark end-mark beg-mark)
458          (find-attribute end-mark :whitespace #'zerop)
459          (when (next-character end-mark)
460            ;; that is, we didn't go all the way to the end of the buffer
461            (line-start end-mark))
462          (delete-region (region beg-mark end-mark)))))))
463
464
465(defcommand "Un-Kill" (p)
466  "Inserts the top item in the kill-ring at the point.
467  The mark is left mark before the insertion and the point after.  With prefix
468  argument inserts the prefix'th most recent item."
469  "Inserts the item with index p in the kill ring at the point, leaving
470  the mark before and the point after."
471  (let ((idx (1- (or p 1))))
472    (cond ((> (ring-length *kill-ring*) idx -1)
473           (let* ((region (ring-ref *kill-ring* idx))
474                  (point (current-point-for-insertion))
475                  (mark (push-new-buffer-mark point)))
476             (insert-region point region)
477             (make-region-undo :delete "Un-Kill"
478                               (region (copy-mark mark) (copy-mark point))))
479           (setf (last-command-type) :unkill))
480          (t (editor-error)))))
481;;;
482(push :unkill *ephemerally-active-command-types*)
483
484(defcommand "Rotate Kill Ring" (p)
485  "Replace un-killed text with previously killed text.
486  Kills the current region, rotates the kill ring, and inserts the new top
487  item.  With prefix argument rotates the kill ring that many times."
488  "This function will not behave in any reasonable fashion when
489  called as a lisp function."
490  (let ((point (current-point))
491        (mark (current-mark)))
492    (cond ((or (not (eq (last-command-type) :unkill))
493               (zerop (ring-length *kill-ring*)))
494           (editor-error))
495          (t (delete-region (region mark point))
496             (rotate-ring *kill-ring* (or p 1))
497             (insert-region point (ring-ref *kill-ring* 0))
498             (make-region-undo :delete "Un-Kill"
499                               (region (copy-mark mark) (copy-mark point)))
500             (setf (last-command-type) :unkill)))))
Note: See TracBrowser for help on using the repository browser.