/[cmucl]/src/hemlock/killcoms.lisp
ViewVC logotype

Contents of /src/hemlock/killcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Mar 13 15:49:54 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +3 -3 lines
Change toplevel PROCLAIMs to DECLAIMs.
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/killcoms.lisp,v 1.4 2001/03/13 15:49:54 pw Rel $")
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 *active-region-p* nil)
36 (defvar *active-region-buffer* nil)
37 (defvar *ephemerally-active-command-types* (list :ephemerally-active)
38 "This is a list of command types that permit the current region to be active
39 for the immediately following command.")
40
41 (declaim (inline activate-region deactivate-region region-active-p))
42
43 (defun activate-region ()
44 "Make the current region active."
45 (let ((buffer (current-buffer)))
46 (setf *active-region-p* (buffer-signature buffer))
47 (setf *active-region-buffer* buffer)))
48
49 (defun deactivate-region ()
50 "Make the current region not active."
51 (setf *active-region-p* nil)
52 (setf *active-region-buffer* nil))
53
54 (defun region-active-p ()
55 "Returns t or nil, depending on whether the current region is active."
56 (or (and *active-region-buffer*
57 (eql *active-region-p* (buffer-signature *active-region-buffer*)))
58 (member (last-command-type) *ephemerally-active-command-types*
59 :test #'equal)))
60
61 (defun check-region-active ()
62 "Signals an error when active regions are enabled and the current region
63 is not active."
64 (when (and (value active-regions-enabled) (not (region-active-p)))
65 (editor-error "The current region is not active.")))
66
67 (defun current-region (&optional (error-if-not-active t)
68 (deactivate-region t))
69 "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally
70 signalling an editor error if the current region is not active. A new
71 region is cons'ed on each call. This optionally deactivates the region."
72 (when error-if-not-active (check-region-active))
73 (when deactivate-region (deactivate-region))
74 (let ((point (current-point))
75 (mark (current-mark)))
76 (if (mark< mark point) (region mark point) (region point mark))))
77
78
79 (defcommand "Activate Region" (p)
80 "Make the current region active. ^G deactivates the region."
81 "Make the current region active."
82 (declare (ignore p))
83 (activate-region))
84
85
86 ;;; The following are hook functions for keeping things righteous.
87 ;;;
88
89 (defun set-buffer-deactivate-region (buffer)
90 (declare (ignore buffer))
91 (deactivate-region))
92 ;;;
93 (add-hook set-buffer-hook 'set-buffer-deactivate-region)
94
95 (defun set-window-deactivate-region (window)
96 (unless (or (eq window *echo-area-window*)
97 (eq (current-window) *echo-area-window*))
98 (deactivate-region)))
99 ;;;
100 (add-hook set-window-hook 'set-window-deactivate-region)
101
102 (defun control-g-deactivate-region ()
103 (deactivate-region))
104 ;;;
105 (add-hook abort-hook 'control-g-deactivate-region)
106
107
108
109 ;;;; Buffer-Mark primitives and commands.
110
111 ;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the
112 ;;; stack for each buffer.
113
114 (defun current-mark ()
115 "Returns the top of the current buffer's mark stack."
116 (ring-ref (value buffer-mark-ring) 0))
117
118 (defun buffer-mark (buffer)
119 "Returns the top of buffer's mark stack."
120 (ring-ref (variable-value 'buffer-mark-ring :buffer buffer) 0))
121
122 (defun pop-buffer-mark ()
123 "Pops the current buffer's mark stack, returning the mark. If the stack
124 becomes empty, a mark is push on the stack pointing to the buffer's start.
125 This always makes the current region not active."
126 (let* ((ring (value buffer-mark-ring))
127 (mark (ring-pop ring)))
128 (deactivate-region)
129 (if (zerop (ring-length ring))
130 (ring-push (copy-mark
131 (buffer-start-mark (current-buffer)) :right-inserting)
132 ring))
133 mark))
134
135 (defun push-buffer-mark (mark &optional (activate-region nil))
136 "Pushes mark into buffer's mark ring, ensuring that the mark is in the right
137 buffer and :right-inserting. Optionally, the current region is made active.
138 This never deactivates the current region. Mark is returned."
139 (cond ((eq (line-buffer (mark-line mark)) (current-buffer))
140 (setf (mark-kind mark) :right-inserting)
141 (ring-push mark (value buffer-mark-ring)))
142 (t (error "Mark not in the current buffer.")))
143 (when activate-region (activate-region))
144 mark)
145
146 (defcommand "Set/Pop Mark" (p)
147 "Set or Pop the mark ring.
148 With no C-U's, pushes point as the mark, activating the current region.
149 With one C-U's, pops the mark into point, de-activating the current region.
150 With two C-U's, pops the mark and throws it away, de-activating the current
151 region."
152 "Set or Pop the mark ring."
153 (cond ((not p)
154 (push-buffer-mark (copy-mark (current-point)) t)
155 (when (interactive)
156 (message "Mark pushed.")))
157 ((= p (value universal-argument-default))
158 (pop-and-goto-mark-command nil))
159 ((= p (expt (value universal-argument-default) 2))
160 (delete-mark (pop-buffer-mark)))
161 (t (editor-error))))
162
163 (defcommand "Pop and Goto Mark" (p)
164 "Pop mark into point, de-activating the current region."
165 "Pop mark into point."
166 (declare (ignore p))
167 (let ((mark (pop-buffer-mark)))
168 (move-mark (current-point) mark)
169 (delete-mark mark)))
170
171 (defcommand "Pop Mark" (p)
172 "Pop mark and throw it away, de-activating the current region."
173 "Pop mark and throw it away."
174 (declare (ignore p))
175 (delete-mark (pop-buffer-mark)))
176
177 (defcommand "Exchange Point and Mark" (p)
178 "Swap the positions of the point and the mark."
179 "Swap the positions of the point and the mark."
180 (declare (ignore p))
181 (let ((point (current-point))
182 (mark (current-mark)))
183 (with-mark ((temp point))
184 (move-mark point mark)
185 (move-mark mark temp))))
186
187 (defcommand "Mark Whole Buffer" (p)
188 "Set the region around the whole buffer, activating the region.
189 Pushes the point on the mark ring first, so two pops get it back.
190 With prefix argument, put mark at beginning and point at end."
191 "Put point at beginning and part at end of current buffer.
192 If P, do it the other way around."
193 (let* ((region (buffer-region (current-buffer)))
194 (start (region-start region))
195 (end (region-end region))
196 (point (current-point)))
197 (push-buffer-mark (copy-mark point))
198 (cond (p (push-buffer-mark (copy-mark start) t)
199 (move-mark point end))
200 (t (push-buffer-mark (copy-mark end) t)
201 (move-mark point start)))))
202
203
204
205 ;;;; KILL-REGION and KILL-CHARACTERS primitives.
206
207 (declaim (special *delete-char-region*))
208
209 ;;; KILL-REGION first checks for any characters that may need to be added to
210 ;;; the region. If there are some, we possibly push a region onto *kill-ring*,
211 ;;; and we use the top of *kill-ring*. If there are no characters to deal
212 ;;; with, then we make sure the ring isn't empty; if it is, just push our
213 ;;; region. If there is some region in *kill-ring*, then see if the last
214 ;;; command type was a region kill. Otherwise, just push the region.
215 ;;;
216 (defun kill-region (region current-type)
217 "Kills the region saving it in *kill-ring*. Current-type is either
218 :kill-forward or :kill-backward. When LAST-COMMAND-TYPE is one of these,
219 region is appended or prepended, respectively, to the top of *kill-ring*.
220 The killing of the region is undo-able with \"Undo\". LAST-COMMAND-TYPE
221 is set to current-type. This interacts with KILL-CHARACTERS."
222 (let ((last-type (last-command-type))
223 (insert-mark (copy-mark (region-start region) :left-inserting)))
224 (cond ((or (eq last-type :char-kill-forward)
225 (eq last-type :char-kill-backward))
226 (when *delete-char-region*
227 (ring-push *delete-char-region* *kill-ring*)
228 (setf *delete-char-region* nil))
229 (setf region (kill-region-top-of-ring region current-type)))
230 ((zerop (ring-length *kill-ring*))
231 (setf region (delete-and-save-region region))
232 (ring-push region *kill-ring*))
233 ((or (eq last-type :kill-forward) (eq last-type :kill-backward))
234 (setf region (kill-region-top-of-ring region current-type)))
235 (t
236 (setf region (delete-and-save-region region))
237 (ring-push region *kill-ring*)))
238 (make-region-undo :insert "kill" (copy-region region) insert-mark)
239 (setf (last-command-type) current-type)))
240
241 (defun kill-region-top-of-ring (region current-type)
242 (let ((r (ring-ref *kill-ring* 0)))
243 (ninsert-region (if (eq current-type :kill-forward)
244 (region-end r)
245 (region-start r))
246 (delete-and-save-region region))
247 r))
248
249 (defhvar "Character Deletion Threshold"
250 "When this many characters are deleted contiguously via KILL-CHARACTERS,
251 they are saved on the kill ring -- for example, \"Delete Next Character\",
252 \"Delete Previous Character\", or \"Delete Previous Character Expanding
253 Tabs\"."
254 :value 5)
255
256 (defvar *delete-char-region* nil)
257 (defvar *delete-char-count* 0)
258
259 ;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET.
260 ;;; If the last command type was a region kill, we just use the top region
261 ;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is
262 ;;; over the threshold. We don't call KILL-REGION in this case to save making
263 ;;; undo's -- no good reason. If we were just called, then increment our
264 ;;; global counter. Otherwise, make an empty region to keep KILL-CHAR-REGION
265 ;;; happy and increment the global counter.
266 ;;;
267 (defun kill-characters (mark count)
268 "Kills count characters after mark if positive, before mark if negative.
269 If called multiple times contiguously such that the sum of the count values
270 equals \"Character Deletion Threshold\", then the characters are saved on
271 *kill-ring*. This relies on setting LAST-COMMAND-TYPE, and it interacts
272 with KILL-REGION. If there are not count characters in the appropriate
273 direction, no characters are deleted, and nil is returned; otherwise, mark
274 is returned."
275 (if (zerop count)
276 mark
277 (with-mark ((temp mark :left-inserting))
278 (if (character-offset temp count)
279 (let ((current-type (if (plusp count)
280 :char-kill-forward
281 :char-kill-backward))
282 (last-type (last-command-type))
283 (del-region (if (mark< temp mark)
284 (region temp mark)
285 (region mark temp))))
286 (cond ((or (eq last-type :kill-forward)
287 (eq last-type :kill-backward))
288 (setf *delete-char-count*
289 (value character-deletion-threshold))
290 (setf *delete-char-region* nil))
291 ((or (eq last-type :char-kill-backward)
292 (eq last-type :char-kill-forward))
293 (incf *delete-char-count* (abs count)))
294 (t
295 (setf *delete-char-region* (make-empty-region))
296 (setf *delete-char-count* (abs count))))
297 (kill-char-region del-region current-type)
298 mark)
299 nil))))
300
301 (defun kill-char-region (region current-type)
302 (let ((deleted-region (delete-and-save-region region)))
303 (cond ((< *delete-char-count* (value character-deletion-threshold))
304 (ninsert-region (if (eq current-type :char-kill-forward)
305 (region-end *delete-char-region*)
306 (region-start *delete-char-region*))
307 deleted-region)
308 (setf (last-command-type) current-type))
309 (t
310 (when *delete-char-region*
311 (ring-push *delete-char-region* *kill-ring*)
312 (setf *delete-char-region* nil))
313 (let ((r (ring-ref *kill-ring* 0)))
314 (ninsert-region (if (eq current-type :char-kill-forward)
315 (region-end r)
316 (region-start r))
317 deleted-region))
318 (setf (last-command-type)
319 (if (eq current-type :char-kill-forward)
320 :kill-forward
321 :kill-backward))))))
322
323
324
325 ;;;; Commands.
326
327 (defcommand "Kill Region" (p)
328 "Kill the region, pushing on the kill ring.
329 If the region is not active nor the last command a yank, signal an error."
330 "Kill the region, pushing on the kill ring."
331 (declare (ignore p))
332 (kill-region (current-region)
333 (if (mark< (current-mark) (current-point))
334 :kill-backward
335 :kill-forward)))
336
337 (defcommand "Save Region" (p)
338 "Insert the region into the kill ring.
339 If the region is not active nor the last command a yank, signal an error."
340 "Insert the region into the kill ring."
341 (declare (ignore p))
342 (ring-push (copy-region (current-region)) *kill-ring*))
343
344 (defcommand "Kill Next Word" (p)
345 "Kill a word at the point.
346 With prefix argument delete that many words. The text killed is
347 appended to the text currently at the top of the kill ring if it was
348 next to the text being killed."
349 "Kill p words at the point"
350 (let ((point (current-point))
351 (num (or p 1)))
352 (with-mark ((mark point :temporary))
353 (if (word-offset mark num)
354 (if (minusp num)
355 (kill-region (region mark point) :kill-backward)
356 (kill-region (region point mark) :kill-forward))
357 (editor-error)))))
358
359 (defcommand "Kill Previous Word" (p)
360 "Kill a word before the point.
361 With prefix argument kill that many words before the point. The text
362 being killed is appended to the text currently at the top of the kill
363 ring if it was next to the text being killed."
364 "Kill p words before the point"
365 (kill-next-word-command (- (or p 1))))
366
367
368 (defcommand "Kill Line" (p)
369 "Kills the characters to the end of the current line.
370 If the line is empty then the line is deleted. With prefix argument,
371 deletes that many lines past the point (or before if the prefix is negative)."
372 "Kills p lines after the point."
373 (let* ((point (current-point))
374 (line (mark-line point)))
375 (with-mark ((mark point))
376 (cond
377 (p
378 (when (and (/= (mark-charpos point) 0) (minusp p))
379 (incf p))
380 (unless (line-offset mark p 0)
381 (if (plusp p)
382 (kill-region (region point (buffer-end mark)) :kill-forward)
383 (kill-region (region (buffer-start mark) point) :kill-backward))
384 (editor-error))
385 (if (plusp p)
386 (kill-region (region point mark) :kill-forward)
387 (kill-region (region mark point) :kill-backward)))
388 (t
389 (cond ((not (blank-after-p mark))
390 (line-end mark))
391 ((line-next line)
392 (line-start mark (line-next line)))
393 ((not (end-line-p mark))
394 (line-end mark))
395 (t
396 (editor-error)))
397 (kill-region (region point mark) :kill-forward))))))
398
399 (defcommand "Backward Kill Line" (p)
400 "Kill from the point to the beginning of the line.
401 If at the beginning of the line, kill the newline and any trailing space
402 on the previous line. With prefix argument, call \"Kill Line\" with
403 the argument negated."
404 "Kills p lines before the point."
405 (if p
406 (kill-line-command (- p))
407 (with-mark ((m (current-point)))
408 (cond ((zerop (mark-charpos m))
409 (mark-before m)
410 (unless (reverse-find-attribute m :space #'zerop)
411 (buffer-start m)))
412 (t
413 (line-start m)))
414 (kill-region (region m (current-point)) :kill-backward))))
415
416
417 (defcommand "Delete Blank Lines" (p)
418 "On a blank line, deletes all surrounding blank lines, leaving just
419 one. On an isolated blank line, deletes that one. On a non-blank line,
420 deletes all blank following that one."
421 "Kill blank lines around the point"
422 (declare (ignore p))
423 (let ((point (current-point)))
424 (with-mark ((beg-mark point :left-inserting)
425 (end-mark point :right-inserting))
426 ;; handle case when the current line is blank
427 (when (blank-line-p (mark-line point))
428 ;; back up to last non-whitespace character
429 (reverse-find-attribute beg-mark :whitespace #'zerop)
430 (when (previous-character beg-mark)
431 ;; that is, we didn't back up to the beginning of the buffer
432 (unless (same-line-p beg-mark end-mark)
433 (line-offset beg-mark 1 0)))
434 ;; if isolated, zap the line else zap the blank ones above
435 (cond ((same-line-p beg-mark end-mark)
436 (line-offset end-mark 1 0))
437 (t
438 (line-start end-mark)))
439 (delete-region (region beg-mark end-mark)))
440 ;; always delete all blank lines after the current line
441 (move-mark beg-mark point)
442 (when (line-offset beg-mark 1 0)
443 (move-mark end-mark beg-mark)
444 (find-attribute end-mark :whitespace #'zerop)
445 (when (next-character end-mark)
446 ;; that is, we didn't go all the way to the end of the buffer
447 (line-start end-mark))
448 (delete-region (region beg-mark end-mark))))))
449
450
451 (defcommand "Un-Kill" (p)
452 "Inserts the top item in the kill-ring at the point.
453 The mark is left mark before the insertion and the point after. With prefix
454 argument inserts the prefix'th most recent item."
455 "Inserts the item with index p in the kill ring at the point, leaving
456 the mark before and the point after."
457 (let ((idx (1- (or p 1))))
458 (cond ((> (ring-length *kill-ring*) idx -1)
459 (let* ((region (ring-ref *kill-ring* idx))
460 (point (current-point))
461 (mark (copy-mark point)))
462 (push-buffer-mark mark)
463 (insert-region point region)
464 (make-region-undo :delete "Un-Kill"
465 (region (copy-mark mark) (copy-mark point))))
466 (setf (last-command-type) :unkill))
467 (t (editor-error)))))
468 ;;;
469 (push :unkill *ephemerally-active-command-types*)
470
471 (defcommand "Rotate Kill Ring" (p)
472 "Replace un-killed text with previously killed text.
473 Kills the current region, rotates the kill ring, and inserts the new top
474 item. With prefix argument rotates the kill ring that many times."
475 "This function will not behave in any reasonable fashion when
476 called as a lisp function."
477 (let ((point (current-point))
478 (mark (current-mark)))
479 (cond ((or (not (eq (last-command-type) :unkill))
480 (zerop (ring-length *kill-ring*)))
481 (editor-error))
482 (t (delete-region (region mark point))
483 (rotate-ring *kill-ring* (or p 1))
484 (insert-region point (ring-ref *kill-ring* 0))
485 (make-region-undo :delete "Un-Kill"
486 (region (copy-mark mark) (copy-mark point)))
487 (setf (last-command-type) :unkill)))))

  ViewVC Help
Powered by ViewVC 1.1.5