428
|
1 /* undo handling for XEmacs.
|
|
2 Copyright (C) 1990, 1992, 1993, 1994 Free Software Foundation, Inc.
|
|
3
|
|
4 This file is part of XEmacs.
|
|
5
|
|
6 XEmacs is free software; you can redistribute it and/or modify it
|
|
7 under the terms of the GNU General Public License as published by the
|
|
8 Free Software Foundation; either version 2, or (at your option) any
|
|
9 later version.
|
|
10
|
|
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
|
|
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
14 for more details.
|
|
15
|
|
16 You should have received a copy of the GNU General Public License
|
|
17 along with XEmacs; see the file COPYING. If not, write to
|
|
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
19 Boston, MA 02111-1307, USA. */
|
|
20
|
|
21 /* Synched up with: FSF 19.28. */
|
|
22
|
|
23 /* This file has been Mule-ized. */
|
|
24
|
|
25 #include <config.h>
|
|
26 #include "lisp.h"
|
|
27 #include "buffer.h"
|
|
28 #include "extents.h"
|
|
29
|
|
30 /* Maintained in event-stream.c */
|
|
31 extern Bufpos last_point_position;
|
|
32 extern Lisp_Object last_point_position_buffer;
|
|
33
|
|
34 /* Extent code needs to know about undo because the behavior of insert()
|
|
35 with regard to extents varies depending on whether we are inside
|
|
36 an undo or not. */
|
|
37 int inside_undo;
|
|
38
|
|
39 /* Last buffer for which undo information was recorded. */
|
|
40 static Lisp_Object last_undo_buffer;
|
|
41
|
|
42 Lisp_Object Qinhibit_read_only;
|
|
43
|
|
44 /* The first time a command records something for undo.
|
|
45 it also allocates the undo-boundary object
|
|
46 which will be added to the list at the end of the command.
|
|
47 This ensures we can't run out of space while trying to make
|
|
48 an undo-boundary. */
|
|
49 static Lisp_Object pending_boundary;
|
|
50
|
|
51 static void
|
|
52 undo_boundary (struct buffer *b)
|
|
53 {
|
|
54 Lisp_Object tem = Fcar (b->undo_list);
|
|
55 if (!NILP (tem))
|
|
56 {
|
|
57 /* One way or another, cons nil onto the front of the undo list. */
|
|
58 if (CONSP (pending_boundary))
|
|
59 {
|
|
60 /* If we have preallocated the cons cell to use here,
|
|
61 use that one. */
|
|
62 XCDR (pending_boundary) = b->undo_list;
|
|
63 b->undo_list = pending_boundary;
|
|
64 pending_boundary = Qnil;
|
|
65 }
|
|
66 else
|
|
67 b->undo_list = Fcons (Qnil, b->undo_list);
|
|
68 }
|
|
69 }
|
|
70
|
|
71
|
|
72 static int
|
|
73 undo_prelude (struct buffer *b, int hack_pending_boundary)
|
|
74 {
|
|
75 if (EQ (b->undo_list, Qt))
|
|
76 return (0);
|
|
77
|
|
78 if (NILP (last_undo_buffer)
|
|
79 || (BUFFER_BASE_BUFFER (b)
|
|
80 != BUFFER_BASE_BUFFER (XBUFFER (last_undo_buffer))))
|
|
81 {
|
|
82 undo_boundary (b);
|
|
83 XSETBUFFER (last_undo_buffer, b);
|
|
84 }
|
|
85
|
|
86 /* Allocate a cons cell to be the undo boundary after this command. */
|
|
87 if (hack_pending_boundary && NILP (pending_boundary))
|
|
88 pending_boundary = Fcons (Qnil, Qnil);
|
|
89
|
|
90 if (BUF_MODIFF (b) <= BUF_SAVE_MODIFF (b))
|
|
91 {
|
|
92 /* Record that an unmodified buffer is about to be changed.
|
|
93 Record the file modification date so that when undoing this
|
|
94 entry we can tell whether it is obsolete because the file was
|
|
95 saved again. */
|
|
96 b->undo_list
|
|
97 = Fcons (Fcons (Qt,
|
|
98 Fcons (make_int ((b->modtime >> 16) & 0xffff),
|
|
99 make_int (b->modtime & 0xffff))),
|
|
100 b->undo_list);
|
|
101 }
|
|
102 return 1;
|
|
103 }
|
|
104
|
|
105
|
|
106
|
|
107 static Lisp_Object
|
|
108 restore_inside_undo (Lisp_Object val)
|
|
109 {
|
|
110 inside_undo = XINT (val);
|
|
111 return val;
|
|
112 }
|
|
113
|
|
114
|
|
115 /* Record an insertion that just happened or is about to happen,
|
|
116 for LENGTH characters at position BEG.
|
|
117 (It is possible to record an insertion before or after the fact
|
|
118 because we don't need to record the contents.) */
|
|
119
|
|
120 void
|
|
121 record_insert (struct buffer *b, Bufpos beg, Charcount length)
|
|
122 {
|
|
123 if (!undo_prelude (b, 1))
|
|
124 return;
|
|
125
|
|
126 /* If this is following another insertion and consecutive with it
|
|
127 in the buffer, combine the two. */
|
|
128 if (CONSP (b->undo_list))
|
|
129 {
|
|
130 Lisp_Object elt;
|
|
131 elt = XCAR (b->undo_list);
|
|
132 if (CONSP (elt)
|
|
133 && INTP (XCAR (elt))
|
|
134 && INTP (XCDR (elt))
|
|
135 && XINT (XCDR (elt)) == beg)
|
|
136 {
|
|
137 XCDR (elt) = make_int (beg + length);
|
|
138 return;
|
|
139 }
|
|
140 }
|
|
141
|
|
142 b->undo_list = Fcons (Fcons (make_int (beg),
|
|
143 make_int (beg + length)),
|
|
144 b->undo_list);
|
|
145 }
|
|
146
|
|
147 /* Record that a deletion is about to take place,
|
|
148 for LENGTH characters at location BEG. */
|
|
149
|
|
150 void
|
|
151 record_delete (struct buffer *b, Bufpos beg, Charcount length)
|
|
152 {
|
|
153 /* This function can GC */
|
|
154 Lisp_Object sbeg;
|
|
155 int at_boundary;
|
|
156
|
|
157 if (!undo_prelude (b, 1))
|
|
158 return;
|
|
159
|
|
160 at_boundary = (CONSP (b->undo_list)
|
|
161 && NILP (XCAR (b->undo_list)));
|
|
162
|
|
163 if (BUF_PT (b) == beg + length)
|
|
164 sbeg = make_int (-beg);
|
|
165 else
|
|
166 sbeg = make_int (beg);
|
|
167
|
|
168 /* If we are just after an undo boundary, and
|
|
169 point wasn't at start of deleted range, record where it was. */
|
|
170 if (at_boundary
|
|
171 && BUFFERP (last_point_position_buffer)
|
|
172 && b == XBUFFER (last_point_position_buffer)
|
|
173 && last_point_position != XINT (sbeg))
|
|
174 b->undo_list = Fcons (make_int (last_point_position), b->undo_list);
|
|
175
|
|
176 b->undo_list = Fcons (Fcons (make_string_from_buffer (b, beg,
|
|
177 length),
|
|
178 sbeg),
|
|
179 b->undo_list);
|
|
180 }
|
|
181
|
|
182 /* Record that a replacement is about to take place,
|
|
183 for LENGTH characters at location BEG.
|
|
184 The replacement does not change the number of characters. */
|
|
185
|
|
186 void
|
|
187 record_change (struct buffer *b, Bufpos beg, Charcount length)
|
|
188 {
|
|
189 record_delete (b, beg, length);
|
|
190 record_insert (b, beg, length);
|
|
191 }
|
|
192
|
|
193 /* Record that an EXTENT is about to be attached or detached in its buffer.
|
|
194 This works much like a deletion or insertion, except that there's no string.
|
|
195 The tricky part is that the buffer we operate on comes from EXTENT.
|
|
196 Most extent changes happen as a side effect of string insertion and
|
|
197 deletion; this call is solely for Fdetach_extent() and Finsert_extent().
|
|
198 */
|
|
199 void
|
|
200 record_extent (Lisp_Object extent, int attached)
|
|
201 {
|
|
202 Lisp_Object obj = Fextent_object (extent);
|
|
203
|
|
204 if (BUFFERP (obj))
|
|
205 {
|
|
206 Lisp_Object token;
|
|
207 struct buffer *b = XBUFFER (obj);
|
|
208 if (!undo_prelude (b, 1))
|
|
209 return;
|
|
210 if (attached)
|
|
211 token = extent;
|
|
212 else
|
|
213 token = list3 (extent, Fextent_start_position (extent),
|
|
214 Fextent_end_position (extent));
|
|
215 b->undo_list = Fcons (token, b->undo_list);
|
|
216 }
|
|
217 else
|
|
218 return;
|
|
219 }
|
|
220
|
|
221 #if 0 /* FSFmacs */
|
|
222 /* Record a change in property PROP (whose old value was VAL)
|
|
223 for LENGTH characters starting at position BEG in BUFFER. */
|
|
224
|
|
225 record_property_change (Bufpos beg, Charcount length,
|
|
226 Lisp_Object prop, Lisp_Object value,
|
|
227 Lisp_Object buffer)
|
|
228 {
|
|
229 Lisp_Object lbeg, lend, entry;
|
|
230 struct buffer *b = XBUFFER (buffer);
|
|
231
|
|
232 if (!undo_prelude (b, 1))
|
|
233 return;
|
|
234
|
|
235 lbeg = make_int (beg);
|
|
236 lend = make_int (beg + length);
|
|
237 entry = Fcons (Qnil, Fcons (prop, Fcons (value, Fcons (lbeg, lend))));
|
|
238 b->undo_list = Fcons (entry, b->undo_list);
|
|
239 }
|
|
240 #endif /* FSFmacs */
|
|
241
|
|
242
|
|
243 DEFUN ("undo-boundary", Fundo_boundary, 0, 0, 0, /*
|
|
244 Mark a boundary between units of undo.
|
|
245 An undo command will stop at this point,
|
|
246 but another undo command will undo to the previous boundary.
|
|
247 */
|
|
248 ())
|
|
249 {
|
|
250 if (EQ (current_buffer->undo_list, Qt))
|
|
251 return Qnil;
|
|
252 undo_boundary (current_buffer);
|
|
253 return Qnil;
|
|
254 }
|
|
255
|
|
256 /* At garbage collection time, make an undo list shorter at the end,
|
|
257 returning the truncated list.
|
|
258 MINSIZE and MAXSIZE are the limits on size allowed, as described below.
|
|
259 In practice, these are the values of undo-threshold and
|
|
260 undo-high-threshold. */
|
|
261
|
|
262 Lisp_Object
|
|
263 truncate_undo_list (Lisp_Object list, int minsize, int maxsize)
|
|
264 {
|
|
265 Lisp_Object prev, next, last_boundary;
|
|
266 int size_so_far = 0;
|
|
267
|
|
268 if (!(minsize > 0 || maxsize > 0))
|
|
269 return list;
|
|
270
|
|
271 prev = Qnil;
|
|
272 next = list;
|
|
273 last_boundary = Qnil;
|
|
274
|
|
275 if (!CONSP (list))
|
|
276 return (list);
|
|
277
|
|
278 /* Always preserve at least the most recent undo record.
|
|
279 If the first element is an undo boundary, skip past it. */
|
|
280 if (CONSP (next)
|
|
281 && NILP (XCAR (next)))
|
|
282 {
|
|
283 /* Add in the space occupied by this element and its chain link. */
|
440
|
284 size_so_far += sizeof (Lisp_Cons);
|
428
|
285
|
|
286 /* Advance to next element. */
|
|
287 prev = next;
|
|
288 next = XCDR (next);
|
|
289 }
|
|
290 while (CONSP (next)
|
|
291 && !NILP (XCAR (next)))
|
|
292 {
|
|
293 Lisp_Object elt;
|
|
294 elt = XCAR (next);
|
|
295
|
|
296 /* Add in the space occupied by this element and its chain link. */
|
440
|
297 size_so_far += sizeof (Lisp_Cons);
|
428
|
298 if (CONSP (elt))
|
|
299 {
|
440
|
300 size_so_far += sizeof (Lisp_Cons);
|
428
|
301 if (STRINGP (XCAR (elt)))
|
440
|
302 size_so_far += (sizeof (Lisp_String) - 1
|
428
|
303 + XSTRING_LENGTH (XCAR (elt)));
|
|
304 }
|
|
305
|
|
306 /* Advance to next element. */
|
|
307 prev = next;
|
|
308 next = XCDR (next);
|
|
309 }
|
|
310 if (CONSP (next))
|
|
311 last_boundary = prev;
|
|
312
|
|
313 while (CONSP (next))
|
|
314 {
|
|
315 Lisp_Object elt;
|
|
316 elt = XCAR (next);
|
|
317
|
|
318 /* When we get to a boundary, decide whether to truncate
|
|
319 either before or after it. The lower threshold, MINSIZE,
|
|
320 tells us to truncate after it. If its size pushes past
|
|
321 the higher threshold MAXSIZE as well, we truncate before it. */
|
|
322 if (NILP (elt))
|
|
323 {
|
|
324 if (size_so_far > maxsize && maxsize > 0)
|
|
325 break;
|
|
326 last_boundary = prev;
|
|
327 if (size_so_far > minsize && minsize > 0)
|
|
328 break;
|
|
329 }
|
|
330
|
|
331 /* Add in the space occupied by this element and its chain link. */
|
440
|
332 size_so_far += sizeof (Lisp_Cons);
|
428
|
333 if (CONSP (elt))
|
|
334 {
|
440
|
335 size_so_far += sizeof (Lisp_Cons);
|
428
|
336 if (STRINGP (XCAR (elt)))
|
440
|
337 size_so_far += (sizeof (Lisp_String) - 1
|
428
|
338 + XSTRING_LENGTH (XCAR (elt)));
|
|
339 }
|
|
340
|
|
341 /* Advance to next element. */
|
|
342 prev = next;
|
|
343 next = XCDR (next);
|
|
344 }
|
|
345
|
|
346 /* If we scanned the whole list, it is short enough; don't change it. */
|
|
347 if (NILP (next))
|
|
348 return list;
|
|
349
|
|
350 /* Truncate at the boundary where we decided to truncate. */
|
|
351 if (!NILP (last_boundary))
|
|
352 {
|
|
353 XCDR (last_boundary) = Qnil;
|
|
354 return list;
|
|
355 }
|
|
356 else
|
|
357 return Qnil;
|
|
358 }
|
|
359
|
|
360 DEFUN ("primitive-undo", Fprimitive_undo, 2, 2, 0, /*
|
|
361 Undo COUNT records from the front of the list LIST.
|
|
362 Return what remains of the list.
|
|
363 */
|
|
364 (count, list))
|
|
365 {
|
|
366 struct gcpro gcpro1, gcpro2;
|
|
367 Lisp_Object next = Qnil;
|
|
368 /* This function can GC */
|
|
369 int arg;
|
|
370 int speccount = specpdl_depth ();
|
|
371
|
|
372 record_unwind_protect (restore_inside_undo, make_int (inside_undo));
|
|
373 inside_undo = 1;
|
|
374
|
|
375 #if 0 /* This is a good feature, but would make undo-start
|
|
376 unable to do what is expected. */
|
|
377 Lisp_Object tem;
|
|
378
|
|
379 /* If the head of the list is a boundary, it is the boundary
|
|
380 preceding this command. Get rid of it and don't count it. */
|
|
381 tem = Fcar (list);
|
|
382 if (NILP (tem))
|
|
383 list = Fcdr (list);
|
|
384 #endif
|
|
385
|
|
386 CHECK_INT (count);
|
|
387 arg = XINT (count);
|
|
388 next = Qnil;
|
|
389 GCPRO2 (next, list);
|
|
390
|
|
391 /* Don't let read-only properties interfere with undo. */
|
|
392 if (NILP (current_buffer->read_only))
|
|
393 specbind (Qinhibit_read_only, Qt);
|
|
394
|
|
395 while (arg > 0)
|
|
396 {
|
|
397 while (1)
|
|
398 {
|
|
399 if (NILP (list))
|
|
400 break;
|
|
401 else if (!CONSP (list))
|
|
402 goto rotten;
|
|
403 next = XCAR (list);
|
|
404 list = XCDR (list);
|
|
405 /* Exit inner loop at undo boundary. */
|
|
406 if (NILP (next))
|
|
407 break;
|
|
408 /* Handle an integer by setting point to that value. */
|
|
409 else if (INTP (next))
|
|
410 BUF_SET_PT (current_buffer,
|
|
411 bufpos_clip_to_bounds (BUF_BEGV (current_buffer),
|
|
412 XINT (next),
|
|
413 BUF_ZV (current_buffer)));
|
|
414 else if (CONSP (next))
|
|
415 {
|
|
416 Lisp_Object car = XCAR (next);
|
|
417 Lisp_Object cdr = XCDR (next);
|
|
418
|
|
419 if (EQ (car, Qt))
|
|
420 {
|
|
421 /* Element (t high . low) records previous modtime. */
|
|
422 Lisp_Object high, low;
|
|
423 int mod_time;
|
|
424 if (!CONSP (cdr)) goto rotten;
|
|
425 high = XCAR (cdr);
|
|
426 low = XCDR (cdr);
|
|
427 if (!INTP (high) || !INTP (low)) goto rotten;
|
|
428 mod_time = (XINT (high) << 16) + XINT (low);
|
|
429 /* If this records an obsolete save
|
|
430 (not matching the actual disk file)
|
|
431 then don't mark unmodified. */
|
|
432 if (mod_time != current_buffer->modtime)
|
|
433 break;
|
|
434 #ifdef CLASH_DETECTION
|
|
435 Funlock_buffer ();
|
|
436 #endif /* CLASH_DETECTION */
|
|
437 /* may GC under ENERGIZE: */
|
|
438 Fset_buffer_modified_p (Qnil, Qnil);
|
|
439 }
|
|
440 else if (EXTENTP (car))
|
|
441 {
|
|
442 /* Element (extent start end) means that EXTENT was
|
|
443 detached, and we need to reattach it. */
|
|
444 Lisp_Object extent_obj, start, end;
|
|
445
|
|
446 extent_obj = car;
|
|
447 start = Fcar (cdr);
|
|
448 end = Fcar (Fcdr (cdr));
|
|
449
|
|
450 if (!INTP (start) || !INTP (end))
|
|
451 goto rotten;
|
|
452 Fset_extent_endpoints (extent_obj, start, end,
|
|
453 Fcurrent_buffer ());
|
|
454 }
|
|
455 #if 0 /* FSFmacs */
|
|
456 else if (EQ (car, Qnil))
|
|
457 {
|
|
458 /* Element (nil prop val beg . end) is property change. */
|
|
459 Lisp_Object beg, end, prop, val;
|
|
460
|
|
461 prop = Fcar (cdr);
|
|
462 cdr = Fcdr (cdr);
|
|
463 val = Fcar (cdr);
|
|
464 cdr = Fcdr (cdr);
|
|
465 beg = Fcar (cdr);
|
|
466 end = Fcdr (cdr);
|
|
467
|
|
468 Fput_text_property (beg, end, prop, val, Qnil);
|
|
469 }
|
|
470 #endif /* FSFmacs */
|
|
471 else if (INTP (car) && INTP (cdr))
|
|
472 {
|
|
473 /* Element (BEG . END) means range was inserted. */
|
|
474
|
|
475 if (XINT (car) < BUF_BEGV (current_buffer)
|
|
476 || XINT (cdr) > BUF_ZV (current_buffer))
|
|
477 error ("Changes to be undone are outside visible portion of buffer");
|
|
478 /* Set point first thing, so that undoing this undo
|
|
479 does not send point back to where it is now. */
|
|
480 Fgoto_char (car, Qnil);
|
|
481 Fdelete_region (car, cdr, Qnil);
|
|
482 }
|
|
483 else if (STRINGP (car) && INTP (cdr))
|
|
484 {
|
|
485 /* Element (STRING . POS) means STRING was deleted. */
|
|
486 Lisp_Object membuf = car;
|
|
487 int pos = XINT (cdr);
|
|
488
|
|
489 if (pos < 0)
|
|
490 {
|
|
491 if (-pos < BUF_BEGV (current_buffer) || -pos > BUF_ZV (current_buffer))
|
|
492 error ("Changes to be undone are outside visible portion of buffer");
|
|
493 BUF_SET_PT (current_buffer, -pos);
|
|
494 Finsert (1, &membuf);
|
|
495 }
|
|
496 else
|
|
497 {
|
|
498 if (pos < BUF_BEGV (current_buffer) || pos > BUF_ZV (current_buffer))
|
|
499 error ("Changes to be undone are outside visible portion of buffer");
|
|
500 BUF_SET_PT (current_buffer, pos);
|
|
501
|
|
502 /* Insert before markers so that if the mark is
|
|
503 currently on the boundary of this deletion, it
|
|
504 ends up on the other side of the now-undeleted
|
|
505 text from point. Since undo doesn't even keep
|
|
506 track of the mark, this isn't really necessary,
|
|
507 but it may lead to better behavior in certain
|
|
508 situations.
|
|
509
|
|
510 I'm doubtful that this is safe; you could mess
|
|
511 up the process-output mark in shell buffers, so
|
|
512 until I hear a compelling reason for this change,
|
|
513 I'm leaving it out. -jwz
|
|
514 */
|
|
515 /* Finsert_before_markers (1, &membuf); */
|
|
516 Finsert (1, &membuf);
|
|
517 BUF_SET_PT (current_buffer, pos);
|
|
518 }
|
|
519 }
|
|
520 else
|
|
521 {
|
|
522 goto rotten;
|
|
523 }
|
|
524 }
|
|
525 else if (EXTENTP (next))
|
|
526 Fdetach_extent (next);
|
|
527 else
|
|
528 {
|
|
529 rotten:
|
|
530 signal_simple_continuable_error
|
|
531 ("Something rotten in the state of undo", next);
|
|
532 }
|
|
533 }
|
|
534 arg--;
|
|
535 }
|
|
536
|
|
537 UNGCPRO;
|
|
538 return unbind_to (speccount, list);
|
|
539 }
|
|
540
|
|
541 void
|
|
542 syms_of_undo (void)
|
|
543 {
|
|
544 DEFSUBR (Fprimitive_undo);
|
|
545 DEFSUBR (Fundo_boundary);
|
|
546 defsymbol (&Qinhibit_read_only, "inhibit-read-only");
|
|
547 }
|
|
548
|
|
549 void
|
|
550 reinit_vars_of_undo (void)
|
|
551 {
|
|
552 inside_undo = 0;
|
|
553 }
|
|
554
|
|
555 void
|
|
556 vars_of_undo (void)
|
|
557 {
|
|
558 reinit_vars_of_undo ();
|
|
559
|
|
560 pending_boundary = Qnil;
|
|
561 staticpro (&pending_boundary);
|
|
562 last_undo_buffer = Qnil;
|
|
563 staticpro (&last_undo_buffer);
|
|
564 }
|