update.
[chise/xemacs-chise.git.1] / src / marker.c
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
39 mark_marker (Lisp_Object obj)
40 {
41   Lisp_Marker *marker = XMARKER (obj);
42   Lisp_Object buf;
43   /* DO NOT mark through the marker's chain.
44      The buffer's markers chain does not preserve markers from gc;
45      Instead, markers are removed from the chain when they are freed
46      by gc.
47    */
48   if (!marker->buffer)
49     return (Qnil);
50
51   XSETBUFFER (buf, marker->buffer);
52   return (buf);
53 }
54
55 static void
56 print_marker (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
57 {
58   Lisp_Marker *marker = XMARKER (obj);
59   char buf[200];
60
61   if (print_readably)
62     error ("printing unreadable object #<marker 0x%lx>", (long) marker);
63
64   write_c_string (GETTEXT ("#<marker "), printcharfun);
65   if (!marker->buffer)
66     write_c_string (GETTEXT ("in no buffer"), printcharfun);
67   else
68     {
69       sprintf (buf, "at %ld in ", (long) marker_position (obj));
70       write_c_string (buf, printcharfun);
71       print_internal (marker->buffer->name, printcharfun, 0);
72     }
73   sprintf (buf, " 0x%lx>", (long) marker);
74   write_c_string (buf, printcharfun);
75 }
76
77 static int
78 marker_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
79 {
80   Lisp_Marker *marker1 = XMARKER (obj1);
81   Lisp_Marker *marker2 = XMARKER (obj2);
82
83   return ((marker1->buffer == marker2->buffer) &&
84           (marker1->memind == marker2->memind ||
85           /* All markers pointing nowhere are equal */
86            !marker1->buffer));
87 }
88
89 static unsigned long
90 marker_hash (Lisp_Object obj, int depth)
91 {
92   unsigned long hash = (unsigned long) XMARKER (obj)->buffer;
93   if (hash)
94     hash = HASH2 (hash, XMARKER (obj)->memind);
95   return hash;
96 }
97
98 static const struct lrecord_description marker_description[] = {
99   { XD_LISP_OBJECT, offsetof (Lisp_Marker, next) },
100   { XD_LISP_OBJECT, offsetof (Lisp_Marker, prev) },
101   { XD_LISP_OBJECT, offsetof (Lisp_Marker, buffer) },
102   { XD_END }
103 };
104
105 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("marker", marker,
106                                      mark_marker, print_marker, 0,
107                                      marker_equal, marker_hash, marker_description,
108                                      Lisp_Marker);
109 \f
110 /* Operations on markers. */
111
112 DEFUN ("marker-buffer", Fmarker_buffer, 1, 1, 0, /*
113 Return the buffer that MARKER points into, or nil if none.
114 Return nil if MARKER points into a dead buffer or doesn't point anywhere.
115 */
116        (marker))
117 {
118   struct buffer *buf;
119   CHECK_MARKER (marker);
120   /* Return marker's buffer only if it is not dead.  */
121   if ((buf = XMARKER (marker)->buffer) && BUFFER_LIVE_P (buf))
122     {
123       Lisp_Object buffer;
124       XSETBUFFER (buffer, buf);
125       return buffer;
126     }
127   return Qnil;
128 }
129
130 DEFUN ("marker-position", Fmarker_position, 1, 1, 0, /*
131 Return the position MARKER points at, as a character number.
132 Return `nil' if marker doesn't point anywhere.
133 */
134        (marker))
135 {
136   CHECK_MARKER (marker);
137   return XMARKER (marker)->buffer ? make_int (marker_position (marker)) : Qnil;
138 }
139
140 #if 0 /* useful debugging function */
141
142 static void
143 check_marker_circularities (struct buffer *buf)
144 {
145   Lisp_Marker *tortoise, *hare;
146
147   tortoise = BUF_MARKERS (buf);
148   hare = tortoise;
149
150   if (!tortoise)
151     return;
152
153   while (1)
154     {
155       assert (hare->buffer == buf);
156       hare = hare->next;
157       if (!hare)
158         return;
159       assert (hare->buffer == buf);
160       hare = hare->next;
161       if (!hare)
162         return;
163       tortoise = tortoise->next;
164       assert (tortoise != hare);
165     }
166 }
167
168 #endif
169
170 static Lisp_Object
171 set_marker_internal (Lisp_Object marker, Lisp_Object position,
172                      Lisp_Object buffer, int restricted_p)
173 {
174   Bufpos charno;
175   struct buffer *b;
176   Lisp_Marker *m;
177   int point_p;
178
179   CHECK_MARKER (marker);
180
181   point_p = POINT_MARKER_P (marker);
182
183   /* If position is nil or a marker that points nowhere,
184      make this marker point nowhere.  */
185   if (NILP (position) ||
186       (MARKERP (position) && !XMARKER (position)->buffer))
187     {
188       if (point_p)
189         signal_simple_error ("Can't make point-marker point nowhere",
190                              marker);
191       if (XMARKER (marker)->buffer)
192         unchain_marker (marker);
193       return marker;
194     }
195
196   CHECK_INT_COERCE_MARKER (position);
197   if (NILP (buffer))
198     b = current_buffer;
199   else
200     {
201       CHECK_BUFFER (buffer);
202       b = XBUFFER (buffer);
203       /* If buffer is dead, set marker to point nowhere.  */
204       if (!BUFFER_LIVE_P (XBUFFER (buffer)))
205         {
206           if (point_p)
207             signal_simple_error
208               ("Can't move point-marker in a killed buffer", marker);
209           if (XMARKER (marker)->buffer)
210             unchain_marker (marker);
211           return marker;
212         }
213     }
214
215   charno = XINT (position);
216   m = XMARKER (marker);
217
218   if (restricted_p)
219     {
220       if (charno < BUF_BEGV (b)) charno = BUF_BEGV (b);
221       if (charno > BUF_ZV (b)) charno = BUF_ZV (b);
222     }
223   else
224     {
225       if (charno < BUF_BEG (b)) charno = BUF_BEG (b);
226       if (charno > BUF_Z (b)) charno = BUF_Z (b);
227     }
228
229   if (point_p)
230     {
231 #ifndef moving_point_by_moving_its_marker_is_a_bug
232       BUF_SET_PT (b, charno);   /* this will move the marker */
233 #else  /* It's not a feature, so it must be a bug */
234       signal_simple_error ("DEBUG: attempt to move point via point-marker",
235                            marker);
236 #endif
237     }
238   else
239     {
240       m->memind = bufpos_to_memind (b, charno);
241     }
242
243   if (m->buffer != b)
244     {
245       if (point_p)
246         signal_simple_error ("Can't change buffer of point-marker", marker);
247       if (m->buffer != 0)
248         unchain_marker (marker);
249       m->buffer = b;
250       marker_next (m) = BUF_MARKERS (b);
251       marker_prev (m) = 0;
252       if (BUF_MARKERS (b))
253         marker_prev (BUF_MARKERS (b)) = m;
254       BUF_MARKERS (b) = m;
255     }
256
257   return marker;
258 }
259
260
261 DEFUN ("set-marker", Fset_marker, 2, 3, 0, /*
262 Move MARKER to position POSITION in BUFFER.
263 POSITION can be a marker, an integer or nil.  If POSITION is an
264 integer, make MARKER point before the POSITIONth character in BUFFER.
265 If POSITION is nil, makes MARKER point nowhere.  Then it no longer
266 slows down editing in any buffer.  If POSITION is less than 1, move
267 MARKER to the beginning of BUFFER.  If POSITION is greater than the
268 size of BUFFER, move MARKER to the end of BUFFER.
269 BUFFER defaults to the current buffer.
270 If this marker was returned by (point-marker t), then changing its
271 position moves point.  You cannot change its buffer or make it point
272 nowhere.
273 The return value is MARKER.
274 */
275        (marker, position, buffer))
276 {
277   return set_marker_internal (marker, position, buffer, 0);
278 }
279
280
281 /* This version of Fset_marker won't let the position
282    be outside the visible part.  */
283 Lisp_Object
284 set_marker_restricted (Lisp_Object marker, Lisp_Object position,
285                        Lisp_Object buffer)
286 {
287   return set_marker_internal (marker, position, buffer, 1);
288 }
289
290
291 /* This is called during garbage collection,
292    so we must be careful to ignore and preserve mark bits,
293    including those in chain fields of markers.  */
294
295 void
296 unchain_marker (Lisp_Object m)
297 {
298   Lisp_Marker *marker = XMARKER (m);
299   struct buffer *b = marker->buffer;
300
301   if (b == 0)
302     return;
303
304 #ifdef ERROR_CHECK_GC
305   assert (BUFFER_LIVE_P (b));
306 #endif
307
308   if (marker_next (marker))
309     marker_prev (marker_next (marker)) = marker_prev (marker);
310   if (marker_prev (marker))
311     marker_next (marker_prev (marker)) = marker_next (marker);
312   else
313     BUF_MARKERS (b) = marker_next (marker);
314
315 #ifdef ERROR_CHECK_GC
316   assert (marker != XMARKER (b->point_marker));
317 #endif
318
319   marker->buffer = 0;
320 }
321
322 Bytind
323 bi_marker_position (Lisp_Object marker)
324 {
325   Lisp_Marker *m = XMARKER (marker);
326   struct buffer *buf = m->buffer;
327   Bytind pos;
328
329   if (!buf)
330     error ("Marker does not point anywhere");
331
332   /* FSF claims that marker indices could end up denormalized, i.e.
333      in the gap.  This is way bogus if it ever happens, and means
334      something fucked up elsewhere.  Since I've overhauled all this
335      shit, I don't think this can happen.  In any case, the following
336      macro has an assert() in it that will catch these denormalized
337      positions. */
338   pos = memind_to_bytind (buf, m->memind);
339
340 #ifdef ERROR_CHECK_BUFPOS
341   if (pos < BI_BUF_BEG (buf) || pos > BI_BUF_Z (buf))
342     ABORT ();
343 #endif
344
345   return pos;
346 }
347
348 Bufpos
349 marker_position (Lisp_Object marker)
350 {
351   struct buffer *buf = XMARKER (marker)->buffer;
352
353   if (!buf)
354     error ("Marker does not point anywhere");
355
356   return bytind_to_bufpos (buf, bi_marker_position (marker));
357 }
358
359 void
360 set_bi_marker_position (Lisp_Object marker, Bytind pos)
361 {
362   Lisp_Marker *m = XMARKER (marker);
363   struct buffer *buf = m->buffer;
364
365   if (!buf)
366     error ("Marker does not point anywhere");
367
368 #ifdef ERROR_CHECK_BUFPOS
369   if (pos < BI_BUF_BEG (buf) || pos > BI_BUF_Z (buf))
370     ABORT ();
371 #endif
372
373   m->memind = bytind_to_memind (buf, pos);
374 }
375
376 void
377 set_marker_position (Lisp_Object marker, Bufpos pos)
378 {
379   struct buffer *buf = XMARKER (marker)->buffer;
380
381   if (!buf)
382     error ("Marker does not point anywhere");
383
384   set_bi_marker_position (marker, bufpos_to_bytind (buf, pos));
385 }
386
387 static Lisp_Object
388 copy_marker_1 (Lisp_Object marker, Lisp_Object type, int noseeum)
389 {
390   REGISTER Lisp_Object new;
391
392   while (1)
393     {
394       if (INTP (marker) || MARKERP (marker))
395         {
396           if (noseeum)
397             new = noseeum_make_marker ();
398           else
399             new = Fmake_marker ();
400           Fset_marker (new, marker,
401                        (MARKERP (marker) ? Fmarker_buffer (marker) : Qnil));
402           XMARKER (new)->insertion_type = !NILP (type);
403           return new;
404         }
405       else
406         marker = wrong_type_argument (Qinteger_or_marker_p, marker);
407     }
408
409   RETURN_NOT_REACHED (Qnil) /* not reached */
410 }
411
412 DEFUN ("copy-marker", Fcopy_marker, 1, 2, 0, /*
413 Return a new marker pointing at the same place as MARKER-OR-INTEGER.
414 If MARKER-OR-INTEGER is an integer, return a new marker pointing
415 at that position in the current buffer.
416 Optional argument MARKER-TYPE specifies the insertion type of the new
417 marker; see `marker-insertion-type'.
418 */
419        (marker_or_integer, marker_type))
420 {
421   return copy_marker_1 (marker_or_integer, marker_type, 0);
422 }
423
424 Lisp_Object
425 noseeum_copy_marker (Lisp_Object marker, Lisp_Object marker_type)
426 {
427   return copy_marker_1 (marker, marker_type, 1);
428 }
429
430 DEFUN ("marker-insertion-type", Fmarker_insertion_type, 1, 1, 0, /*
431 Return insertion type of MARKER: t if it stays after inserted text.
432 nil means the marker stays before text inserted there.
433 */
434        (marker))
435 {
436   CHECK_MARKER (marker);
437   return XMARKER (marker)->insertion_type ? Qt : Qnil;
438 }
439
440 DEFUN ("set-marker-insertion-type", Fset_marker_insertion_type, 2, 2, 0, /*
441 Set the insertion-type of MARKER to TYPE.
442 If TYPE is t, it means the marker advances when you insert text at it.
443 If TYPE is nil, it means the marker stays behind when you insert text at it.
444 */
445        (marker, type))
446 {
447   CHECK_MARKER (marker);
448
449   XMARKER (marker)->insertion_type = ! NILP (type);
450   return type;
451 }
452
453 /* #### What is the possible use of this?  It looks quite useless to
454    me, because there is no way to find *which* markers are positioned
455    at POSITION.  Additional bogosity bonus: (buffer-has-markers-at
456    (point)) will always return t because of the `point-marker'.  The
457    same goes for the position of mark.  Bletch!
458
459    Someone should discuss this with Stallman, but I don't have the
460    stomach.  In fact, this function sucks so badly that I'm disabling
461    it by default (although I've debugged it).  If you want to use it,
462    use extents instead.  --hniksic */
463 #if 0
464 xxDEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, 1, 1, 0, /*
465 Return t if there are markers pointing at POSITION in the current buffer.
466 */
467        (position))
468 {
469   Lisp_Marker *marker;
470   Memind pos;
471
472   /* A small optimization trick: convert POS to memind now, rather
473      than converting every marker's memory index to bufpos.  */
474   pos = bytind_to_memind (current_buffer,
475                           get_buffer_pos_byte (current_buffer, position,
476                                                GB_COERCE_RANGE));
477
478   for (marker = BUF_MARKERS (current_buffer);
479        marker;
480        marker = marker_next (marker))
481     {
482       /* We use marker->memind, so we don't have to go through the
483          unwieldy operation of creating a Lisp_Object for
484          marker_position() every time around.  */
485       if (marker->memind == pos)
486         return Qt;
487     }
488
489   return Qnil;
490 }
491 #endif /* 0 */
492
493 #ifdef MEMORY_USAGE_STATS
494
495 int
496 compute_buffer_marker_usage (struct buffer *b, struct overhead_stats *ovstats)
497 {
498   Lisp_Marker *m;
499   int total = 0;
500   int overhead;
501
502   for (m = BUF_MARKERS (b); m; m = m->next)
503     total += sizeof (Lisp_Marker);
504   ovstats->was_requested += total;
505   overhead = fixed_type_block_overhead (total);
506   /* #### claiming this is all malloc overhead is not really right,
507      but it has to go somewhere. */
508   ovstats->malloc_overhead += overhead;
509   return total + overhead;
510 }
511
512 #endif /* MEMORY_USAGE_STATS */
513
514 \f
515 void
516 syms_of_marker (void)
517 {
518   INIT_LRECORD_IMPLEMENTATION (marker);
519
520   DEFSUBR (Fmarker_position);
521   DEFSUBR (Fmarker_buffer);
522   DEFSUBR (Fset_marker);
523   DEFSUBR (Fcopy_marker);
524   DEFSUBR (Fmarker_insertion_type);
525   DEFSUBR (Fset_marker_insertion_type);
526 #if 0 /* FSFmacs crock */
527   DEFSUBR (Fbuffer_has_markers_at);
528 #endif
529 }
530
531 void
532 init_buffer_markers (struct buffer *b)
533 {
534   Lisp_Object buf;
535
536   XSETBUFFER (buf, b);
537   b->mark = Fmake_marker ();
538   BUF_MARKERS (b) = 0;
539   b->point_marker = Fmake_marker ();
540   Fset_marker (b->point_marker,
541                /* For indirect buffers, point is already set.  */
542                b->base_buffer ? make_int (BUF_PT (b)) : make_int (1),
543                buf);
544 }
545
546 void
547 uninit_buffer_markers (struct buffer *b)
548 {
549   /* Unchain all markers of this buffer
550      and leave them pointing nowhere.  */
551   REGISTER Lisp_Marker *m, *next;
552   for (m = BUF_MARKERS (b); m; m = next)
553     {
554       m->buffer = 0;
555       next = marker_next (m);
556       marker_next (m) = 0;
557       marker_prev (m) = 0;
558     }
559   BUF_MARKERS (b) = 0;
560 }