Mercurial > hg > xemacs-beta
annotate src/marker.c @ 5117:3742ea8250b5 ben-lisp-object ben-lisp-object-final-ws-year-2005
Checking in final CVS version of workspace 'ben-lisp-object'
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Sat, 26 Dec 2009 00:20:27 -0600 |
parents | facf3239ba30 |
children | e0db3c197671 |
rev | line source |
---|---|
428 | 1 /* Markers: examining, setting and killing. |
2 Copyright (C) 1985, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. | |
800 | 3 Copyright (C) 2002 Ben Wing. |
428 | 4 |
5 This file is part of XEmacs. | |
6 | |
7 XEmacs is free software; you can redistribute it and/or modify it | |
8 under the terms of the GNU General Public License as published by the | |
9 Free Software Foundation; either version 2, or (at your option) any | |
10 later version. | |
11 | |
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
18 along with XEmacs; see the file COPYING. If not, write to | |
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 Boston, MA 02111-1307, USA. */ | |
21 | |
22 /* Synched up with: FSF 19.30. */ | |
23 | |
24 /* This file has been Mule-ized. */ | |
25 | |
26 /* Note that markers are currently kept in an unordered list. | |
27 This means that marker operations may be inefficient if | |
28 there are a bunch of markers in the buffer. This probably | |
29 won't have a significant impact on redisplay (which uses | |
30 markers), but if it does, it wouldn't be too hard to change | |
31 to an ordered gap array. (Just copy the code from extents.c.) | |
32 */ | |
33 | |
34 #include <config.h> | |
35 #include "lisp.h" | |
36 | |
37 #include "buffer.h" | |
38 | |
39 static Lisp_Object | |
40 mark_marker (Lisp_Object obj) | |
41 { | |
440 | 42 Lisp_Marker *marker = XMARKER (obj); |
428 | 43 Lisp_Object buf; |
44 /* DO NOT mark through the marker's chain. | |
45 The buffer's markers chain does not preserve markers from gc; | |
46 Instead, markers are removed from the chain when they are freed | |
47 by gc. | |
48 */ | |
49 if (!marker->buffer) | |
50 return (Qnil); | |
51 | |
793 | 52 buf = wrap_buffer (marker->buffer); |
428 | 53 return (buf); |
54 } | |
55 | |
56 static void | |
2286 | 57 print_marker (Lisp_Object obj, Lisp_Object printcharfun, |
58 int UNUSED (escapeflag)) | |
428 | 59 { |
440 | 60 Lisp_Marker *marker = XMARKER (obj); |
428 | 61 |
62 if (print_readably) | |
563 | 63 printing_unreadable_object ("#<marker 0x%lx>", (long) marker); |
428 | 64 |
826 | 65 write_c_string (printcharfun, GETTEXT ("#<marker ")); |
428 | 66 if (!marker->buffer) |
826 | 67 write_c_string (printcharfun, GETTEXT ("in no buffer")); |
428 | 68 else |
69 { | |
826 | 70 write_fmt_string (printcharfun, "at %ld in ", |
71 (long) marker_position (obj)); | |
428 | 72 print_internal (marker->buffer->name, printcharfun, 0); |
73 } | |
826 | 74 if (marker->insertion_type) |
75 write_c_string (printcharfun, " insertion-type=t"); | |
800 | 76 write_fmt_string (printcharfun, " 0x%lx>", (long) marker); |
428 | 77 } |
78 | |
79 static int | |
2286 | 80 marker_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) |
428 | 81 { |
440 | 82 Lisp_Marker *marker1 = XMARKER (obj1); |
83 Lisp_Marker *marker2 = XMARKER (obj2); | |
428 | 84 |
85 return ((marker1->buffer == marker2->buffer) && | |
665 | 86 (marker1->membpos == marker2->membpos || |
428 | 87 /* All markers pointing nowhere are equal */ |
88 !marker1->buffer)); | |
89 } | |
90 | |
2515 | 91 static Hashcode |
2286 | 92 marker_hash (Lisp_Object obj, int UNUSED (depth)) |
428 | 93 { |
2515 | 94 Hashcode hash = (Hashcode) XMARKER (obj)->buffer; |
428 | 95 if (hash) |
665 | 96 hash = HASH2 (hash, XMARKER (obj)->membpos); |
428 | 97 return hash; |
98 } | |
99 | |
1204 | 100 static const struct memory_description marker_description[] = { |
2551 | 101 { XD_LISP_OBJECT, offsetof (Lisp_Marker, next), 0, { 0 }, XD_FLAG_NO_KKCC }, |
102 { XD_LISP_OBJECT, offsetof (Lisp_Marker, prev), 0, { 0 }, XD_FLAG_NO_KKCC }, | |
440 | 103 { XD_LISP_OBJECT, offsetof (Lisp_Marker, buffer) }, |
428 | 104 { XD_END } |
105 }; | |
106 | |
2720 | 107 #ifdef MC_ALLOC |
108 static void | |
109 finalize_marker (void *header, int for_disksave) | |
110 { | |
111 if (!for_disksave) | |
112 { | |
113 Lisp_Object tem = wrap_marker (header); | |
114 unchain_marker (tem); | |
115 } | |
116 } | |
117 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
118 DEFINE_BASIC_LISP_OBJECT ("marker", marker, |
2720 | 119 mark_marker, print_marker, |
120 finalize_marker, | |
121 marker_equal, marker_hash, | |
122 marker_description, Lisp_Marker); | |
123 #else /* not MC_ALLOC */ | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
124 DEFINE_BASIC_LISP_OBJECT ("marker", marker, |
934 | 125 mark_marker, print_marker, 0, |
1204 | 126 marker_equal, marker_hash, |
127 marker_description, Lisp_Marker); | |
2720 | 128 #endif /* not MC_ALLOC */ |
428 | 129 |
130 /* Operations on markers. */ | |
131 | |
132 DEFUN ("marker-buffer", Fmarker_buffer, 1, 1, 0, /* | |
133 Return the buffer that MARKER points into, or nil if none. | |
134 Return nil if MARKER points into a dead buffer or doesn't point anywhere. | |
135 */ | |
136 (marker)) | |
137 { | |
138 struct buffer *buf; | |
139 CHECK_MARKER (marker); | |
140 /* Return marker's buffer only if it is not dead. */ | |
141 if ((buf = XMARKER (marker)->buffer) && BUFFER_LIVE_P (buf)) | |
142 { | |
793 | 143 return wrap_buffer (buf); |
428 | 144 } |
145 return Qnil; | |
146 } | |
147 | |
148 DEFUN ("marker-position", Fmarker_position, 1, 1, 0, /* | |
149 Return the position MARKER points at, as a character number. | |
150 Return `nil' if marker doesn't point anywhere. | |
151 */ | |
152 (marker)) | |
153 { | |
154 CHECK_MARKER (marker); | |
155 return XMARKER (marker)->buffer ? make_int (marker_position (marker)) : Qnil; | |
156 } | |
157 | |
158 #if 0 /* useful debugging function */ | |
159 | |
160 static void | |
161 check_marker_circularities (struct buffer *buf) | |
162 { | |
440 | 163 Lisp_Marker *tortoise, *hare; |
428 | 164 |
165 tortoise = BUF_MARKERS (buf); | |
166 hare = tortoise; | |
167 | |
168 if (!tortoise) | |
169 return; | |
170 | |
171 while (1) | |
172 { | |
173 assert (hare->buffer == buf); | |
174 hare = hare->next; | |
175 if (!hare) | |
176 return; | |
177 assert (hare->buffer == buf); | |
178 hare = hare->next; | |
179 if (!hare) | |
180 return; | |
181 tortoise = tortoise->next; | |
182 assert (tortoise != hare); | |
183 } | |
184 } | |
185 | |
186 #endif | |
187 | |
188 static Lisp_Object | |
444 | 189 set_marker_internal (Lisp_Object marker, Lisp_Object position, |
190 Lisp_Object buffer, int restricted_p) | |
428 | 191 { |
665 | 192 Charbpos charno; |
428 | 193 struct buffer *b; |
440 | 194 Lisp_Marker *m; |
428 | 195 int point_p; |
196 | |
197 CHECK_MARKER (marker); | |
198 | |
199 point_p = POINT_MARKER_P (marker); | |
200 | |
201 /* If position is nil or a marker that points nowhere, | |
202 make this marker point nowhere. */ | |
444 | 203 if (NILP (position) || |
204 (MARKERP (position) && !XMARKER (position)->buffer)) | |
428 | 205 { |
206 if (point_p) | |
563 | 207 invalid_operation ("Can't make point-marker point nowhere", |
208 marker); | |
428 | 209 if (XMARKER (marker)->buffer) |
210 unchain_marker (marker); | |
211 return marker; | |
212 } | |
213 | |
444 | 214 CHECK_INT_COERCE_MARKER (position); |
428 | 215 if (NILP (buffer)) |
216 b = current_buffer; | |
217 else | |
218 { | |
219 CHECK_BUFFER (buffer); | |
220 b = XBUFFER (buffer); | |
221 /* If buffer is dead, set marker to point nowhere. */ | |
222 if (!BUFFER_LIVE_P (XBUFFER (buffer))) | |
223 { | |
224 if (point_p) | |
563 | 225 invalid_operation |
428 | 226 ("Can't move point-marker in a killed buffer", marker); |
227 if (XMARKER (marker)->buffer) | |
228 unchain_marker (marker); | |
229 return marker; | |
230 } | |
231 } | |
232 | |
444 | 233 charno = XINT (position); |
428 | 234 m = XMARKER (marker); |
235 | |
236 if (restricted_p) | |
237 { | |
238 if (charno < BUF_BEGV (b)) charno = BUF_BEGV (b); | |
239 if (charno > BUF_ZV (b)) charno = BUF_ZV (b); | |
240 } | |
241 else | |
242 { | |
243 if (charno < BUF_BEG (b)) charno = BUF_BEG (b); | |
244 if (charno > BUF_Z (b)) charno = BUF_Z (b); | |
245 } | |
246 | |
247 if (point_p) | |
248 { | |
249 #ifndef moving_point_by_moving_its_marker_is_a_bug | |
250 BUF_SET_PT (b, charno); /* this will move the marker */ | |
251 #else /* It's not a feature, so it must be a bug */ | |
563 | 252 invalid_operation ("DEBUG: attempt to move point via point-marker", |
253 marker); | |
428 | 254 #endif |
255 } | |
256 else | |
257 { | |
665 | 258 m->membpos = charbpos_to_membpos (b, charno); |
428 | 259 } |
260 | |
261 if (m->buffer != b) | |
262 { | |
263 if (point_p) | |
563 | 264 invalid_operation ("Can't change buffer of point-marker", marker); |
428 | 265 if (m->buffer != 0) |
266 unchain_marker (marker); | |
267 m->buffer = b; | |
268 marker_next (m) = BUF_MARKERS (b); | |
269 marker_prev (m) = 0; | |
270 if (BUF_MARKERS (b)) | |
271 marker_prev (BUF_MARKERS (b)) = m; | |
272 BUF_MARKERS (b) = m; | |
273 } | |
274 | |
275 return marker; | |
276 } | |
277 | |
278 | |
279 DEFUN ("set-marker", Fset_marker, 2, 3, 0, /* | |
444 | 280 Move MARKER to position POSITION in BUFFER. |
281 POSITION can be a marker, an integer or nil. If POSITION is an | |
282 integer, make MARKER point before the POSITIONth character in BUFFER. | |
283 If POSITION is nil, makes MARKER point nowhere. Then it no longer | |
284 slows down editing in any buffer. If POSITION is less than 1, move | |
285 MARKER to the beginning of BUFFER. If POSITION is greater than the | |
286 size of BUFFER, move MARKER to the end of BUFFER. | |
428 | 287 BUFFER defaults to the current buffer. |
444 | 288 If this marker was returned by (point-marker t), then changing its |
289 position moves point. You cannot change its buffer or make it point | |
290 nowhere. | |
291 The return value is MARKER. | |
428 | 292 */ |
444 | 293 (marker, position, buffer)) |
428 | 294 { |
444 | 295 return set_marker_internal (marker, position, buffer, 0); |
428 | 296 } |
297 | |
298 | |
299 /* This version of Fset_marker won't let the position | |
300 be outside the visible part. */ | |
301 Lisp_Object | |
444 | 302 set_marker_restricted (Lisp_Object marker, Lisp_Object position, |
303 Lisp_Object buffer) | |
428 | 304 { |
444 | 305 return set_marker_internal (marker, position, buffer, 1); |
428 | 306 } |
307 | |
308 | |
309 /* This is called during garbage collection, | |
310 so we must be careful to ignore and preserve mark bits, | |
311 including those in chain fields of markers. */ | |
312 | |
313 void | |
314 unchain_marker (Lisp_Object m) | |
315 { | |
440 | 316 Lisp_Marker *marker = XMARKER (m); |
428 | 317 struct buffer *b = marker->buffer; |
318 | |
319 if (b == 0) | |
320 return; | |
321 | |
800 | 322 #ifdef ERROR_CHECK_STRUCTURES |
428 | 323 assert (BUFFER_LIVE_P (b)); |
324 #endif | |
325 | |
326 if (marker_next (marker)) | |
327 marker_prev (marker_next (marker)) = marker_prev (marker); | |
328 if (marker_prev (marker)) | |
329 marker_next (marker_prev (marker)) = marker_next (marker); | |
330 else | |
331 BUF_MARKERS (b) = marker_next (marker); | |
332 | |
800 | 333 #ifdef ERROR_CHECK_STRUCTURES |
428 | 334 assert (marker != XMARKER (b->point_marker)); |
335 #endif | |
336 | |
337 marker->buffer = 0; | |
338 } | |
339 | |
665 | 340 Bytebpos |
826 | 341 byte_marker_position (Lisp_Object marker) |
428 | 342 { |
440 | 343 Lisp_Marker *m = XMARKER (marker); |
428 | 344 struct buffer *buf = m->buffer; |
665 | 345 Bytebpos pos; |
428 | 346 |
347 if (!buf) | |
563 | 348 invalid_argument ("Marker does not point anywhere", Qunbound); |
428 | 349 |
350 /* FSF claims that marker indices could end up denormalized, i.e. | |
351 in the gap. This is way bogus if it ever happens, and means | |
352 something fucked up elsewhere. Since I've overhauled all this | |
353 shit, I don't think this can happen. In any case, the following | |
354 macro has an assert() in it that will catch these denormalized | |
355 positions. */ | |
665 | 356 pos = membpos_to_bytebpos (buf, m->membpos); |
428 | 357 |
358 return pos; | |
359 } | |
360 | |
665 | 361 Charbpos |
428 | 362 marker_position (Lisp_Object marker) |
363 { | |
364 struct buffer *buf = XMARKER (marker)->buffer; | |
365 | |
366 if (!buf) | |
563 | 367 invalid_argument ("Marker does not point anywhere", Qunbound); |
428 | 368 |
826 | 369 return bytebpos_to_charbpos (buf, byte_marker_position (marker)); |
428 | 370 } |
371 | |
372 void | |
826 | 373 set_byte_marker_position (Lisp_Object marker, Bytebpos pos) |
428 | 374 { |
440 | 375 Lisp_Marker *m = XMARKER (marker); |
428 | 376 struct buffer *buf = m->buffer; |
377 | |
378 if (!buf) | |
563 | 379 invalid_argument ("Marker does not point anywhere", Qunbound); |
428 | 380 |
665 | 381 m->membpos = bytebpos_to_membpos (buf, pos); |
428 | 382 } |
383 | |
384 void | |
665 | 385 set_marker_position (Lisp_Object marker, Charbpos pos) |
428 | 386 { |
387 struct buffer *buf = XMARKER (marker)->buffer; | |
388 | |
389 if (!buf) | |
563 | 390 invalid_argument ("Marker does not point anywhere", Qunbound); |
428 | 391 |
826 | 392 set_byte_marker_position (marker, charbpos_to_bytebpos (buf, pos)); |
428 | 393 } |
394 | |
395 static Lisp_Object | |
396 copy_marker_1 (Lisp_Object marker, Lisp_Object type, int noseeum) | |
397 { | |
3025 | 398 REGISTER Lisp_Object new_; |
428 | 399 |
400 while (1) | |
401 { | |
402 if (INTP (marker) || MARKERP (marker)) | |
403 { | |
404 if (noseeum) | |
3025 | 405 new_ = noseeum_make_marker (); |
428 | 406 else |
3025 | 407 new_ = Fmake_marker (); |
408 Fset_marker (new_, marker, | |
428 | 409 (MARKERP (marker) ? Fmarker_buffer (marker) : Qnil)); |
3025 | 410 XMARKER (new_)->insertion_type = !NILP (type); |
411 return new_; | |
428 | 412 } |
413 else | |
414 marker = wrong_type_argument (Qinteger_or_marker_p, marker); | |
415 } | |
416 | |
1204 | 417 RETURN_NOT_REACHED (Qnil); /* not reached */ |
428 | 418 } |
419 | |
420 DEFUN ("copy-marker", Fcopy_marker, 1, 2, 0, /* | |
444 | 421 Return a new marker pointing at the same place as MARKER-OR-INTEGER. |
422 If MARKER-OR-INTEGER is an integer, return a new marker pointing | |
428 | 423 at that position in the current buffer. |
444 | 424 Optional argument MARKER-TYPE specifies the insertion type of the new |
425 marker; see `marker-insertion-type'. | |
428 | 426 */ |
444 | 427 (marker_or_integer, marker_type)) |
428 | 428 { |
444 | 429 return copy_marker_1 (marker_or_integer, marker_type, 0); |
428 | 430 } |
431 | |
432 Lisp_Object | |
444 | 433 noseeum_copy_marker (Lisp_Object marker, Lisp_Object marker_type) |
428 | 434 { |
444 | 435 return copy_marker_1 (marker, marker_type, 1); |
428 | 436 } |
437 | |
438 DEFUN ("marker-insertion-type", Fmarker_insertion_type, 1, 1, 0, /* | |
439 Return insertion type of MARKER: t if it stays after inserted text. | |
440 nil means the marker stays before text inserted there. | |
441 */ | |
442 (marker)) | |
443 { | |
444 CHECK_MARKER (marker); | |
445 return XMARKER (marker)->insertion_type ? Qt : Qnil; | |
446 } | |
447 | |
448 DEFUN ("set-marker-insertion-type", Fset_marker_insertion_type, 2, 2, 0, /* | |
449 Set the insertion-type of MARKER to TYPE. | |
450 If TYPE is t, it means the marker advances when you insert text at it. | |
451 If TYPE is nil, it means the marker stays behind when you insert text at it. | |
452 */ | |
453 (marker, type)) | |
454 { | |
455 CHECK_MARKER (marker); | |
456 | |
457 XMARKER (marker)->insertion_type = ! NILP (type); | |
458 return type; | |
459 } | |
460 | |
461 /* #### What is the possible use of this? It looks quite useless to | |
462 me, because there is no way to find *which* markers are positioned | |
463 at POSITION. Additional bogosity bonus: (buffer-has-markers-at | |
464 (point)) will always return t because of the `point-marker'. The | |
465 same goes for the position of mark. Bletch! | |
466 | |
467 Someone should discuss this with Stallman, but I don't have the | |
468 stomach. In fact, this function sucks so badly that I'm disabling | |
469 it by default (although I've debugged it). If you want to use it, | |
470 use extents instead. --hniksic */ | |
471 #if 0 | |
826 | 472 DEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, 1, 1, 0, /* |
428 | 473 Return t if there are markers pointing at POSITION in the current buffer. |
474 */ | |
475 (position)) | |
476 { | |
440 | 477 Lisp_Marker *marker; |
665 | 478 Membpos pos; |
428 | 479 |
665 | 480 /* A small optimization trick: convert POS to membpos now, rather |
481 than converting every marker's memory index to charbpos. */ | |
482 pos = bytebpos_to_membpos (current_buffer, | |
428 | 483 get_buffer_pos_byte (current_buffer, position, |
484 GB_COERCE_RANGE)); | |
485 | |
486 for (marker = BUF_MARKERS (current_buffer); | |
487 marker; | |
488 marker = marker_next (marker)) | |
489 { | |
665 | 490 /* We use marker->membpos, so we don't have to go through the |
428 | 491 unwieldy operation of creating a Lisp_Object for |
492 marker_position() every time around. */ | |
665 | 493 if (marker->membpos == pos) |
428 | 494 return Qt; |
495 } | |
496 | |
497 return Qnil; | |
498 } | |
499 #endif /* 0 */ | |
500 | |
501 #ifdef MEMORY_USAGE_STATS | |
502 | |
503 int | |
504 compute_buffer_marker_usage (struct buffer *b, struct overhead_stats *ovstats) | |
505 { | |
440 | 506 Lisp_Marker *m; |
428 | 507 int total = 0; |
508 int overhead; | |
509 | |
510 for (m = BUF_MARKERS (b); m; m = m->next) | |
440 | 511 total += sizeof (Lisp_Marker); |
428 | 512 ovstats->was_requested += total; |
2720 | 513 #ifdef MC_ALLOC |
514 overhead = mc_alloced_storage_size (total, 0); | |
515 #else /* not MC_ALLOC */ | |
428 | 516 overhead = fixed_type_block_overhead (total); |
2720 | 517 #endif /* not MC_ALLOC */ |
428 | 518 /* #### claiming this is all malloc overhead is not really right, |
519 but it has to go somewhere. */ | |
520 ovstats->malloc_overhead += overhead; | |
521 return total + overhead; | |
522 } | |
523 | |
524 #endif /* MEMORY_USAGE_STATS */ | |
525 | |
526 | |
527 void | |
528 syms_of_marker (void) | |
529 { | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
530 INIT_LISP_OBJECT (marker); |
442 | 531 |
428 | 532 DEFSUBR (Fmarker_position); |
533 DEFSUBR (Fmarker_buffer); | |
534 DEFSUBR (Fset_marker); | |
535 DEFSUBR (Fcopy_marker); | |
536 DEFSUBR (Fmarker_insertion_type); | |
537 DEFSUBR (Fset_marker_insertion_type); | |
538 #if 0 /* FSFmacs crock */ | |
539 DEFSUBR (Fbuffer_has_markers_at); | |
540 #endif | |
541 } | |
542 | |
543 void | |
544 init_buffer_markers (struct buffer *b) | |
545 { | |
793 | 546 Lisp_Object buf = wrap_buffer (b); |
428 | 547 |
548 b->mark = Fmake_marker (); | |
549 BUF_MARKERS (b) = 0; | |
550 b->point_marker = Fmake_marker (); | |
551 Fset_marker (b->point_marker, | |
552 /* For indirect buffers, point is already set. */ | |
553 b->base_buffer ? make_int (BUF_PT (b)) : make_int (1), | |
554 buf); | |
555 } | |
556 | |
557 void | |
558 uninit_buffer_markers (struct buffer *b) | |
559 { | |
560 /* Unchain all markers of this buffer | |
561 and leave them pointing nowhere. */ | |
440 | 562 REGISTER Lisp_Marker *m, *next; |
428 | 563 for (m = BUF_MARKERS (b); m; m = next) |
564 { | |
565 m->buffer = 0; | |
566 next = marker_next (m); | |
567 marker_next (m) = 0; | |
568 marker_prev (m) = 0; | |
569 } | |
570 BUF_MARKERS (b) = 0; | |
571 } |