(U-0002011D): Use `ideographic-radical@{ucs|cns}' and
[chise/xemacs-chise.git.1] / src / undo.c
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 \f
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 \f
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.  */
284       size_so_far += sizeof (Lisp_Cons);
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.  */
297       size_so_far += sizeof (Lisp_Cons);
298       if (CONSP (elt))
299         {
300           size_so_far += sizeof (Lisp_Cons);
301           if (STRINGP (XCAR (elt)))
302             size_so_far += (sizeof (Lisp_String) - 1
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.  */
332       size_so_far += sizeof (Lisp_Cons);
333       if (CONSP (elt))
334         {
335           size_so_far += sizeof (Lisp_Cons);
336           if (STRINGP (XCAR (elt)))
337             size_so_far += (sizeof (Lisp_String) - 1
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 \f
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 }