cgit.sxemacs.org Git - sxemacs/blob - src/undo.c

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