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