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