Mercurial > hg > xemacs-beta

comparison src/marker.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Markers: examining, setting and killing.
2 Copyright (C) 1985, 1992, 1993, 1994, 1995 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.30. */
22
23 /* This file has been Mule-ized. */
24
25 /* Note that markers are currently kept in an unordered list.
26 This means that marker operations may be inefficient if
27 there are a bunch of markers in the buffer. This probably
28 won't have a significant impact on redisplay (which uses
29 markers), but if it does, it wouldn't be too hard to change
30 to an ordered gap array. (Just copy the code from extents.c.)
31 */
32
33 #include <config.h>
34 #include "lisp.h"
35
36 #include "buffer.h"
37
38 static Lisp_Object mark_marker (Lisp_Object, void (*) (Lisp_Object));
39 static void print_marker (Lisp_Object, Lisp_Object, int);
40 static int marker_equal (Lisp_Object, Lisp_Object, int);
41 static unsigned long marker_hash (Lisp_Object obj, int depth);
42 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("marker", marker,
43 mark_marker, print_marker, 0,
44 marker_equal, marker_hash,
45 struct Lisp_Marker);
46
47 static Lisp_Object
48 mark_marker (Lisp_Object obj, void (*markobj) (Lisp_Object))
49 {
50 struct Lisp_Marker *marker = XMARKER (obj);
51 Lisp_Object buf;
52 /* DO NOT mark through the marker's chain.
53 The buffer's markers chain does not preserve markers from gc;
54 Instead, markers are removed from the chain when they are freed
55 by gc.
56 */
57 if (!marker->buffer)
58 return (Qnil);
59
60 XSETBUFFER (buf, marker->buffer);
61 return (buf);
62 }
63
64 static void
65 print_marker (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
66 {
67 if (print_readably)
68 error ("printing unreadable object #<marker>");
69
70 write_c_string (GETTEXT ("#<marker "), printcharfun);
71 if (!(XMARKER (obj)->buffer))
72 write_c_string (GETTEXT ("in no buffer"), printcharfun);
73 else
74 {
75 char buf[200];
76 sprintf (buf, "at %d", marker_position (obj));
77 write_c_string (buf, printcharfun);
78 write_c_string (" in ", printcharfun);
79 print_internal (XMARKER (obj)->buffer->name, printcharfun, 0);
80 }
81 write_c_string (">", printcharfun);
82 }
83
84 static int
85 marker_equal (Lisp_Object o1, Lisp_Object o2, int depth)
86 {
87 struct buffer *b1 = XMARKER (o1)->buffer;
88 if (b1 != XMARKER (o2)->buffer)
89 return (0);
90 else if (!b1)
91 /* All markers pointing nowhere are equal */
92 return (1);
93 else
94 return ((XMARKER (o1)->memind == XMARKER (o2)->memind));
95 }
96
97 static unsigned long
98 marker_hash (Lisp_Object obj, int depth)
99 {
100 unsigned long hash = (unsigned long) XMARKER (obj)->buffer;
101 if (hash)
102 hash = HASH2 (hash, XMARKER (obj)->memind);
103 return hash;
104 }
105
106
107 /* Operations on markers. */
108
109 DEFUN ("marker-buffer", Fmarker_buffer, Smarker_buffer, 1, 1, 0 /*
110 Return the buffer that MARKER points into, or nil if none.
111 Returns nil if MARKER points into a dead buffer.
112 */ )
113 (marker)
114 Lisp_Object marker;
115 {
116 Lisp_Object buf;
117 CHECK_MARKER (marker);
118 if (XMARKER (marker)->buffer)
119 {
120 XSETBUFFER (buf, XMARKER (marker)->buffer);
121 /* Return marker's buffer only if it is not dead. */
122 if (BUFFER_LIVE_P (XBUFFER (buf)))
123 return buf;
124 }
125 return Qnil;
126 }
127
128 DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0 /*
129 Return the position MARKER points at, as a character number.
130 Returns `nil' if marker doesn't point anywhere.
131 */ )
132 (marker)
133 Lisp_Object marker;
134 {
135 CHECK_MARKER (marker);
136 if (XMARKER (marker)->buffer)
137 {
138 return (make_int (marker_position (marker)));
139 }
140 return Qnil;
141 }
142
143 #if 0 /* useful debugging function */
144
145 static void
146 check_marker_circularities (struct buffer *buf)
147 {
148 struct Lisp_Marker *tortoise, *hare;
149
150 tortoise = BUF_MARKERS (buf);
151 hare = tortoise;
152
153 if (!tortoise)
154 return;
155
156 while (1)
157 {
158 assert (hare->buffer == buf);
159 hare = hare->next;
160 if (!hare)
161 return;
162 assert (hare->buffer == buf);
163 hare = hare->next;
164 if (!hare)
165 return;
166 tortoise = tortoise->next;
167 assert (tortoise != hare);
168 }
169 }
170
171 #endif
172
173 static Lisp_Object
174 set_marker_internal (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer,
175 int restricted_p)
176 {
177 Bufpos charno;
178 struct buffer *b;
179 struct Lisp_Marker *m;
180 int point_p;
181
182 CHECK_MARKER (marker);
183
184 point_p = POINT_MARKER_P (marker);
185
186 /* If position is nil or a marker that points nowhere,
187 make this marker point nowhere. */
188 if (NILP (pos) ||
189 (MARKERP (pos) && !XMARKER (pos)->buffer))
190 {
191 if (point_p)
192 signal_simple_error ("can't make point-marker point nowhere",
193 marker);
194 if (XMARKER (marker)->buffer)
195 unchain_marker (marker);
196 return marker;
197 }
198
199 CHECK_INT_COERCE_MARKER (pos);
200 if (NILP (buffer))
201 b = current_buffer;
202 else
203 {
204 CHECK_BUFFER (buffer);
205 b = XBUFFER (buffer);
206 /* If buffer is dead, set marker to point nowhere. */
207 if (!BUFFER_LIVE_P (XBUFFER (buffer)))
208 {
209 if (point_p)
210 signal_simple_error
211 ("can't move point-marker in a killed buffer", marker);
212 if (XMARKER (marker)->buffer)
213 unchain_marker (marker);
214 return marker;
215 }
216 }
217
218 charno = XINT (pos);
219 m = XMARKER (marker);
220
221 if (restricted_p)
222 {
223 if (charno < BUF_BEGV (b)) charno = BUF_BEGV (b);
224 if (charno > BUF_ZV (b)) charno = BUF_ZV (b);
225 }
226 else
227 {
228 if (charno < BUF_BEG (b)) charno = BUF_BEG (b);
229 if (charno > BUF_Z (b)) charno = BUF_Z (b);
230 }
231
232 if (point_p)
233 {
234 #ifndef moving_point_by_moving_its_marker_is_a_bug
235 BUF_SET_PT (b, charno); /* this will move the marker */
236 #else /* It's not a feature, so it must be a bug */
237 signal_simple_error ("DEBUG: attempt to move point via point-marker",
238 marker);
239 #endif
240 }
241 else
242 {
243 m->memind = bufpos_to_memind (b, charno);
244 }
245
246 if (m->buffer != b)
247 {
248 if (point_p)
249 signal_simple_error ("can't change buffer of point-marker", marker);
250 if (m->buffer != 0)
251 unchain_marker (marker);
252 m->buffer = b;
253 marker_next (m) = BUF_MARKERS (b);
254 marker_prev (m) = 0;
255 if (BUF_MARKERS (b))
256 marker_prev (BUF_MARKERS (b)) = m;
257 BUF_MARKERS (b) = m;
258 }
259
260 return marker;
261 }
262
263
264 DEFUN ("set-marker", Fset_marker, Sset_marker, 2, 3, 0 /*
265 Position MARKER before character number NUMBER in BUFFER.
266 BUFFER defaults to the current buffer.
267 If NUMBER is nil, makes marker point nowhere.
268 Then it no longer slows down editing in any buffer.
269 If this marker was returned by (point-marker t), then changing its position
270 moves point. You cannot change its buffer or make it point nowhere.
271 Returns MARKER.
272 */ )
273 (marker, number, buffer)
274 Lisp_Object marker, number, buffer;
275 {
276 return set_marker_internal (marker, number, buffer, 0);
277 }
278
279
280 /* This version of Fset_marker won't let the position
281 be outside the visible part. */
282 Lisp_Object
283 set_marker_restricted (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer)
284 {
285 return set_marker_internal (marker, pos, buffer, 1);
286 }
287
288
289 /* This is called during garbage collection,
290 so we must be careful to ignore and preserve mark bits,
291 including those in chain fields of markers. */
292
293 void
294 unchain_marker (Lisp_Object m)
295 {
296 struct Lisp_Marker *marker = XMARKER (m);
297 struct buffer *b = marker->buffer;
298
299 if (b == 0)
300 return;
301
302 assert (BUFFER_LIVE_P (b));
303
304 if (marker_next (marker))
305 marker_prev (marker_next (marker)) = marker_prev (marker);
306 if (marker_prev (marker))
307 marker_next (marker_prev (marker)) = marker_next (marker);
308 else
309 BUF_MARKERS (b) = marker_next (marker);
310
311 assert (marker != XMARKER (b->point_marker));
312
313 marker->buffer = 0;
314 }
315
316 Bytind
317 bi_marker_position (Lisp_Object marker)
318 {
319 struct Lisp_Marker *m = XMARKER (marker);
320 struct buffer *buf = m->buffer;
321 Bytind pos;
322
323 if (!buf)
324 error ("Marker does not point anywhere");
325
326 /* FSF claims that marker indices could end up denormalized, i.e.
327 in the gap. This is way bogus if it ever happens, and means
328 something fucked up elsewhere. Since I've overhauled all this
329 shit, I don't think this can happen. In any case, the following
330 macro has an assert() in it that will catch these denormalized
331 positions. */
332 pos = memind_to_bytind (buf, m->memind);
333
334 if (pos < BI_BUF_BEG (buf) || pos > BI_BUF_Z (buf))
335 abort ();
336
337 return pos;
338 }
339
340 Bufpos
341 marker_position (Lisp_Object marker)
342 {
343 struct buffer *buf = XMARKER (marker)->buffer;
344
345 if (!buf)
346 error ("Marker does not point anywhere");
347
348 return bytind_to_bufpos (buf, bi_marker_position (marker));
349 }
350
351 void
352 set_bi_marker_position (Lisp_Object marker, Bytind pos)
353 {
354 struct Lisp_Marker *m = XMARKER (marker);
355 struct buffer *buf = m->buffer;
356
357 if (!buf)
358 error ("Marker does not point anywhere");
359
360 if (pos < BI_BUF_BEG (buf) || pos > BI_BUF_Z (buf))
361 abort ();
362
363 m->memind = bytind_to_memind (buf, pos);
364 }
365
366 void
367 set_marker_position (Lisp_Object marker, Bufpos pos)
368 {
369 struct buffer *buf = XMARKER (marker)->buffer;
370
371 if (!buf)
372 error ("Marker does not point anywhere");
373
374 set_bi_marker_position (marker, bufpos_to_bytind (buf, pos));
375 }
376
377 static Lisp_Object
378 copy_marker_1 (Lisp_Object marker, Lisp_Object type, int noseeum)
379 {
380 REGISTER Lisp_Object new;
381
382 while (1)
383 {
384 if (INTP (marker) || MARKERP (marker))
385 {
386 if (noseeum)
387 new = noseeum_make_marker ();
388 else
389 new = Fmake_marker ();
390 Fset_marker (new, marker,
391 (MARKERP (marker) ? Fmarker_buffer (marker) : Qnil));
392 XMARKER (new)->insertion_type = !NILP (type);
393 return new;
394 }
395 else
396 marker = wrong_type_argument (Qinteger_or_marker_p, marker);
397 }
398
399 RETURN_NOT_REACHED (Qnil) /* not reached */
400 }
401
402 DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 1, 2, 0 /*
403 Return a new marker pointing at the same place as MARKER.
404 If argument is a number, makes a new marker pointing
405 at that position in the current buffer.
406 The optional argument TYPE specifies the insertion type of the new marker;
407 see `marker-insertion-type'.
408 */ )
409 (marker, type)
410 Lisp_Object marker, type;
411 {
412 return copy_marker_1 (marker, type, 0);
413 }
414
415 Lisp_Object
416 noseeum_copy_marker (Lisp_Object marker, Lisp_Object type)
417 {
418 return copy_marker_1 (marker, type, 1);
419 }
420
421 DEFUN ("marker-insertion-type", Fmarker_insertion_type,
422 Smarker_insertion_type, 1, 1, 0 /*
423 Return insertion type of MARKER: t if it stays after inserted text.
424 nil means the marker stays before text inserted there.
425 */ )
426 (marker)
427 register Lisp_Object marker;
428 {
429 CHECK_MARKER (marker);
430 return XMARKER (marker)->insertion_type ? Qt : Qnil;
431 }
432
433 DEFUN ("set-marker-insertion-type", Fset_marker_insertion_type,
434 Sset_marker_insertion_type, 2, 2, 0 /*
435 Set the insertion-type of MARKER to TYPE.
436 If TYPE is t, it means the marker advances when you insert text at it.
437 If TYPE is nil, it means the marker stays behind when you insert text at it.
438 */ )
439 (marker, type)
440 Lisp_Object marker, type;
441 {
442 CHECK_MARKER (marker);
443
444 XMARKER (marker)->insertion_type = ! NILP (type);
445 return type;
446 }
447
448 #ifdef MEMORY_USAGE_STATS
449
450 int
451 compute_buffer_marker_usage (struct buffer *b, struct overhead_stats *ovstats)
452 {
453 struct Lisp_Marker *m;
454 int total = 0;
455 int overhead;
456
457 for (m = BUF_MARKERS (b); m; m = m->next)
458 total += sizeof (struct Lisp_Marker);
459 ovstats->was_requested += total;
460 overhead = fixed_type_block_overhead (total);
461 /* #### claiming this is all malloc overhead is not really right,
462 but it has to go somewhere. */
463 ovstats->malloc_overhead += overhead;
464 return total + overhead;
465 }
466
467 #endif /* MEMORY_USAGE_STATS */
468
469
470 void
471 syms_of_marker (void)
472 {
473 defsubr (&Smarker_position);
474 defsubr (&Smarker_buffer);
475 defsubr (&Sset_marker);
476 defsubr (&Scopy_marker);
477 defsubr (&Smarker_insertion_type);
478 defsubr (&Sset_marker_insertion_type);
479 }
480
481 void init_buffer_markers (struct buffer *b);
482 void
483 init_buffer_markers (struct buffer *b)
484 {
485 Lisp_Object buf = Qnil;
486
487 XSETBUFFER (buf, b);
488 b->mark = Fmake_marker ();
489 BUF_MARKERS (b) = 0;
490 b->point_marker = Fmake_marker ();
491 Fset_marker (b->point_marker, make_int (1), buf);
492 }
493
494 void uninit_buffer_markers (struct buffer *b);
495 void
496 uninit_buffer_markers (struct buffer *b)
497 {
498 /* Unchain all markers of this buffer
499 and leave them pointing nowhere. */
500 REGISTER struct Lisp_Marker *m, *next;
501 for (m = BUF_MARKERS (b); m; m = next)
502 {
503 m->buffer = 0;
504 next = marker_next (m);
505 marker_next (m) = 0;
506 marker_prev (m) = 0;
507 }
508 BUF_MARKERS (b) = 0;
509 }