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