git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 }