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