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