Revision: miles@gnu.org--gnu-2005/emacs--unicode--0--patch-68
[bpt/emacs.git] / src / undo.c
1 /* undo handling for GNU Emacs.
2 Copyright (C) 1990, 1993, 1994, 2000, 2002, 2004, 2005
3 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
21
22
23 #include <config.h>
24 #include "lisp.h"
25 #include "buffer.h"
26 #include "commands.h"
27
28 /* Limits controlling how much undo information to keep. */
29
30 EMACS_INT undo_limit;
31 EMACS_INT undo_strong_limit;
32
33 Lisp_Object Vundo_outer_limit;
34
35 /* Function to call when undo_outer_limit is exceeded. */
36
37 Lisp_Object Vundo_outer_limit_function;
38
39 /* Last buffer for which undo information was recorded. */
40 Lisp_Object last_undo_buffer;
41
42 Lisp_Object Qinhibit_read_only;
43
44 /* Marker for function call undo list elements. */
45
46 Lisp_Object Qapply;
47
48 /* The first time a command records something for undo.
49 it also allocates the undo-boundary object
50 which will be added to the list at the end of the command.
51 This ensures we can't run out of space while trying to make
52 an undo-boundary. */
53 Lisp_Object pending_boundary;
54
55 /* Record point as it was at beginning of this command (if necessary)
56 And prepare the undo info for recording a change.
57 PT is the position of point that will naturally occur as a result of the
58 undo record that will be added just after this command terminates. */
59
60 static void
61 record_point (pt)
62 int pt;
63 {
64 int at_boundary;
65
66 /* Allocate a cons cell to be the undo boundary after this command. */
67 if (NILP (pending_boundary))
68 pending_boundary = Fcons (Qnil, Qnil);
69
70 if (!BUFFERP (last_undo_buffer)
71 || current_buffer != XBUFFER (last_undo_buffer))
72 Fundo_boundary ();
73 XSETBUFFER (last_undo_buffer, current_buffer);
74
75 if (CONSP (current_buffer->undo_list))
76 {
77 /* Set AT_BOUNDARY to 1 only when we have nothing other than
78 marker adjustment before undo boundary. */
79
80 Lisp_Object tail = current_buffer->undo_list, elt;
81
82 while (1)
83 {
84 if (NILP (tail))
85 elt = Qnil;
86 else
87 elt = XCAR (tail);
88 if (NILP (elt) || ! (CONSP (elt) && MARKERP (XCAR (elt))))
89 break;
90 tail = XCDR (tail);
91 }
92 at_boundary = NILP (elt);
93 }
94 else
95 at_boundary = 1;
96
97 if (MODIFF <= SAVE_MODIFF)
98 record_first_change ();
99
100 /* If we are just after an undo boundary, and
101 point wasn't at start of deleted range, record where it was. */
102 if (at_boundary
103 && last_point_position != pt
104 /* If we're called from batch mode, this could be nil. */
105 && BUFFERP (last_point_position_buffer)
106 && current_buffer == XBUFFER (last_point_position_buffer))
107 current_buffer->undo_list
108 = Fcons (make_number (last_point_position), current_buffer->undo_list);
109 }
110
111 /* Record an insertion that just happened or is about to happen,
112 for LENGTH characters at position BEG.
113 (It is possible to record an insertion before or after the fact
114 because we don't need to record the contents.) */
115
116 void
117 record_insert (beg, length)
118 int beg, length;
119 {
120 Lisp_Object lbeg, lend;
121
122 if (EQ (current_buffer->undo_list, Qt))
123 return;
124
125 record_point (beg);
126
127 /* If this is following another insertion and consecutive with it
128 in the buffer, combine the two. */
129 if (CONSP (current_buffer->undo_list))
130 {
131 Lisp_Object elt;
132 elt = XCAR (current_buffer->undo_list);
133 if (CONSP (elt)
134 && INTEGERP (XCAR (elt))
135 && INTEGERP (XCDR (elt))
136 && XINT (XCDR (elt)) == beg)
137 {
138 XSETCDR (elt, make_number (beg + length));
139 return;
140 }
141 }
142
143 XSETFASTINT (lbeg, beg);
144 XSETINT (lend, beg + length);
145 current_buffer->undo_list = Fcons (Fcons (lbeg, lend),
146 current_buffer->undo_list);
147 }
148
149 /* Record that a deletion is about to take place,
150 of the characters in STRING, at location BEG. */
151
152 void
153 record_delete (beg, string)
154 int beg;
155 Lisp_Object string;
156 {
157 Lisp_Object sbeg;
158
159 if (EQ (current_buffer->undo_list, Qt))
160 return;
161
162 if (PT == beg + SCHARS (string))
163 {
164 XSETINT (sbeg, -beg);
165 record_point (PT);
166 }
167 else
168 {
169 XSETFASTINT (sbeg, beg);
170 record_point (beg);
171 }
172
173 current_buffer->undo_list
174 = Fcons (Fcons (string, sbeg), current_buffer->undo_list);
175 }
176
177 /* Record the fact that MARKER is about to be adjusted by ADJUSTMENT.
178 This is done only when a marker points within text being deleted,
179 because that's the only case where an automatic marker adjustment
180 won't be inverted automatically by undoing the buffer modification. */
181
182 void
183 record_marker_adjustment (marker, adjustment)
184 Lisp_Object marker;
185 int adjustment;
186 {
187 if (EQ (current_buffer->undo_list, Qt))
188 return;
189
190 /* Allocate a cons cell to be the undo boundary after this command. */
191 if (NILP (pending_boundary))
192 pending_boundary = Fcons (Qnil, Qnil);
193
194 if (!BUFFERP (last_undo_buffer)
195 || current_buffer != XBUFFER (last_undo_buffer))
196 Fundo_boundary ();
197 XSETBUFFER (last_undo_buffer, current_buffer);
198
199 current_buffer->undo_list
200 = Fcons (Fcons (marker, make_number (adjustment)),
201 current_buffer->undo_list);
202 }
203
204 /* Record that a replacement is about to take place,
205 for LENGTH characters at location BEG.
206 The replacement must not change the number of characters. */
207
208 void
209 record_change (beg, length)
210 int beg, length;
211 {
212 record_delete (beg, make_buffer_string (beg, beg + length, 1));
213 record_insert (beg, length);
214 }
215 \f
216 /* Record that an unmodified buffer is about to be changed.
217 Record the file modification date so that when undoing this entry
218 we can tell whether it is obsolete because the file was saved again. */
219
220 void
221 record_first_change ()
222 {
223 Lisp_Object high, low;
224 struct buffer *base_buffer = current_buffer;
225
226 if (EQ (current_buffer->undo_list, Qt))
227 return;
228
229 if (!BUFFERP (last_undo_buffer)
230 || current_buffer != XBUFFER (last_undo_buffer))
231 Fundo_boundary ();
232 XSETBUFFER (last_undo_buffer, current_buffer);
233
234 if (base_buffer->base_buffer)
235 base_buffer = base_buffer->base_buffer;
236
237 XSETFASTINT (high, (base_buffer->modtime >> 16) & 0xffff);
238 XSETFASTINT (low, base_buffer->modtime & 0xffff);
239 current_buffer->undo_list = Fcons (Fcons (Qt, Fcons (high, low)), current_buffer->undo_list);
240 }
241
242 /* Record a change in property PROP (whose old value was VAL)
243 for LENGTH characters starting at position BEG in BUFFER. */
244
245 void
246 record_property_change (beg, length, prop, value, buffer)
247 int beg, length;
248 Lisp_Object prop, value, buffer;
249 {
250 Lisp_Object lbeg, lend, entry;
251 struct buffer *obuf = current_buffer;
252 int boundary = 0;
253
254 if (EQ (XBUFFER (buffer)->undo_list, Qt))
255 return;
256
257 /* Allocate a cons cell to be the undo boundary after this command. */
258 if (NILP (pending_boundary))
259 pending_boundary = Fcons (Qnil, Qnil);
260
261 if (!EQ (buffer, last_undo_buffer))
262 boundary = 1;
263 last_undo_buffer = buffer;
264
265 /* Switch temporarily to the buffer that was changed. */
266 current_buffer = XBUFFER (buffer);
267
268 if (boundary)
269 Fundo_boundary ();
270
271 if (MODIFF <= SAVE_MODIFF)
272 record_first_change ();
273
274 XSETINT (lbeg, beg);
275 XSETINT (lend, beg + length);
276 entry = Fcons (Qnil, Fcons (prop, Fcons (value, Fcons (lbeg, lend))));
277 current_buffer->undo_list = Fcons (entry, current_buffer->undo_list);
278
279 current_buffer = obuf;
280 }
281
282 DEFUN ("undo-boundary", Fundo_boundary, Sundo_boundary, 0, 0, 0,
283 doc: /* Mark a boundary between units of undo.
284 An undo command will stop at this point,
285 but another undo command will undo to the previous boundary. */)
286 ()
287 {
288 Lisp_Object tem;
289 if (EQ (current_buffer->undo_list, Qt))
290 return Qnil;
291 tem = Fcar (current_buffer->undo_list);
292 if (!NILP (tem))
293 {
294 /* One way or another, cons nil onto the front of the undo list. */
295 if (!NILP (pending_boundary))
296 {
297 /* If we have preallocated the cons cell to use here,
298 use that one. */
299 XSETCDR (pending_boundary, current_buffer->undo_list);
300 current_buffer->undo_list = pending_boundary;
301 pending_boundary = Qnil;
302 }
303 else
304 current_buffer->undo_list = Fcons (Qnil, current_buffer->undo_list);
305 }
306 return Qnil;
307 }
308
309 /* At garbage collection time, make an undo list shorter at the end,
310 returning the truncated list. How this is done depends on the
311 variables undo-limit, undo-strong-limit and undo-outer-limit.
312 In some cases this works by calling undo-outer-limit-function. */
313
314 void
315 truncate_undo_list (b)
316 struct buffer *b;
317 {
318 Lisp_Object list;
319 Lisp_Object prev, next, last_boundary;
320 int size_so_far = 0;
321
322 /* Make sure that calling undo-outer-limit-function
323 won't cause another GC. */
324 int count = inhibit_garbage_collection ();
325
326 /* Make the buffer current to get its local values of variables such
327 as undo_limit. Also so that Vundo_outer_limit_function can
328 tell which buffer to operate on. */
329 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
330 set_buffer_internal (b);
331
332 list = b->undo_list;
333
334 prev = Qnil;
335 next = list;
336 last_boundary = Qnil;
337
338 /* If the first element is an undo boundary, skip past it. */
339 if (CONSP (next) && NILP (XCAR (next)))
340 {
341 /* Add in the space occupied by this element and its chain link. */
342 size_so_far += sizeof (struct Lisp_Cons);
343
344 /* Advance to next element. */
345 prev = next;
346 next = XCDR (next);
347 }
348
349 /* Always preserve at least the most recent undo record
350 unless it is really horribly big.
351
352 Skip, skip, skip the undo, skip, skip, skip the undo,
353 Skip, skip, skip the undo, skip to the undo bound'ry. */
354
355 while (CONSP (next) && ! NILP (XCAR (next)))
356 {
357 Lisp_Object elt;
358 elt = XCAR (next);
359
360 /* Add in the space occupied by this element and its chain link. */
361 size_so_far += sizeof (struct Lisp_Cons);
362 if (CONSP (elt))
363 {
364 size_so_far += sizeof (struct Lisp_Cons);
365 if (STRINGP (XCAR (elt)))
366 size_so_far += (sizeof (struct Lisp_String) - 1
367 + SCHARS (XCAR (elt)));
368 }
369
370 /* Advance to next element. */
371 prev = next;
372 next = XCDR (next);
373 }
374
375 /* If by the first boundary we have already passed undo_outer_limit,
376 we're heading for memory full, so offer to clear out the list. */
377 if (INTEGERP (Vundo_outer_limit)
378 && size_so_far > XINT (Vundo_outer_limit)
379 && !NILP (Vundo_outer_limit_function))
380 {
381 Lisp_Object temp = last_undo_buffer;
382
383 /* Normally the function this calls is undo-outer-limit-truncate. */
384 if (! NILP (call1 (Vundo_outer_limit_function,
385 make_number (size_so_far))))
386 {
387 /* The function is responsible for making
388 any desired changes in buffer-undo-list. */
389 unbind_to (count, Qnil);
390 return;
391 }
392 /* That function probably used the minibuffer, and if so, that
393 changed last_undo_buffer. Change it back so that we don't
394 force next change to make an undo boundary here. */
395 last_undo_buffer = temp;
396 }
397
398 if (CONSP (next))
399 last_boundary = prev;
400
401 /* Keep additional undo data, if it fits in the limits. */
402 while (CONSP (next))
403 {
404 Lisp_Object elt;
405 elt = XCAR (next);
406
407 /* When we get to a boundary, decide whether to truncate
408 either before or after it. The lower threshold, undo_limit,
409 tells us to truncate after it. If its size pushes past
410 the higher threshold undo_strong_limit, we truncate before it. */
411 if (NILP (elt))
412 {
413 if (size_so_far > undo_strong_limit)
414 break;
415 last_boundary = prev;
416 if (size_so_far > undo_limit)
417 break;
418 }
419
420 /* Add in the space occupied by this element and its chain link. */
421 size_so_far += sizeof (struct Lisp_Cons);
422 if (CONSP (elt))
423 {
424 size_so_far += sizeof (struct Lisp_Cons);
425 if (STRINGP (XCAR (elt)))
426 size_so_far += (sizeof (struct Lisp_String) - 1
427 + SCHARS (XCAR (elt)));
428 }
429
430 /* Advance to next element. */
431 prev = next;
432 next = XCDR (next);
433 }
434
435 /* If we scanned the whole list, it is short enough; don't change it. */
436 if (NILP (next))
437 ;
438 /* Truncate at the boundary where we decided to truncate. */
439 else if (!NILP (last_boundary))
440 XSETCDR (last_boundary, Qnil);
441 /* There's nothing we decided to keep, so clear it out. */
442 else
443 b->undo_list = Qnil;
444
445 unbind_to (count, Qnil);
446 }
447 \f
448 DEFUN ("primitive-undo", Fprimitive_undo, Sprimitive_undo, 2, 2, 0,
449 doc: /* Undo N records from the front of the list LIST.
450 Return what remains of the list. */)
451 (n, list)
452 Lisp_Object n, list;
453 {
454 struct gcpro gcpro1, gcpro2;
455 Lisp_Object next;
456 int count = SPECPDL_INDEX ();
457 register int arg;
458 Lisp_Object oldlist;
459 int did_apply = 0;
460
461 #if 0 /* This is a good feature, but would make undo-start
462 unable to do what is expected. */
463 Lisp_Object tem;
464
465 /* If the head of the list is a boundary, it is the boundary
466 preceding this command. Get rid of it and don't count it. */
467 tem = Fcar (list);
468 if (NILP (tem))
469 list = Fcdr (list);
470 #endif
471
472 CHECK_NUMBER (n);
473 arg = XINT (n);
474 next = Qnil;
475 GCPRO2 (next, list);
476 /* I don't think we need to gcpro oldlist, as we use it only
477 to check for EQ. ++kfs */
478
479 /* In a writable buffer, enable undoing read-only text that is so
480 because of text properties. */
481 if (NILP (current_buffer->read_only))
482 specbind (Qinhibit_read_only, Qt);
483
484 /* Don't let `intangible' properties interfere with undo. */
485 specbind (Qinhibit_point_motion_hooks, Qt);
486
487 oldlist = current_buffer->undo_list;
488
489 while (arg > 0)
490 {
491 while (CONSP (list))
492 {
493 next = XCAR (list);
494 list = XCDR (list);
495 /* Exit inner loop at undo boundary. */
496 if (NILP (next))
497 break;
498 /* Handle an integer by setting point to that value. */
499 if (INTEGERP (next))
500 SET_PT (clip_to_bounds (BEGV, XINT (next), ZV));
501 else if (CONSP (next))
502 {
503 Lisp_Object car, cdr;
504
505 car = XCAR (next);
506 cdr = XCDR (next);
507 if (EQ (car, Qt))
508 {
509 /* Element (t high . low) records previous modtime. */
510 Lisp_Object high, low;
511 int mod_time;
512 struct buffer *base_buffer = current_buffer;
513
514 high = Fcar (cdr);
515 low = Fcdr (cdr);
516 mod_time = (XFASTINT (high) << 16) + XFASTINT (low);
517
518 if (current_buffer->base_buffer)
519 base_buffer = current_buffer->base_buffer;
520
521 /* If this records an obsolete save
522 (not matching the actual disk file)
523 then don't mark unmodified. */
524 if (mod_time != base_buffer->modtime)
525 continue;
526 #ifdef CLASH_DETECTION
527 Funlock_buffer ();
528 #endif /* CLASH_DETECTION */
529 Fset_buffer_modified_p (Qnil);
530 }
531 else if (EQ (car, Qnil))
532 {
533 /* Element (nil PROP VAL BEG . END) is property change. */
534 Lisp_Object beg, end, prop, val;
535
536 prop = Fcar (cdr);
537 cdr = Fcdr (cdr);
538 val = Fcar (cdr);
539 cdr = Fcdr (cdr);
540 beg = Fcar (cdr);
541 end = Fcdr (cdr);
542
543 Fput_text_property (beg, end, prop, val, Qnil);
544 }
545 else if (INTEGERP (car) && INTEGERP (cdr))
546 {
547 /* Element (BEG . END) means range was inserted. */
548
549 if (XINT (car) < BEGV
550 || XINT (cdr) > ZV)
551 error ("Changes to be undone are outside visible portion of buffer");
552 /* Set point first thing, so that undoing this undo
553 does not send point back to where it is now. */
554 Fgoto_char (car);
555 Fdelete_region (car, cdr);
556 }
557 else if (EQ (car, Qapply))
558 {
559 /* Element (apply FUN . ARGS) means call FUN to undo. */
560 struct buffer *save_buffer = current_buffer;
561
562 car = Fcar (cdr);
563 cdr = Fcdr (cdr);
564 if (INTEGERP (car))
565 {
566 /* Long format: (apply DELTA START END FUN . ARGS). */
567 Lisp_Object delta = car;
568 Lisp_Object start = Fcar (cdr);
569 Lisp_Object end = Fcar (Fcdr (cdr));
570 Lisp_Object start_mark = Fcopy_marker (start, Qnil);
571 Lisp_Object end_mark = Fcopy_marker (end, Qt);
572
573 cdr = Fcdr (Fcdr (cdr));
574 apply1 (Fcar (cdr), Fcdr (cdr));
575
576 /* Check that the function did what the entry said it
577 would do. */
578 if (!EQ (start, Fmarker_position (start_mark))
579 || (XINT (delta) + XINT (end)
580 != marker_position (end_mark)))
581 error ("Changes to be undone by function different than announced");
582 Fset_marker (start_mark, Qnil, Qnil);
583 Fset_marker (end_mark, Qnil, Qnil);
584 }
585 else
586 apply1 (car, cdr);
587
588 if (save_buffer != current_buffer)
589 error ("Undo function switched buffer");
590 did_apply = 1;
591 }
592 else if (STRINGP (car) && INTEGERP (cdr))
593 {
594 /* Element (STRING . POS) means STRING was deleted. */
595 Lisp_Object membuf;
596 int pos = XINT (cdr);
597
598 membuf = car;
599 if (pos < 0)
600 {
601 if (-pos < BEGV || -pos > ZV)
602 error ("Changes to be undone are outside visible portion of buffer");
603 SET_PT (-pos);
604 Finsert (1, &membuf);
605 }
606 else
607 {
608 if (pos < BEGV || pos > ZV)
609 error ("Changes to be undone are outside visible portion of buffer");
610 SET_PT (pos);
611
612 /* Now that we record marker adjustments
613 (caused by deletion) for undo,
614 we should always insert after markers,
615 so that undoing the marker adjustments
616 put the markers back in the right place. */
617 Finsert (1, &membuf);
618 SET_PT (pos);
619 }
620 }
621 else if (MARKERP (car) && INTEGERP (cdr))
622 {
623 /* (MARKER . INTEGER) means a marker MARKER
624 was adjusted by INTEGER. */
625 if (XMARKER (car)->buffer)
626 Fset_marker (car,
627 make_number (marker_position (car) - XINT (cdr)),
628 Fmarker_buffer (car));
629 }
630 }
631 }
632 arg--;
633 }
634
635
636 /* Make sure an apply entry produces at least one undo entry,
637 so the test in `undo' for continuing an undo series
638 will work right. */
639 if (did_apply
640 && EQ (oldlist, current_buffer->undo_list))
641 current_buffer->undo_list
642 = Fcons (list3 (Qapply, Qcdr, Qnil), current_buffer->undo_list);
643
644 UNGCPRO;
645 return unbind_to (count, list);
646 }
647 \f
648 void
649 syms_of_undo ()
650 {
651 Qinhibit_read_only = intern ("inhibit-read-only");
652 staticpro (&Qinhibit_read_only);
653
654 Qapply = intern ("apply");
655 staticpro (&Qapply);
656
657 pending_boundary = Qnil;
658 staticpro (&pending_boundary);
659
660 defsubr (&Sprimitive_undo);
661 defsubr (&Sundo_boundary);
662
663 DEFVAR_INT ("undo-limit", &undo_limit,
664 doc: /* Keep no more undo information once it exceeds this size.
665 This limit is applied when garbage collection happens.
666 When a previous command increases the total undo list size past this
667 value, the earlier commands that came before it are forgotten.
668
669 The size is counted as the number of bytes occupied,
670 which includes both saved text and other data. */);
671 undo_limit = 20000;
672
673 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit,
674 doc: /* Don't keep more than this much size of undo information.
675 This limit is applied when garbage collection happens.
676 When a previous command increases the total undo list size past this
677 value, that command and the earlier commands that came before it are forgotten.
678 However, the most recent buffer-modifying command's undo info
679 is never discarded for this reason.
680
681 The size is counted as the number of bytes occupied,
682 which includes both saved text and other data. */);
683 undo_strong_limit = 30000;
684
685 DEFVAR_LISP ("undo-outer-limit", &Vundo_outer_limit,
686 doc: /* Outer limit on size of undo information for one command.
687 At garbage collection time, if the current command has produced
688 more than this much undo information, it discards the info and displays
689 a warning. This is a last-ditch limit to prevent memory overflow.
690
691 The size is counted as the number of bytes occupied, which includes
692 both saved text and other data. A value of nil means no limit. In
693 this case, accumulating one huge undo entry could make Emacs crash as
694 a result of memory overflow.
695
696 In fact, this calls the function which is the value of
697 `undo-outer-limit-function' with one argument, the size.
698 The text above describes the behavior of the function
699 that variable usually specifies. */);
700 Vundo_outer_limit = make_number (3000000);
701
702 DEFVAR_LISP ("undo-outer-limit-function", &Vundo_outer_limit_function,
703 doc: /* Function to call when an undo list exceeds `undo-outer-limit'.
704 This function is called with one argument, the current undo list size
705 for the most recent command (since the last undo boundary).
706 If the function returns t, that means truncation has been fully handled.
707 If it returns nil, the other forms of truncation are done.
708
709 Garbage collection is inhibited around the call to this function,
710 so it must make sure not to do a lot of consing. */);
711 Vundo_outer_limit_function = Qnil;
712 }
713
714 /* arch-tag: d546ee01-4aed-4ffb-bb8b-eefaae50d38a
715 (do not change this comment) */