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