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