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