src/undo.c

   1 /* undo handling for GNU Emacs.
   2    Copyright (C) 1990, 1993 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is distributed in the hope that it will be useful,
   7 but WITHOUT ANY WARRANTY.  No author or distributor
   8 accepts responsibility to anyone for the consequences of using it
   9 or for whether it serves any particular purpose or works at all,
  10 unless he says so in writing.  Refer to the GNU Emacs General Public
  11 License for full details.
  12
  13 Everyone is granted permission to copy, modify and redistribute
  14 GNU Emacs, but only under the conditions described in the
  15 GNU Emacs General Public License.   A copy of this license is
  16 supposed to have been given to you along with GNU Emacs so you
  17 can know your rights and responsibilities.  It should be in a
  18 file named COPYING.  Among other things, the copyright notice
  19 and this notice must be preserved on all copies.  */
  20
  21
  22 #include <config.h>
  23 #include "lisp.h"
  24 #include "buffer.h"
  25
  26 /* Last buffer for which undo information was recorded.  */
  27 Lisp_Object last_undo_buffer;
  28
  29 Lisp_Object Qinhibit_read_only;
  30
  31 /* Record an insertion that just happened or is about to happen,
  32    for LENGTH characters at position BEG.
  33    (It is possible to record an insertion before or after the fact
  34    because we don't need to record the contents.)  */
  35
  36 record_insert (beg, length)
  37      Lisp_Object beg, length;
  38 {
  39   Lisp_Object lbeg, lend;
  40
  41   if (EQ (current_buffer->undo_list, Qt))
  42     return;
  43
  44   if (current_buffer != XBUFFER (last_undo_buffer))
  45     Fundo_boundary ();
  46   XSET (last_undo_buffer, Lisp_Buffer, current_buffer);
  47
  48   if (MODIFF <= current_buffer->save_modified)
  49     record_first_change ();
  50
  51   /* If this is following another insertion and consecutive with it
  52      in the buffer, combine the two.  */
  53   if (XTYPE (current_buffer->undo_list) == Lisp_Cons)
  54     {
  55       Lisp_Object elt;
  56       elt = XCONS (current_buffer->undo_list)->car;
  57       if (XTYPE (elt) == Lisp_Cons
  58           && XTYPE (XCONS (elt)->car) == Lisp_Int
  59           && XTYPE (XCONS (elt)->cdr) == Lisp_Int
  60           && XINT (XCONS (elt)->cdr) == XINT (beg))
  61         {
  62           XSETINT (XCONS (elt)->cdr, XINT (beg) + XINT (length));
  63           return;
  64         }
  65     }
  66
  67   lbeg = beg;
  68   XSET (lend, Lisp_Int, XINT (beg) + XINT (length));
  69   current_buffer->undo_list = Fcons (Fcons (lbeg, lend),
  70                                      current_buffer->undo_list);
  71 }
  72
  73 /* Record that a deletion is about to take place,
  74    for LENGTH characters at location BEG.  */
  75
  76 record_delete (beg, length)
  77      int beg, length;
  78 {
  79   Lisp_Object lbeg, lend, sbeg;
  80
  81   if (EQ (current_buffer->undo_list, Qt))
  82     return;
  83
  84   if (current_buffer != XBUFFER (last_undo_buffer))
  85     Fundo_boundary ();
  86   XSET (last_undo_buffer, Lisp_Buffer, current_buffer);
  87
  88   if (MODIFF <= current_buffer->save_modified)
  89     record_first_change ();
  90
  91   if (point == beg + length)
  92     XSET (sbeg, Lisp_Int, -beg);
  93   else
  94     XFASTINT (sbeg) = beg;
  95   XFASTINT (lbeg) = beg;
  96   XFASTINT (lend) = beg + length;
  97
  98   /* If point isn't at start of deleted range, record where it is.  */
  99   if (PT != XFASTINT (sbeg))
 100     current_buffer->undo_list
 101       = Fcons (make_number (PT), current_buffer->undo_list);
 102
 103   current_buffer->undo_list
 104     = Fcons (Fcons (Fbuffer_substring (lbeg, lend), sbeg),
 105              current_buffer->undo_list);
 106 }
 107
 108 /* Record that a replacement is about to take place,
 109    for LENGTH characters at location BEG.
 110    The replacement does not change the number of characters.  */
 111
 112 record_change (beg, length)
 113      int beg, length;
 114 {
 115   record_delete (beg, length);
 116   record_insert (beg, length);
 117 }
 118 \f
 119 /* Record that an unmodified buffer is about to be changed.
 120    Record the file modification date so that when undoing this entry
 121    we can tell whether it is obsolete because the file was saved again.  */
 122
 123 record_first_change ()
 124 {
 125   Lisp_Object high, low;
 126
 127   if (EQ (current_buffer->undo_list, Qt))
 128     return;
 129
 130   if (current_buffer != XBUFFER (last_undo_buffer))
 131     Fundo_boundary ();
 132   XSET (last_undo_buffer, Lisp_Buffer, current_buffer);
 133
 134   XFASTINT (high) = (current_buffer->modtime >> 16) & 0xffff;
 135   XFASTINT (low) = current_buffer->modtime & 0xffff;
 136   current_buffer->undo_list = Fcons (Fcons (Qt, Fcons (high, low)), current_buffer->undo_list);
 137 }
 138
 139 /* Record a change in property PROP (whose old value was VAL)
 140    for LENGTH characters starting at position BEG in BUFFER.  */
 141
 142 record_property_change (beg, length, prop, value, buffer)
 143      int beg, length;
 144      Lisp_Object prop, value, buffer;
 145 {
 146   Lisp_Object lbeg, lend, entry;
 147   struct buffer *obuf = current_buffer;
 148   int boundary = 0;
 149
 150   if (EQ (XBUFFER (buffer)->undo_list, Qt))
 151     return;
 152
 153   if (!EQ (buffer, last_undo_buffer))
 154     boundary = 1;
 155   last_undo_buffer = buffer;
 156
 157   /* Switch temporarily to the buffer that was changed.  */
 158   current_buffer = XBUFFER (buffer);
 159
 160   if (boundary)
 161     Fundo_boundary ();
 162
 163   if (MODIFF <= current_buffer->save_modified)
 164     record_first_change ();
 165
 166   XSET (lbeg, Lisp_Int, beg);
 167   XSET (lend, Lisp_Int, beg + length);
 168   entry = Fcons (Qnil, Fcons (prop, Fcons (value, Fcons (lbeg, lend))));
 169   current_buffer->undo_list = Fcons (entry, current_buffer->undo_list);
 170
 171   current_buffer = obuf;
 172 }
 173
 174 DEFUN ("undo-boundary", Fundo_boundary, Sundo_boundary, 0, 0, 0,
 175   "Mark a boundary between units of undo.\n\
 176 An undo command will stop at this point,\n\
 177 but another undo command will undo to the previous boundary.")
 178   ()
 179 {
 180   Lisp_Object tem;
 181   if (EQ (current_buffer->undo_list, Qt))
 182     return Qnil;
 183   tem = Fcar (current_buffer->undo_list);
 184   if (!NILP (tem))
 185     current_buffer->undo_list = Fcons (Qnil, current_buffer->undo_list);
 186   return Qnil;
 187 }
 188
 189 /* At garbage collection time, make an undo list shorter at the end,
 190    returning the truncated list.
 191    MINSIZE and MAXSIZE are the limits on size allowed, as described below.
 192    In practice, these are the values of undo-limit and
 193    undo-strong-limit.  */
 194
 195 Lisp_Object
 196 truncate_undo_list (list, minsize, maxsize)
 197      Lisp_Object list;
 198      int minsize, maxsize;
 199 {
 200   Lisp_Object prev, next, last_boundary;
 201   int size_so_far = 0;
 202
 203   prev = Qnil;
 204   next = list;
 205   last_boundary = Qnil;
 206
 207   /* Always preserve at least the most recent undo record.
 208      If the first element is an undo boundary, skip past it.
 209
 210      Skip, skip, skip the undo, skip, skip, skip the undo,
 211      Skip, skip, skip the undo, skip to the undo bound'ry.
 212      (Get it?  "Skip to my Loo?")  */
 213   if (XTYPE (next) == Lisp_Cons
 214       && NILP (XCONS (next)->car))
 215     {
 216       /* Add in the space occupied by this element and its chain link.  */
 217       size_so_far += sizeof (struct Lisp_Cons);
 218
 219       /* Advance to next element.  */
 220       prev = next;
 221       next = XCONS (next)->cdr;
 222     }
 223   while (XTYPE (next) == Lisp_Cons
 224          && ! NILP (XCONS (next)->car))
 225     {
 226       Lisp_Object elt;
 227       elt = XCONS (next)->car;
 228
 229       /* Add in the space occupied by this element and its chain link.  */
 230       size_so_far += sizeof (struct Lisp_Cons);
 231       if (XTYPE (elt) == Lisp_Cons)
 232         {
 233           size_so_far += sizeof (struct Lisp_Cons);
 234           if (XTYPE (XCONS (elt)->car) == Lisp_String)
 235             size_so_far += (sizeof (struct Lisp_String) - 1
 236                             + XSTRING (XCONS (elt)->car)->size);
 237         }
 238
 239       /* Advance to next element.  */
 240       prev = next;
 241       next = XCONS (next)->cdr;
 242     }
 243   if (XTYPE (next) == Lisp_Cons)
 244     last_boundary = prev;
 245
 246   while (XTYPE (next) == Lisp_Cons)
 247     {
 248       Lisp_Object elt;
 249       elt = XCONS (next)->car;
 250
 251       /* When we get to a boundary, decide whether to truncate
 252          either before or after it.  The lower threshold, MINSIZE,
 253          tells us to truncate after it.  If its size pushes past
 254          the higher threshold MAXSIZE as well, we truncate before it.  */
 255       if (NILP (elt))
 256         {
 257           if (size_so_far > maxsize)
 258             break;
 259           last_boundary = prev;
 260           if (size_so_far > minsize)
 261             break;
 262         }
 263
 264       /* Add in the space occupied by this element and its chain link.  */
 265       size_so_far += sizeof (struct Lisp_Cons);
 266       if (XTYPE (elt) == Lisp_Cons)
 267         {
 268           size_so_far += sizeof (struct Lisp_Cons);
 269           if (XTYPE (XCONS (elt)->car) == Lisp_String)
 270             size_so_far += (sizeof (struct Lisp_String) - 1
 271                             + XSTRING (XCONS (elt)->car)->size);
 272         }
 273
 274       /* Advance to next element.  */
 275       prev = next;
 276       next = XCONS (next)->cdr;
 277     }
 278
 279   /* If we scanned the whole list, it is short enough; don't change it.  */
 280   if (NILP (next))
 281     return list;
 282
 283   /* Truncate at the boundary where we decided to truncate.  */
 284   if (!NILP (last_boundary))
 285     {
 286       XCONS (last_boundary)->cdr = Qnil;
 287       return list;
 288     }
 289   else
 290     return Qnil;
 291 }
 292 \f
 293 DEFUN ("primitive-undo", Fprimitive_undo, Sprimitive_undo, 2, 2, 0,
 294   "Undo N records from the front of the list LIST.\n\
 295 Return what remains of the list.")
 296   (n, list)
 297      Lisp_Object n, list;
 298 {
 299   int count = specpdl_ptr - specpdl;
 300   register int arg = XINT (n);
 301 #if 0  /* This is a good feature, but would make undo-start
 302           unable to do what is expected.  */
 303   Lisp_Object tem;
 304
 305   /* If the head of the list is a boundary, it is the boundary
 306      preceding this command.  Get rid of it and don't count it.  */
 307   tem = Fcar (list);
 308   if (NILP (tem))
 309     list = Fcdr (list);
 310 #endif
 311
 312   /* Don't let read-only properties interfere with undo.  */
 313   if (NILP (current_buffer->read_only))
 314     specbind (Qinhibit_read_only, Qt);
 315
 316   while (arg > 0)
 317     {
 318       while (1)
 319         {
 320           Lisp_Object next;
 321           next = Fcar (list);
 322           list = Fcdr (list);
 323           /* Exit inner loop at undo boundary.  */
 324           if (NILP (next))
 325             break;
 326           /* Handle an integer by setting point to that value.  */
 327           if (XTYPE (next) == Lisp_Int)
 328             SET_PT (clip_to_bounds (BEGV, XINT (next), ZV));
 329           else if (XTYPE (next) == Lisp_Cons)
 330             {
 331               Lisp_Object car, cdr;
 332
 333               car = Fcar (next);
 334               cdr = Fcdr (next);
 335               if (EQ (car, Qt))
 336                 {
 337                   /* Element (t high . low) records previous modtime.  */
 338                   Lisp_Object high, low;
 339                   int mod_time;
 340
 341                   high = Fcar (cdr);
 342                   low = Fcdr (cdr);
 343                   mod_time = (XFASTINT (high) << 16) + XFASTINT (low);
 344                   /* If this records an obsolete save
 345                      (not matching the actual disk file)
 346                      then don't mark unmodified.  */
 347                   if (mod_time != current_buffer->modtime)
 348                     break;
 349 #ifdef CLASH_DETECTION
 350                   Funlock_buffer ();
 351 #endif /* CLASH_DETECTION */
 352                   Fset_buffer_modified_p (Qnil);
 353                 }
 354 #ifdef USE_TEXT_PROPERTIES
 355               else if (EQ (car, Qnil))
 356                 {
 357                   /* Element (nil prop val beg . end) is property change.  */
 358                   Lisp_Object beg, end, prop, val;
 359
 360                   prop = Fcar (cdr);
 361                   cdr = Fcdr (cdr);
 362                   val = Fcar (cdr);
 363                   cdr = Fcdr (cdr);
 364                   beg = Fcar (cdr);
 365                   end = Fcdr (cdr);
 366
 367                   Fput_text_property (beg, end, prop, val, Qnil);
 368                 }
 369 #endif /* USE_TEXT_PROPERTIES */
 370               else if (XTYPE (car) == Lisp_Int && XTYPE (cdr) == Lisp_Int)
 371                 {
 372                   /* Element (BEG . END) means range was inserted.  */
 373                   Lisp_Object end;
 374
 375                   if (XINT (car) < BEGV
 376                       || XINT (cdr) > ZV)
 377                     error ("Changes to be undone are outside visible portion of buffer");
 378                   /* Set point first thing, so that undoing this undo
 379                      does not send point back to where it is now.  */
 380                   Fgoto_char (car);
 381                   Fdelete_region (car, cdr);
 382                 }
 383               else if (XTYPE (car) == Lisp_String && XTYPE (cdr) == Lisp_Int)
 384                 {
 385                   /* Element (STRING . POS) means STRING was deleted.  */
 386                   Lisp_Object membuf;
 387                   int pos = XINT (cdr);
 388
 389                   membuf = car;
 390                   if (pos < 0)
 391                     {
 392                       if (-pos < BEGV || -pos > ZV)
 393                         error ("Changes to be undone are outside visible portion of buffer");
 394                       SET_PT (-pos);
 395                       Finsert (1, &membuf);
 396                     }
 397                   else
 398                     {
 399                       if (pos < BEGV || pos > ZV)
 400                         error ("Changes to be undone are outside visible portion of buffer");
 401                       SET_PT (pos);
 402
 403                       /* Insert before markers so that if the mark is
 404                          currently on the boundary of this deletion, it
 405                          ends up on the other side of the now-undeleted
 406                          text from point.  Since undo doesn't even keep
 407                          track of the mark, this isn't really necessary,
 408                          but it may lead to better behavior in certain
 409                          situations.  */
 410                       Finsert_before_markers (1, &membuf);
 411                       SET_PT (pos);
 412                     }
 413                 }
 414             }
 415         }
 416       arg--;
 417     }
 418
 419   return unbind_to (count, list);
 420 }
 421
 422 syms_of_undo ()
 423 {
 424   Qinhibit_read_only = intern ("inhibit-read-only");
 425   staticpro (&Qinhibit_read_only);
 426
 427   defsubr (&Sprimitive_undo);
 428   defsubr (&Sundo_boundary);
 429 }