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 }