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 pos, Lisp_Object buffer,
 172                      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 (pos) ||
 186       (MARKERP (pos) && !XMARKER (pos)->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 (pos);
 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 (pos);
 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 Position MARKER before character number NUMBER in BUFFER.
 263 BUFFER defaults to the current buffer.
 264 If NUMBER is nil, makes marker point nowhere.
 265 Then it no longer slows down editing in any buffer.
 266 If this marker was returned by (point-marker t), then changing its position
 267 moves point.  You cannot change its buffer or make it point nowhere.
 268 Returns MARKER.
 269 */
 270        (marker, number, buffer))
 271 {
 272   return set_marker_internal (marker, number, buffer, 0);
 273 }
 274
 275
 276 /* This version of Fset_marker won't let the position
 277    be outside the visible part.  */
 278 Lisp_Object
 279 set_marker_restricted (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer)
 280 {
 281   return set_marker_internal (marker, pos, buffer, 1);
 282 }
 283
 284
 285 /* This is called during garbage collection,
 286    so we must be careful to ignore and preserve mark bits,
 287    including those in chain fields of markers.  */
 288
 289 void
 290 unchain_marker (Lisp_Object m)
 291 {
 292   Lisp_Marker *marker = XMARKER (m);
 293   struct buffer *b = marker->buffer;
 294
 295   if (b == 0)
 296     return;
 297
 298 #ifdef ERROR_CHECK_GC
 299   assert (BUFFER_LIVE_P (b));
 300 #endif
 301
 302   if (marker_next (marker))
 303     marker_prev (marker_next (marker)) = marker_prev (marker);
 304   if (marker_prev (marker))
 305     marker_next (marker_prev (marker)) = marker_next (marker);
 306   else
 307     BUF_MARKERS (b) = marker_next (marker);
 308
 309 #ifdef ERROR_CHECK_GC
 310   assert (marker != XMARKER (b->point_marker));
 311 #endif
 312
 313   marker->buffer = 0;
 314 }
 315
 316 Bytind
 317 bi_marker_position (Lisp_Object marker)
 318 {
 319   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 #ifdef ERROR_CHECK_BUFPOS
 335   if (pos < BI_BUF_BEG (buf) || pos > BI_BUF_Z (buf))
 336     abort ();
 337 #endif
 338
 339   return pos;
 340 }
 341
 342 Bufpos
 343 marker_position (Lisp_Object marker)
 344 {
 345   struct buffer *buf = XMARKER (marker)->buffer;
 346
 347   if (!buf)
 348     error ("Marker does not point anywhere");
 349
 350   return bytind_to_bufpos (buf, bi_marker_position (marker));
 351 }
 352
 353 void
 354 set_bi_marker_position (Lisp_Object marker, Bytind pos)
 355 {
 356   Lisp_Marker *m = XMARKER (marker);
 357   struct buffer *buf = m->buffer;
 358
 359   if (!buf)
 360     error ("Marker does not point anywhere");
 361
 362 #ifdef ERROR_CHECK_BUFPOS
 363   if (pos < BI_BUF_BEG (buf) || pos > BI_BUF_Z (buf))
 364     abort ();
 365 #endif
 366
 367   m->memind = bytind_to_memind (buf, pos);
 368 }
 369
 370 void
 371 set_marker_position (Lisp_Object marker, Bufpos pos)
 372 {
 373   struct buffer *buf = XMARKER (marker)->buffer;
 374
 375   if (!buf)
 376     error ("Marker does not point anywhere");
 377
 378   set_bi_marker_position (marker, bufpos_to_bytind (buf, pos));
 379 }
 380
 381 static Lisp_Object
 382 copy_marker_1 (Lisp_Object marker, Lisp_Object type, int noseeum)
 383 {
 384   REGISTER Lisp_Object new;
 385
 386   while (1)
 387     {
 388       if (INTP (marker) || MARKERP (marker))
 389         {
 390           if (noseeum)
 391             new = noseeum_make_marker ();
 392           else
 393             new = Fmake_marker ();
 394           Fset_marker (new, marker,
 395                        (MARKERP (marker) ? Fmarker_buffer (marker) : Qnil));
 396           XMARKER (new)->insertion_type = !NILP (type);
 397           return new;
 398         }
 399       else
 400         marker = wrong_type_argument (Qinteger_or_marker_p, marker);
 401     }
 402
 403   RETURN_NOT_REACHED (Qnil) /* not reached */
 404 }
 405
 406 DEFUN ("copy-marker", Fcopy_marker, 1, 2, 0, /*
 407 Return a new marker pointing at the same place as MARKER.
 408 If argument is a number, makes a new marker pointing
 409 at that position in the current buffer.
 410 The optional argument TYPE specifies the insertion type of the new marker;
 411 see `marker-insertion-type'.
 412 */
 413        (marker, type))
 414 {
 415   return copy_marker_1 (marker, type, 0);
 416 }
 417
 418 Lisp_Object
 419 noseeum_copy_marker (Lisp_Object marker, Lisp_Object type)
 420 {
 421   return copy_marker_1 (marker, type, 1);
 422 }
 423
 424 DEFUN ("marker-insertion-type", Fmarker_insertion_type, 1, 1, 0, /*
 425 Return insertion type of MARKER: t if it stays after inserted text.
 426 nil means the marker stays before text inserted there.
 427 */
 428        (marker))
 429 {
 430   CHECK_MARKER (marker);
 431   return XMARKER (marker)->insertion_type ? Qt : Qnil;
 432 }
 433
 434 DEFUN ("set-marker-insertion-type", Fset_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 {
 441   CHECK_MARKER (marker);
 442
 443   XMARKER (marker)->insertion_type = ! NILP (type);
 444   return type;
 445 }
 446
 447 /* #### What is the possible use of this?  It looks quite useless to
 448    me, because there is no way to find *which* markers are positioned
 449    at POSITION.  Additional bogosity bonus: (buffer-has-markers-at
 450    (point)) will always return t because of the `point-marker'.  The
 451    same goes for the position of mark.  Bletch!
 452
 453    Someone should discuss this with Stallman, but I don't have the
 454    stomach.  In fact, this function sucks so badly that I'm disabling
 455    it by default (although I've debugged it).  If you want to use it,
 456    use extents instead.  --hniksic */
 457 #if 0
 458 xxDEFUN ("buffer-has-markers-at", Fbuffer_has_markers_at, 1, 1, 0, /*
 459 Return t if there are markers pointing at POSITION in the current buffer.
 460 */
 461        (position))
 462 {
 463   Lisp_Marker *marker;
 464   Memind pos;
 465
 466   /* A small optimization trick: convert POS to memind now, rather
 467      than converting every marker's memory index to bufpos.  */
 468   pos = bytind_to_memind (current_buffer,
 469                           get_buffer_pos_byte (current_buffer, position,
 470                                                GB_COERCE_RANGE));
 471
 472   for (marker = BUF_MARKERS (current_buffer);
 473        marker;
 474        marker = marker_next (marker))
 475     {
 476       /* We use marker->memind, so we don't have to go through the
 477          unwieldy operation of creating a Lisp_Object for
 478          marker_position() every time around.  */
 479       if (marker->memind == pos)
 480         return Qt;
 481     }
 482
 483   return Qnil;
 484 }
 485 #endif /* 0 */
 486
 487 #ifdef MEMORY_USAGE_STATS
 488
 489 int
 490 compute_buffer_marker_usage (struct buffer *b, struct overhead_stats *ovstats)
 491 {
 492   Lisp_Marker *m;
 493   int total = 0;
 494   int overhead;
 495
 496   for (m = BUF_MARKERS (b); m; m = m->next)
 497     total += sizeof (Lisp_Marker);
 498   ovstats->was_requested += total;
 499   overhead = fixed_type_block_overhead (total);
 500   /* #### claiming this is all malloc overhead is not really right,
 501      but it has to go somewhere. */
 502   ovstats->malloc_overhead += overhead;
 503   return total + overhead;
 504 }
 505
 506 #endif /* MEMORY_USAGE_STATS */
 507
 508 \f
 509 void
 510 syms_of_marker (void)
 511 {
 512   INIT_LRECORD_IMPLEMENTATION (marker);
 513
 514   DEFSUBR (Fmarker_position);
 515   DEFSUBR (Fmarker_buffer);
 516   DEFSUBR (Fset_marker);
 517   DEFSUBR (Fcopy_marker);
 518   DEFSUBR (Fmarker_insertion_type);
 519   DEFSUBR (Fset_marker_insertion_type);
 520 #if 0 /* FSFmacs crock */
 521   DEFSUBR (Fbuffer_has_markers_at);
 522 #endif
 523 }
 524
 525 void
 526 init_buffer_markers (struct buffer *b)
 527 {
 528   Lisp_Object buf;
 529
 530   XSETBUFFER (buf, b);
 531   b->mark = Fmake_marker ();
 532   BUF_MARKERS (b) = 0;
 533   b->point_marker = Fmake_marker ();
 534   Fset_marker (b->point_marker,
 535                /* For indirect buffers, point is already set.  */
 536                b->base_buffer ? make_int (BUF_PT (b)) : make_int (1),
 537                buf);
 538 }
 539
 540 void
 541 uninit_buffer_markers (struct buffer *b)
 542 {
 543   /* Unchain all markers of this buffer
 544      and leave them pointing nowhere.  */
 545   REGISTER Lisp_Marker *m, *next;
 546   for (m = BUF_MARKERS (b); m; m = next)
 547     {
 548       m->buffer = 0;
 549       next = marker_next (m);
 550       marker_next (m) = 0;
 551       marker_prev (m) = 0;
 552     }
 553   BUF_MARKERS (b) = 0;
 554 }