source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/killcoms.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.6 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(defcommand "Activate Region" (p)
82  "Make the current region active.  ^G deactivates the region."
83  "Make the current region active."
84  (declare (ignore p))
85  (activate-region))
86
87
88
89(defun control-g-deactivate-region ()
90  (deactivate-region))
91;;;
92(add-hook abort-hook 'control-g-deactivate-region)
93
94
95
96;;;; Buffer-Mark primitives and commands.
97
98;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the
99;;; stack for each buffer.
100
101(defun current-mark ()
102  "Returns the top of the current buffer's mark stack."
103  (buffer-mark (current-buffer)))
104
105(defun buffer-mark (buffer)
106  "Returns the top of buffer's mark stack."
107  (hi::buffer-%mark buffer))
108
109(defun pop-buffer-mark ()
110  "Pops the current buffer's mark stack, returning the mark.  If the stack
111   becomes empty, a mark is push on the stack pointing to the buffer's start.
112   This always makes the current region not active."
113  (let* ((ring (value buffer-mark-ring))
114         (buffer (current-buffer))
115         (mark (buffer-mark buffer)))
116    (deactivate-region)
117    (setf (hi::buffer-%mark buffer)
118          (if (zerop (ring-length ring))
119            (copy-mark
120             (buffer-start-mark (current-buffer)) :right-inserting)
121            (ring-pop ring)))
122    mark))
123
124
125(defun %buffer-push-buffer-mark (b mark activate-region)
126  (cond ((eq (line-buffer (mark-line mark)) b)
127         (setf (mark-kind mark) :right-inserting)
128         (let* ((old-mark (hi::buffer-%mark b)))
129           (when old-mark
130             (ring-push old-mark (variable-value 'buffer-mark-ring :buffer b))))
131         (setf (hi::buffer-%mark b) mark))
132        (t (error "Mark not in the current buffer.")))
133  (when activate-region (%buffer-activate-region b))
134  mark)
135       
136
137(defun push-buffer-mark (mark &optional (activate-region nil))
138  "Pushes mark into buffer's mark ring, ensuring that the mark is in the right
139   buffer and :right-inserting.  Optionally, the current region is made active.
140   This never deactivates the current region.  Mark is returned."
141  (%buffer-push-buffer-mark (current-buffer) mark activate-region))
142
143
144(defcommand "Set/Pop Mark" (p)
145  "Set or Pop the mark ring.
146   With no C-U's, pushes point as the mark, activating the current region.
147   With one C-U's, pops the mark into point, de-activating the current region.
148   With two C-U's, pops the mark and throws it away, de-activating the current
149   region."
150  "Set or Pop the mark ring."
151  (cond ((not p)
152         (push-buffer-mark (copy-mark (current-point)) t)
153         (when (interactive)
154           (message "Mark pushed.")))
155        ((= p (value universal-argument-default))
156         (pop-and-goto-mark-command nil))
157        ((= p (expt (value universal-argument-default) 2))
158         (delete-mark (pop-buffer-mark)))
159        (t (editor-error))))
160
161(defcommand "Pop and Goto Mark" (p)
162  "Pop mark into point, de-activating the current region."
163  "Pop mark into point."
164  (declare (ignore p))
165  (let ((mark (pop-buffer-mark)))
166    (move-mark (current-point) mark)
167    (delete-mark mark)))
168
169(defcommand "Pop Mark" (p)
170  "Pop mark and throw it away, de-activating the current region."
171  "Pop mark and throw it away."
172  (declare (ignore p))
173  (delete-mark (pop-buffer-mark)))
174
175(defcommand "Exchange Point and Mark" (p)
176  "Swap the positions of the point and the mark."
177  "Swap the positions of the point and the mark."
178  (declare (ignore p))
179  (let ((point (current-point))
180        (mark (current-mark)))
181    (with-mark ((temp point))
182      (move-mark point mark)
183      (move-mark mark temp))))
184
185(defcommand "Mark Whole Buffer"  (p)
186  "Set the region around the whole buffer, activating the region.
187   Pushes the point on the mark ring first, so two pops get it back.
188   With prefix argument, put mark at beginning and point at end."
189  "Put point at beginning and part at end of current buffer.
190  If P, do it the other way around."
191  (let* ((region (buffer-region (current-buffer)))
192         (start (region-start region))
193         (end (region-end region))
194         (point (current-point)))
195    (push-buffer-mark (copy-mark point))
196    (cond (p (push-buffer-mark (copy-mark start) t)
197             (move-mark point end))
198          (t (push-buffer-mark (copy-mark end) t)
199             (move-mark point start)))))
200
201
202
203;;;; KILL-REGION and KILL-CHARACTERS primitives.
204
205(declaim (special *delete-char-region*))
206
207;;; KILL-REGION first checks for any characters that may need to be added to
208;;; the region.  If there are some, we possibly push a region onto *kill-ring*,
209;;; and we use the top of *kill-ring*.  If there are no characters to deal
210;;; with, then we make sure the ring isn't empty; if it is, just push our
211;;; region.  If there is some region in *kill-ring*, then see if the last
212;;; command type was a region kill.  Otherwise, just push the region.
213;;;
214(defun kill-region (region current-type)
215  "Kills the region saving it in *kill-ring*.  Current-type is either
216   :kill-forward or :kill-backward.  When LAST-COMMAND-TYPE is one of these,
217   region is appended or prepended, respectively, to the top of *kill-ring*.
218   The killing of the region is undo-able with \"Undo\".  LAST-COMMAND-TYPE
219   is set to current-type.  This interacts with KILL-CHARACTERS."
220  (let ((last-type (last-command-type))
221        (insert-mark (copy-mark (region-start region) :left-inserting)))
222    (cond ((or (eq last-type :char-kill-forward)
223               (eq last-type :char-kill-backward))
224           (when *delete-char-region*
225             (ring-push *delete-char-region* *kill-ring*)
226             (setf *delete-char-region* nil))
227           (setf region (kill-region-top-of-ring region current-type)))
228          ((zerop (ring-length *kill-ring*))
229           (setf region (delete-and-save-region region))
230           (ring-push region *kill-ring*))
231          ((or (eq last-type :kill-forward) (eq last-type :kill-backward))
232           (setf region (kill-region-top-of-ring region current-type)))
233          (t
234           (setf region (delete-and-save-region region))
235           (ring-push region *kill-ring*)))
236    (make-region-undo :insert "kill" (copy-region region) insert-mark)
237    (setf (last-command-type) current-type)))
238
239(defun kill-region-top-of-ring (region current-type)
240  (let ((r (ring-ref *kill-ring* 0)))
241    (ninsert-region (if (eq current-type :kill-forward)
242                        (region-end r)
243                        (region-start r))
244                    (delete-and-save-region region))
245    r))
246
247(defhvar "Character Deletion Threshold"
248  "When this many characters are deleted contiguously via KILL-CHARACTERS,
249   they are saved on the kill ring -- for example, \"Delete Next Character\",
250   \"Delete Previous Character\", or \"Delete Previous Character Expanding
251   Tabs\"."
252  :value 5)
253
254(defvar *delete-char-region* nil)
255(defvar *delete-char-count* 0)
256
257;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET.
258;;; If the last command type was a region kill, we just use the top region
259;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is
260;;; over the threshold.  We don't call KILL-REGION in this case to save making
261;;; undo's -- no good reason.  If we were just called, then increment our
262;;; global counter.  Otherwise, make an empty region to keep KILL-CHAR-REGION
263;;; happy and increment the global counter.
264;;;
265(defun kill-characters (mark count)
266  "Kills count characters after mark if positive, before mark if negative.
267   If called multiple times contiguously such that the sum of the count values
268   equals \"Character Deletion Threshold\", then the characters are saved on
269   *kill-ring*.  This relies on setting LAST-COMMAND-TYPE, and it interacts
270   with KILL-REGION.  If there are not count characters in the appropriate
271   direction, no characters are deleted, and nil is returned; otherwise, mark
272   is returned."
273  (if (zerop count)
274      mark
275      (with-mark ((temp mark :left-inserting))
276        (if (character-offset temp count)
277            (let ((current-type (if (plusp count)
278                                    :char-kill-forward
279                                    :char-kill-backward))
280                  (last-type (last-command-type))
281                  (del-region (if (mark< temp mark)
282                                  (region temp mark)
283                                  (region mark temp))))
284              (cond ((or (eq last-type :kill-forward)
285                         (eq last-type :kill-backward))
286                     (setf *delete-char-count*
287                           (value character-deletion-threshold))
288                     (setf *delete-char-region* nil))
289                    ((or (eq last-type :char-kill-backward)
290                         (eq last-type :char-kill-forward))
291                     (incf *delete-char-count* (abs count)))
292                    (t
293                     (setf *delete-char-region* (make-empty-region))
294                     (setf *delete-char-count* (abs count))))
295              (kill-char-region del-region current-type)
296              mark)
297            nil))))
298
299(defun kill-char-region (region current-type)
300  (let ((deleted-region (delete-and-save-region region)))
301    (cond ((< *delete-char-count* (value character-deletion-threshold))
302           (ninsert-region (if (eq current-type :char-kill-forward)
303                               (region-end *delete-char-region*)
304                               (region-start *delete-char-region*))
305                           deleted-region)
306           (setf (last-command-type) current-type))
307          (t
308           (when *delete-char-region*
309             (ring-push *delete-char-region* *kill-ring*)
310             (setf *delete-char-region* nil))
311           (let ((r (ring-ref *kill-ring* 0)))
312             (ninsert-region (if (eq current-type :char-kill-forward)
313                                 (region-end r)
314                                 (region-start r))
315                             deleted-region))
316           (setf (last-command-type)
317                 (if (eq current-type :char-kill-forward)
318                     :kill-forward
319                     :kill-backward))))))
320
321
322
323;;;; Commands.
324
325(defcommand "Kill Region" (p)
326  "Kill the region, pushing on the kill ring.
327   If the region is not active nor the last command a yank, signal an error."
328  "Kill the region, pushing on the kill ring."
329  (declare (ignore p))
330  (kill-region (current-region)
331                (if (mark< (current-mark) (current-point))
332                    :kill-backward
333                    :kill-forward)))
334
335(defcommand "Save Region" (p)
336  "Insert the region into the kill ring.
337   If the region is not active nor the last command a yank, signal an error."
338  "Insert the region into the kill ring."
339  (declare (ignore p))
340  (ring-push (copy-region (current-region)) *kill-ring*))
341
342(defcommand "Kill Next Word" (p)
343  "Kill a word at the point.
344  With prefix argument delete that many words.  The text killed is
345  appended to the text currently at the top of the kill ring if it was
346  next to the text being killed."
347  "Kill p words at the point"
348  (let ((point (current-point))
349        (num (or p 1)))
350    (with-mark ((mark point :temporary))
351      (if (word-offset mark num)
352          (if (minusp num)
353              (kill-region (region mark point) :kill-backward)
354              (kill-region (region point mark) :kill-forward))
355          (editor-error)))))
356
357(defcommand "Kill Previous Word" (p)
358  "Kill a word before the point.
359  With prefix argument kill that many words before the point.  The text
360  being killed is appended to the text currently at the top of the kill
361  ring if it was next to the text being killed."
362  "Kill p words before the point"
363  (kill-next-word-command (- (or p 1))))
364
365
366(defcommand "Kill Line" (p)
367  "Kills the characters to the end of the current line.
368  If the line is empty then the line is deleted.  With prefix argument,
369  deletes that many lines past the point (or before if the prefix is negative)."
370  "Kills p lines after the point."
371  (let* ((point (current-point))
372         (line (mark-line point)))
373    (with-mark ((mark point))
374      (cond 
375       (p
376        (when (and (/= (mark-charpos point) 0) (minusp p))
377          (incf p))
378        (unless (line-offset mark p 0)
379          (if (plusp p)
380              (kill-region (region point (buffer-end mark)) :kill-forward)
381              (kill-region (region (buffer-start mark) point) :kill-backward))
382          (editor-error))
383        (if (plusp p)
384            (kill-region (region point mark) :kill-forward)
385            (kill-region (region mark point) :kill-backward)))
386       (t
387        (cond ((not (blank-after-p mark))
388               (line-end mark))
389              ((line-next line)
390               (line-start mark (line-next line)))
391              ((not (end-line-p mark))
392               (line-end mark))
393              (t 
394               (editor-error)))
395        (kill-region (region point mark) :kill-forward))))))
396
397(defcommand "Backward Kill Line" (p)
398  "Kill from the point to the beginning of the line.
399  If at the beginning of the line, kill the newline and any trailing space
400  on the previous line.  With prefix argument, call \"Kill Line\" with
401  the argument negated."
402  "Kills p lines before the point."
403  (if p
404      (kill-line-command (- p))
405      (with-mark ((m (current-point)))
406        (cond ((zerop (mark-charpos m))
407               (mark-before m)
408               (unless (reverse-find-attribute m :space #'zerop)
409                 (buffer-start m)))
410               (t
411                (line-start m)))
412        (kill-region (region m (current-point)) :kill-backward))))
413
414
415(defcommand "Delete Blank Lines" (p)
416  "On a blank line, deletes all surrounding blank lines, leaving just
417  one. On an isolated blank line, deletes that one. On a non-blank line,
418  deletes all blank following that one."
419  "Kill blank lines around the point"
420  (declare (ignore p))
421  (let ((point (current-point)))
422    (with-mark ((beg-mark point :left-inserting)
423                (end-mark point :right-inserting))
424      ;; handle case when the current line is blank
425      (when (blank-line-p (mark-line point))
426        ;; back up to last non-whitespace character
427        (reverse-find-attribute beg-mark :whitespace #'zerop)
428        (when (previous-character beg-mark)
429          ;; that is, we didn't back up to the beginning of the buffer
430          (unless (same-line-p beg-mark end-mark)
431            (line-offset beg-mark 1 0)))
432        ;; if isolated, zap the line else zap the blank ones above
433        (cond ((same-line-p beg-mark end-mark)
434               (line-offset end-mark 1 0))
435              (t
436               (line-start end-mark)))
437        (delete-region (region beg-mark end-mark)))
438      ;; always delete all blank lines after the current line
439      (move-mark beg-mark point)
440      (when (line-offset beg-mark 1 0)
441        (move-mark end-mark beg-mark)
442        (find-attribute end-mark :whitespace #'zerop)
443        (when (next-character end-mark)
444          ;; that is, we didn't go all the way to the end of the buffer
445          (line-start end-mark))
446        (delete-region (region beg-mark end-mark))))))
447
448
449(defcommand "Un-Kill" (p)
450  "Inserts the top item in the kill-ring at the point.
451  The mark is left mark before the insertion and the point after.  With prefix
452  argument inserts the prefix'th most recent item."
453  "Inserts the item with index p in the kill ring at the point, leaving
454  the mark before and the point after."
455  (let ((idx (1- (or p 1))))
456    (cond ((> (ring-length *kill-ring*) idx -1)
457           (let* ((region (ring-ref *kill-ring* idx))
458                  (point (current-point))
459                  (mark (copy-mark point)))
460             (push-buffer-mark mark)
461             (insert-region point region)
462             (make-region-undo :delete "Un-Kill"
463                               (region (copy-mark mark) (copy-mark point))))
464           (setf (last-command-type) :unkill))
465          (t (editor-error)))))
466;;;
467(push :unkill *ephemerally-active-command-types*)
468
469(defcommand "Rotate Kill Ring" (p)
470  "Replace un-killed text with previously killed text.
471  Kills the current region, rotates the kill ring, and inserts the new top
472  item.  With prefix argument rotates the kill ring that many times."
473  "This function will not behave in any reasonable fashion when
474  called as a lisp function."
475  (let ((point (current-point))
476        (mark (current-mark)))
477    (cond ((or (not (eq (last-command-type) :unkill))
478               (zerop (ring-length *kill-ring*)))
479           (editor-error))
480          (t (delete-region (region mark point))
481             (rotate-ring *kill-ring* (or p 1))
482             (insert-region point (ring-ref *kill-ring* 0))
483             (make-region-undo :delete "Un-Kill"
484                               (region (copy-mark mark) (copy-mark point)))
485             (setf (last-command-type) :unkill)))))
Note: See TracBrowser for help on using the repository browser.