This is marker.c in view mode; [Download] [Up]
/* Markers: examining, setting and killing.
Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.
This file is part of XEmacs.
XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: FSF 19.28. */
/* This file has been Mule-ized. */
/* Note that markers are currently kept in an unordered list.
This means that marker operations may be inefficient if
there are a bunch of markers in the buffer. This probably
won't have a significant impact on redisplay (which uses
markers), but if it does, it wouldn't be too hard to change
to an ordered gap array. (Just copy the code from extents.c.)
*/
#include <config.h>
#include "lisp.h"
#include "buffer.h"
static Lisp_Object mark_marker (Lisp_Object, void (*) (Lisp_Object));
static void print_marker (Lisp_Object, Lisp_Object, int);
static int marker_equal (Lisp_Object, Lisp_Object, int);
static unsigned long marker_hash (Lisp_Object obj, int depth);
DEFINE_LRECORD_IMPLEMENTATION ("marker", marker,
mark_marker, print_marker, 0, marker_equal,
marker_hash, struct Lisp_Marker);
static Lisp_Object
mark_marker (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct Lisp_Marker *marker = XMARKER (obj);
Lisp_Object buf;
/* DO NOT mark through the marker's chain.
The buffer's markers chain does not preserve markers from gc;
Instead, markers are removed from the chain when they are freed
by gc.
*/
if (!marker->buffer)
return (Qnil);
XSETBUFFER (buf, marker->buffer);
return (buf);
}
static void
print_marker (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
if (print_readably)
error ("printing unreadable object #<marker>");
write_c_string (GETTEXT ("#<marker "), printcharfun);
if (!(XMARKER (obj)->buffer))
write_c_string (GETTEXT ("in no buffer"), printcharfun);
else
{
char buf[200];
sprintf (buf, "at %d", marker_position (obj));
write_c_string (buf, printcharfun);
write_c_string (" in ", printcharfun);
print_internal (XMARKER (obj)->buffer->name, printcharfun, 0);
}
write_c_string (">", printcharfun);
}
static int
marker_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
struct buffer *b1 = XMARKER (o1)->buffer;
if (b1 != XMARKER (o2)->buffer)
return (0);
else if (!b1)
/* All markers pointing nowhere are equal */
return (1);
else
return ((XMARKER (o1)->memind == XMARKER (o2)->memind));
}
static unsigned long
marker_hash (Lisp_Object obj, int depth)
{
unsigned long hash = (unsigned long) XMARKER (obj)->buffer;
if (hash)
hash = HASH2 (hash, XMARKER (obj)->memind);
return hash;
}
/* Operations on markers. */
DEFUN ("marker-buffer", Fmarker_buffer, Smarker_buffer, 1, 1, 0,
"Return the buffer that MARKER points into, or nil if none.\n\
Returns nil if MARKER points into a dead buffer.")
(marker)
Lisp_Object marker;
{
Lisp_Object buf;
CHECK_MARKER (marker, 0);
if (XMARKER (marker)->buffer)
{
XSETBUFFER (buf, XMARKER (marker)->buffer);
/* Return marker's buffer only if it is not dead. */
if (BUFFER_LIVE_P (XBUFFER (buf)))
return buf;
}
return Qnil;
}
DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0,
"Return the position MARKER points at, as a character number.\n\
Returns `nil' if marker doesn't point anywhere.")
(marker)
Lisp_Object marker;
{
CHECK_MARKER (marker, 0);
if (XMARKER (marker)->buffer)
{
return (make_number (marker_position (marker)));
}
return Qnil;
}
static Lisp_Object
set_marker_internal (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer,
int restricted_p)
{
Bufpos charno;
struct buffer *b;
struct Lisp_Marker *m;
int point_p;
CHECK_MARKER (marker, 0);
point_p = POINT_MARKER_P (marker);
/* If position is nil or a marker that points nowhere,
make this marker point nowhere. */
if (NILP (pos) ||
(MARKERP (pos) && !XMARKER (pos)->buffer))
{
if (point_p)
signal_simple_error ("can't make point-marker point nowhere",
marker);
if (XMARKER (marker)->buffer)
unchain_marker (marker);
return marker;
}
CHECK_INT_COERCE_MARKER (pos, 1);
if (NILP (buffer))
b = current_buffer;
else
{
CHECK_BUFFER (buffer, 1);
b = XBUFFER (buffer);
/* If buffer is dead, set marker to point nowhere. */
if (!BUFFER_LIVE_P (XBUFFER (buffer)))
{
if (point_p)
signal_simple_error
("can't move point-marker in a killed buffer", marker);
if (XMARKER (marker)->buffer)
unchain_marker (marker);
return marker;
}
}
charno = XINT (pos);
m = XMARKER (marker);
if (restricted_p)
{
if (charno < BUF_BEGV (b)) charno = BUF_BEGV (b);
if (charno > BUF_ZV (b)) charno = BUF_ZV (b);
}
else
{
if (charno < BUF_BEG (b)) charno = BUF_BEG (b);
if (charno > BUF_Z (b)) charno = BUF_Z (b);
}
if (point_p)
{
#ifdef moving_point_by_moving_its_marker_is_a_feature
BUF_SET_PT (b, charno); /* this will move the marker */
#else /* It's not a feature, so it must be a bug */
signal_simple_error ("DEBUG: attempt to move point via point-marker",
marker);
#endif
}
else
{
m->memind = bufpos_to_memind (b, charno);
}
if (m->buffer != b)
{
if (point_p)
signal_simple_error ("can't change buffer of point-marker", marker);
if (m->buffer != 0)
unchain_marker (marker);
marker_next (m) = b->markers;
b->markers = m;
m->buffer = b;
}
return marker;
}
DEFUN ("set-marker", Fset_marker, Sset_marker, 2, 3, 0,
"Position MARKER before character number NUMBER in BUFFER.\n\
BUFFER defaults to the current buffer.\n\
If NUMBER is nil, makes marker point nowhere.\n\
Then it no longer slows down editing in any buffer.\n\
If this marker was returned by (point-marker t), then changing its position\n\
moves point. You cannot change its buffer or make it point nowhere.\n\
Returns MARKER.")
(marker, pos, buffer)
Lisp_Object marker, pos, buffer;
{
return set_marker_internal (marker, pos, buffer, 0);
}
/* This version of Fset_marker won't let the position
be outside the visible part. */
Lisp_Object
set_marker_restricted (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer)
{
return set_marker_internal (marker, pos, buffer, 1);
}
/* This is called during garbage collection,
so we must be careful to ignore and preserve mark bits,
including those in chain fields of markers. */
void
unchain_marker (Lisp_Object m)
{
struct Lisp_Marker *marker = XMARKER (m);
struct buffer *b = marker->buffer;
struct Lisp_Marker *chain, *prev, *next;
if (b == 0)
return;
if (EQ (b->name, Qnil)) /* killed buffer */
abort ();
for (chain = b->markers, prev = 0; chain; chain = next)
{
next = marker_next (chain);
if (marker == chain)
{
if (!prev)
{
b->markers = next;
/* Deleting first marker from the buffer's chain.
Crash if new first marker in chain does not say
it belongs to this buffer. */
if (next != 0 && b != next->buffer)
abort ();
}
else
{
marker_next (prev) = next;
}
break;
}
else
prev = chain;
}
if (marker == XMARKER (b->point_marker))
abort ();
marker->buffer = 0;
}
Bufpos
marker_position (Lisp_Object marker)
{
struct Lisp_Marker *m = XMARKER (marker);
struct buffer *buf = m->buffer;
Bufpos pos;
if (!buf)
error ("Marker does not point anywhere");
/* FSF claims that marker indices could end up denormalized, i.e.
in the gap. This is way bogus if it ever happens, and means
something fucked up elsewhere. Since I've overhauled all this
shit, I don't think this can happen. In any case, the following
macro has an assert() in it that will catch these denormalized
positions. */
pos = memind_to_bufpos (buf, m->memind);
if (pos < BUF_BEG (buf) || pos > BUF_Z (buf))
abort ();
return pos;
}
void
set_marker_position (Lisp_Object marker, Bufpos pos)
{
struct Lisp_Marker *m = XMARKER (marker);
struct buffer *buf = m->buffer;
if (!buf)
error ("Marker does not point anywhere");
if (pos < BUF_BEG (buf) || pos > BUF_Z (buf))
abort ();
m->memind = bufpos_to_memind (buf, pos);
}
DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 1, 1, 0,
"Return a new marker pointing at the same place as MARKER.\n\
If argument is a number, makes a new marker pointing\n\
at that position in the current buffer.")
(marker)
Lisp_Object marker;
{
Lisp_Object new;
while (1)
{
if (INTP (marker)
|| MARKERP (marker))
{
Lisp_Object buffer = (MARKERP (marker) ? Fmarker_buffer (marker)
: Qnil);
new = Fmake_marker ();
Fset_marker (new, marker, buffer);
return new;
}
else
marker = wrong_type_argument (Qinteger_or_marker_p, marker);
}
}
void
syms_of_marker (void)
{
defsubr (&Smarker_position);
defsubr (&Smarker_buffer);
defsubr (&Sset_marker);
defsubr (&Scopy_marker);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.