This is extents.c in view mode; [Download] [Up]
/* Copyright (c) 1994, 1995 Amdahl Corporation.
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: Not in FSF. */
/* This file has been Mule-ized with the exception of the extent-replica
stuff. */
/* Originally written by some people at Lucid.
Hacked on by jwz.
Start/end-open stuff added by John Rose (john.rose@eng.sun.com).
Rewritten from scratch by Ben Wing <wing@netcom.com>, December 1994. */
/* #### To do:
Fix map-extent-children?
*/
/* Commentary:
Extents are regions over a buffer, with a start and an end position
denoting the region of the buffer included in the extent. In
addition, either end can be closed or open, meaning that the endpoint
is or is not logically included in the extent. Insertion of a character
at a closed endpoint causes the character to go inside the extent;
insertion at an open endpoint causes the character to go outside.
Extent endpoints are stored using memory indices (see insdel.c),
to minimize the amount of adjusting that needs to be done when
characters are inserted or deleted.
(Formerly, extent endpoints at the gap could be either before or
after the gap, depending on the open/closedness of the endpoint.
The intent of this was to make it so that insertions would
automatically go inside or out of extents as necessary with no
further work needing to be done. It didn't work out that way,
however, and just ended up complexifying and buggifying all the
rest of the code.)
Extent replica endpoints are stored using buffer positions, although
byte indices would perhaps be more efficient. This is because
extent replica objects can be copied from one string to another and
don't contain a pointer to the string they refer to; it also
avoids having to do endpoint adjustment on them, because characters
can never be inserted into or deleted from a string (but can be
changed using `aset' or `fillarray', which might change the byte
indices).
#### Extent replicas should be rethunk. I think they're a piece
of shit and ought to be nuked -- instead, extents should just be able
to exist over strings just like over buffers. Jamie, who (I think)
implemented extent replicas in the first place, is understandably
reluctant to see them go, but so far he hasn't brought up any
compelling reasons why they need to say. (ben)
Extents are compared using memory indices. There are two orderings
for extents and both orders are kept current at all times. The normal
or "display" order is as follows:
Extent A is "less than" extent B, that is, earlier in the display order,
if: A-start < B-start,
or if: A-start = B-start, and A-end > B-end
So if two extents begin at the same position, the larger of them is the
earlier one in the display order (EXTENT_LESS is true).
For the e-order, the same thing holds: Extent A is "less than" extent B
in e-order, that is, later in the buffer,
if: A-end < B-end,
or if: A-end = B-end, and A-start > B-start
So if two extents end at the same position, the smaller of them is the
earlier one in the e-order (EXTENT_E_LESS is true).
The display order and the e-order are complementary orders: any
theorem about the display order also applies to the e-order if you
swap all occurrences of "display order" and "e-order", "less than"
and "greater than", and "extent start" and "extent end".
Extents can be zero-length, and will end up that way if their endpoints
are explicitly set that way or if their detachable property is nil
and all the text in the extent is deleted. (The exception is open-open
zero-length extents, which are barred from existing because there is
no sensible way to define their properties. Deletion of the text in
an open-open extent causes it to be converted into a closed-open
extent.) Zero-length extents are primarily used to represent
annotations, and behave as follows:
1) Insertion at the position of a zero-length extent expands the extent
if both endpoints are closed; goes after the extent if it is closed-open;
and goes before the extent if it is open-closed.
2) Deletion of a character on a side of a zero-length extent whose
corresponding endpoint is closed causes the extent to be detached if
it is detachable; if the extent is not detachable or the corresponding
endpoint is open, the extent remains in the buffer, moving as necessary.
Note that closed-open, non-detachable zero-length extents behave exactly
like markers and that open-closed, non-detachable zero-length extents
behave like the "point-type" marker in Mule.
#### The following information is wrong in places.
More about the different orders:
--------------------------------
The extents in a buffer are ordered by "display order" because that
is that order that the redisplay mechanism needs to process them in.
The e-order is an auxiliary ordering used to facilitate operations
over extents. The operations that can be performed on the ordered
list of extents in a buffer are
1) Locate where an extent would go if inserted into the list.
2) Insert an extent into the list.
3) Remove an extent from the list.
4) Map over all the extents that overlap a range.
(4) requires being able to determine the first and last extents
that overlap a range.
First, define >, <, <=, etc. as applied to extents to mean
comparison according to the display order. Comparison between an
extent E and an index I means comparison between E and the range
[I, I].
Also define e>, e<, e<=, etc. to mean comparison according to the
e-order.
For any range R, define R(0) to be the starting index of the range
and R(1) to be the ending index of the range.
For any extent E, define E(next) to be the extent directly following
E, and E(prev) to be the extent directly preceding E. Assume
E(next) and E(prev) can be determined from E in constant time.
(This is because we store the extent list as a doubly linked
list.)
Similarly, define E(e-next) and E(e-prev) to be the extents
directly following and preceding E in the e-order.
Now:
Let R be a range.
Let F be the first extent overlapping R.
Let L be the last extent overlapping R.
Theorem 1: R(1) lies between L and L(next), i.e. L <= R(1) < L(next).
This follows easily from the definition of display order. The
basic reason that this theorem applies is that the display order
sorts by increasing starting index.
Therefore, we can determine L just by looking at where we would
insert R(1) into the list, and if we know F and are moving forward
over extents, we can easily determine when we've hit L by comparing
the extent we're at to R(1).
Theorem 2: F(e-prev) e< [1, R(0)] e<= F.
This is the analog of Theorem 1, and applies because the e-order
sorts by increasing ending index.
Therefore, F can be found in the same amount of time as operation (1),
i.e. the time that it takes to locate where an extent would go if
inserted into the e-order list.
If the lists were stored as balanced binary trees, then operation (1)
would take logarithmic time, which is usually quite fast. However,
currently they're stored as simple doubly-linked lists, and instead
we do some caching to try to speed things up.
Define a "stack of extents" (or "SOE") as the set of extents
(ordered in the display order) that overlap an index I, together with
the SOE's "previous" extent, which is an extent that precedes I in
the e-order. (Hopefully there will not be very many extents between
I and the previous extent.)
Now:
Let I be an index, let S be the stack of extents on I, let F be
the first extent in S, and let P be S's previous extent.
Theorem 3: The first extent in S is the first extent that overlaps
any range [I, J].
Proof: Any extent that overlaps [I, J] but does not include I must
have a start index > I, and thus be greater than any extent in S.
Therefore, finding the first extent that overlaps a range R is the
same as finding the first extent that overlaps R(0).
Theorem 4: Let I2 be an index such that I2 > I, and let F2 be the
first extent that overlaps I2. Then, either F2 is in S or F2 is
greater than any extent in S.
Proof: If F2 does not include I then its start index is greater
than I and thus it is greater than any extent in S, including F.
Otherwise, F2 includes I and thus is in S, and thus F2 >= F.
*/
#include <config.h>
#include "lisp.h"
#include "buffer.h"
#include "debug.h"
#include "device.h"
#include "extents.h"
#include "faces.h"
#include "frame.h"
#include "glyphs.h"
#include "hash.h"
#include "insdel.h"
#include "opaque.h"
#include "process.h"
#include "redisplay.h"
/* ------------------------------- */
/* general macros */
/* ------------------------------- */
#define MAX_INT ((long) ((1L << VALBITS) - 1))
/* ------------------------------- */
/* gap array */
/* ------------------------------- */
/* Note that this object is not extent-specific and should perhaps be
moved into another file. */
/* Holds a marker that moves as elements in the array are inserted and
deleted, similar to standard markers. */
typedef struct gap_array_marker
{
int pos;
struct gap_array_marker *next;
} Gap_Array_Marker;
/* Holds a "gap array", which is an array of elements with a gap located
in it. Insertions and deletions with a high degree of locality
are very fast, essentially in constant time. Array positions as
used and returned in the gap array functions are independent of
the gap. */
typedef struct gap_array
{
char *array;
int gap;
int gapsize;
int numels;
int elsize;
Gap_Array_Marker *markers;
} Gap_Array;
Gap_Array_Marker *gap_array_marker_freelist;
/* Convert a "memory position" (i.e. taking the gap into account) into
the address of the element at (i.e. after) that position. "Memory
positions" are only used internally and are of type Memind.
"Array positions" are used externally and are of type int. */
#define GAP_ARRAY_MEMEL_ADDR(ga, memel) ((ga)->array + (ga)->elsize*(memel))
/* Number of elements currently in a gap array */
#define GAP_ARRAY_NUM_ELS(ga) ((ga)->numels)
#define GAP_ARRAY_ARRAY_TO_MEMORY_POS(ga, pos) \
((pos) <= (ga)->gap ? (pos) : (pos) + (ga)->gapsize)
#define GAP_ARRAY_MEMORY_TO_ARRAY_POS(ga, pos) \
((pos) <= (ga)->gap ? (pos) : (pos) - (ga)->gapsize)
/* Convert an array position into the address of the element at
(i.e. after) that position. */
#define GAP_ARRAY_EL_ADDR(ga, pos) ((pos) < (ga)->gap ? \
GAP_ARRAY_MEMEL_ADDR(ga, pos) : \
GAP_ARRAY_MEMEL_ADDR(ga, (pos) + (ga)->gapsize))
/* ------------------------------- */
/* extent list */
/* ------------------------------- */
typedef struct extent_list_marker
{
Gap_Array_Marker *m;
int endp;
struct extent_list_marker *next;
} Extent_List_Marker;
typedef struct extent_list
{
Gap_Array *start;
Gap_Array *end;
Extent_List_Marker *markers;
} Extent_List;
Extent_List_Marker *extent_list_marker_freelist;
#define EXTENT_LESS_VALS(e,st,nd) ((extent_start (e) < (st)) || \
((extent_start (e) == (st)) && \
(extent_end (e) > (nd))))
#define EXTENT_EQUAL_VALS(e,st,nd) ((extent_start (e) == (st)) && \
(extent_end (e) == (nd)))
#define EXTENT_LESS_EQUAL_VALS(e,st,nd) ((extent_start (e) < (st)) || \
((extent_start (e) == (st)) && \
(extent_end (e) >= (nd))))
/* Is extent E1 less than extent E2 in the display order? */
#define EXTENT_LESS(e1,e2) \
EXTENT_LESS_VALS (e1, extent_start (e2), extent_end (e2))
/* Is extent E1 equal to extent E2? */
#define EXTENT_EQUAL(e1,e2) \
EXTENT_EQUAL_VALS (e1, extent_start (e2), extent_end (e2))
/* Is extent E1 less than or equal to extent E2 in the display order? */
#define EXTENT_LESS_EQUAL(e1,e2) \
EXTENT_LESS_EQUAL_VALS (e1, extent_start (e2), extent_end (e2))
#define EXTENT_E_LESS_VALS(e,st,nd) ((extent_end (e) < (nd)) || \
((extent_end (e) == (nd)) && \
(extent_start (e) > (st))))
#define EXTENT_E_LESS_EQUAL_VALS(e,st,nd) ((extent_end (e) < (nd)) || \
((extent_end (e) == (nd)) && \
(extent_start (e) >= (st))))
/* Is extent E1 less than extent E2 in the e-order? */
#define EXTENT_E_LESS(e1,e2) \
EXTENT_E_LESS_VALS(e1, extent_start (e2), extent_end (e2))
/* Is extent E1 less than or equal to extent E2 in the e-order? */
#define EXTENT_E_LESS_EQUAL(e1,e2) \
EXTENT_E_LESS_EQUAL_VALS (e1, extent_start (e2), extent_end (e2))
#define EXTENT_GAP_ARRAY_AT(ga, pos) (* (EXTENT *) GAP_ARRAY_EL_ADDR(ga, pos))
/* ------------------------------- */
/* auxiliary extent structure */
/* ------------------------------- */
struct extent_auxiliary extent_auxiliary_defaults;
MAC_DEFINE (EXTENT, mactemp_ancestor_extent);
MAC_DEFINE (EXTENT, mactemp_aux_extent);
MAC_DEFINE (EXTENT, mactemp_plist_extent);
MAC_DEFINE (EXTENT, mactemp_ensure_extent);
MAC_DEFINE (EXTENT, mactemp_set_extent);
/* ------------------------------- */
/* buffer-extent primitives */
/* ------------------------------- */
typedef struct stack_of_extents
{
Extent_List *extents;
Memind pos;
} Stack_Of_Extents;
Lisp_Object Vthis_is_a_dead_extent_replica;
/* ------------------------------- */
/* map-extents */
/* ------------------------------- */
typedef int Endpoint_Index;
#define memind_to_startind(x, start_open) \
((Endpoint_Index) (((x) << 1) + !!(start_open)))
#define memind_to_endind(x, end_open) \
((Endpoint_Index) (((x) << 1) - !!(end_open)))
/* Combination macros */
#define bytind_to_startind(buf, x, start_open) \
memind_to_startind (bytind_to_memind (buf, x), start_open)
#define bytind_to_endind(buf, x, end_open) \
memind_to_endind (bytind_to_memind (buf, x), end_open)
/* ------------------------------- */
/* extent-object primitives */
/* ------------------------------- */
/* These macros generalize many standard buffer-position functions to
either a buffer or a string. */
/* Converting between Meminds and Bytinds, for an extent object.
For strings, this is a no-op. For buffers, this resolves
to the standard memind<->bytind converters. */
#define extent_object_bytind_to_memind(obj, ind) \
(BUFFERP (obj) ? bytind_to_memind (XBUFFER (obj), ind) : (Memind) ind)
#define extent_object_memind_to_bytind(obj, ind) \
(BUFFERP (obj) ? memind_to_bytind (XBUFFER (obj), ind) : (Bytind) ind)
/* Converting between Bufpos's and Bytinds, for an extent object.
For strings, this maps to the bytecount<->charcount converters. */
#define extent_object_bufpos_to_bytind(obj, pos) \
(BUFFERP (obj) ? bufpos_to_bytind (XBUFFER (obj), pos) : \
(Bytind) charcount_to_bytecount (string_data (XSTRING (obj)), pos))
#define extent_object_bytind_to_bufpos(obj, ind) \
(BUFFERP (obj) ? bytind_to_bufpos (XBUFFER (obj), ind) : \
(Bufpos) bytecount_to_charcount (string_data (XSTRING (obj)), ind))
/* Similar for Bufpos's and Meminds. */
#define extent_object_bufpos_to_memind(obj, pos) \
(BUFFERP (obj) ? bufpos_to_memind (XBUFFER (obj), pos) : \
(Memind) charcount_to_bytecount (string_data (XSTRING (obj)), pos))
#define extent_object_memind_to_bufpos(obj, ind) \
(BUFFERP (obj) ? memind_to_bufpos (XBUFFER (obj), ind) : \
(Bufpos) bytecount_to_charcount (string_data (XSTRING (obj)), ind))
/* Similar for Bytinds and start/end indices. */
#define extent_object_bytind_to_startind(obj, ind, start_open) \
memind_to_startind (extent_object_bytind_to_memind (obj, ind), \
start_open)
#define extent_object_bytind_to_endind(obj, ind, end_open) \
memind_to_endind (extent_object_bytind_to_memind (obj, ind), \
end_open)
/* absolute and accessible bounds for a string or buffer.
For a string, this is always just the beginning and end of the string. */
#define extent_object_accessible_start(obj) \
(BUFFERP (obj) ? BI_BUF_BEGV (XBUFFER (obj)) : (Bytind) 0)
#define extent_object_absolute_start(obj) \
(BUFFERP (obj) ? BI_BUF_BEG (XBUFFER (obj)) : (Bytind) 0)
#define extent_object_accessible_limit(obj) \
(BUFFERP (obj) ? BI_BUF_ZV (XBUFFER (obj)) : \
(Bytind) string_length (XSTRING (obj)))
#define extent_object_absolute_limit(obj) \
(BUFFERP (obj) ? BI_BUF_Z (XBUFFER (obj)) : \
(Bytind) string_length (XSTRING (obj)))
/* ------------------------------- */
/* Lisp-level functions */
/* ------------------------------- */
/* flags for decode_extent() */
#define DE_MUST_HAVE_BUFFER 1
#define DE_MUST_BE_ATTACHED 2
#ifdef ENERGIZE
extern void restore_energize_extent_state (EXTENT extent);
extern struct Energize_Extent_Data *energize_extent_data (EXTENT);
extern Lisp_Object Qenergize;
#endif
Lisp_Object Vlast_highlighted_extent;
int mouse_highlight_priority;
Lisp_Object Qextentp;
Lisp_Object Qextent_replicap;
Lisp_Object Qextent_live_p;
Lisp_Object Qextent_replica_live_p;
Lisp_Object Qend_closed;
Lisp_Object Qstart_open;
Lisp_Object Qall_extents_closed;
Lisp_Object Qall_extents_open;
Lisp_Object Qall_extents_closed_open;
Lisp_Object Qall_extents_open_closed;
Lisp_Object Qstart_in_region;
Lisp_Object Qend_in_region;
Lisp_Object Qstart_and_end_in_region;
Lisp_Object Qstart_or_end_in_region;
Lisp_Object Qnegate_in_region;
Lisp_Object Qdup_list; /* used in string_dups() / set_string_dups() */
Lisp_Object Qdetached;
Lisp_Object Qdestroyed;
Lisp_Object Qbegin_glyph;
Lisp_Object Qend_glyph;
Lisp_Object Qstart_open;
Lisp_Object Qend_open;
Lisp_Object Qstart_closed;
Lisp_Object Qend_closed;
Lisp_Object Qread_only;
/* Qhighlight defined in general.c */
Lisp_Object Qunique;
Lisp_Object Qduplicable;
Lisp_Object Qinvisible;
Lisp_Object Qintangible;
Lisp_Object Qdetachable;
Lisp_Object Qpriority;
Lisp_Object Qglyph_layout; /* This exists only for backwards compatibility. */
Lisp_Object Qbegin_glyph_layout, Qend_glyph_layout;
Lisp_Object Qoutside_margin;
Lisp_Object Qinside_margin;
Lisp_Object Qwhitespace;
/* Qtext defined in general.c */
/* partially used in redisplay */
Lisp_Object Qglyph_invisible;
Lisp_Object Qcopy_function;
Lisp_Object Qpaste_function;
/************************************************************************/
/* Generalized gap array */
/************************************************************************/
/* This generalizes the "array with a gap" model used to store buffer
characters. This is based on the stuff in insdel.c and should
probably be merged with it. This is not extent-specific and should
perhaps be moved into a separate file. */
/* ------------------------------- */
/* internal functions */
/* ------------------------------- */
/* Adjust the gap array markers in the range (FROM, TO]. Parallel to
adjust_markers() in insdel.c. */
static void
gap_array_adjust_markers (Gap_Array *ga, Memind from,
Memind to, int amount)
{
Gap_Array_Marker *m;
for (m = ga->markers; m; m = m->next)
m->pos = do_marker_adjustment (m->pos, from, to, amount);
}
/* Move the gap to array position POS. Parallel to move_gap() in
insdel.c but somewhat simplified. */
static void
gap_array_move_gap (Gap_Array *ga, int pos)
{
int gap = ga->gap;
int gapsize = ga->gapsize;
assert (ga->array);
if (pos < gap)
{
memmove (GAP_ARRAY_MEMEL_ADDR (ga, pos + gapsize),
GAP_ARRAY_MEMEL_ADDR (ga, pos),
(gap - pos)*ga->elsize);
gap_array_adjust_markers (ga, (Memind) pos, (Memind) gap,
gapsize);
}
else if (pos > gap)
{
memmove (GAP_ARRAY_MEMEL_ADDR (ga, gap),
GAP_ARRAY_MEMEL_ADDR (ga, gap + gapsize),
(pos - gap)*ga->elsize);
gap_array_adjust_markers (ga, (Memind) (gap + gapsize),
(Memind) (pos + gapsize), - gapsize);
}
ga->gap = pos;
}
/* Make the gap INCREMENT characters longer. Parallel to make_gap() in
insdel.c. */
static void
gap_array_make_gap (Gap_Array *ga, int increment)
{
char *ptr = ga->array;
int real_gap_loc;
int old_gap_size;
/* If we have to get more space, get enough to last a while. We use
a geometric progession that saves on realloc space. */
increment += 100 + ga->numels / 8;
ptr = xrealloc (ptr,
(ga->numels + ga->gapsize + increment)*ga->elsize);
if (ptr == 0)
memory_full ();
ga->array = ptr;
real_gap_loc = ga->gap;
old_gap_size = ga->gapsize;
/* Call the newly allocated space a gap at the end of the whole space. */
ga->gap = ga->numels + ga->gapsize;
ga->gapsize = increment;
/* Move the new gap down to be consecutive with the end of the old one.
This adjusts the markers properly too. */
gap_array_move_gap (ga, real_gap_loc + old_gap_size);
/* Now combine the two into one large gap. */
ga->gapsize += old_gap_size;
ga->gap = real_gap_loc;
}
/* ------------------------------- */
/* external functions */
/* ------------------------------- */
/* Insert NUMELS elements (pointed to by ELPTR) into the specified
gap array at POS. */
static void
gap_array_insert_els (Gap_Array *ga, int pos, void *elptr, int numels)
{
assert (pos >= 0 && pos <= ga->numels);
if (ga->gapsize < numels)
gap_array_make_gap (ga, numels - ga->gapsize);
if (pos != ga->gap)
gap_array_move_gap (ga, pos);
memcpy (GAP_ARRAY_MEMEL_ADDR (ga, ga->gap), (char *) elptr,
numels*ga->elsize);
ga->gapsize -= numels;
ga->gap += numels;
ga->numels += numels;
/* This is the equivalent of insert-before-markers.
#### Should only happen if marker is "moves forward at insert" type.
*/
gap_array_adjust_markers (ga, pos - 1, pos, numels);
}
/* Delete NUMELS elements from the specified gap array, starting at FROM. */
static void
gap_array_delete_els (Gap_Array *ga, int from, int numdel)
{
int to = from + numdel;
int gapsize = ga->gapsize;
assert (from >= 0);
assert (numdel >= 0);
assert (to <= ga->numels);
/* Make sure the gap is somewhere in or next to what we are deleting. */
if (to < ga->gap)
gap_array_move_gap (ga, to);
if (from > ga->gap)
gap_array_move_gap (ga, from);
/* Relocate all markers pointing into the new, larger gap
to point at the end of the text before the gap. */
gap_array_adjust_markers (ga, to + gapsize, to + gapsize,
- numdel - gapsize);
ga->gapsize += numdel;
ga->numels -= numdel;
ga->gap = from;
}
static Gap_Array_Marker *
gap_array_make_marker (Gap_Array *ga, int pos)
{
Gap_Array_Marker *m;
assert (pos >= 0 && pos <= ga->numels);
if (gap_array_marker_freelist)
{
m = gap_array_marker_freelist;
gap_array_marker_freelist = gap_array_marker_freelist->next;
}
else
m = (Gap_Array_Marker *) xmalloc (sizeof (*m));
m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos);
m->next = ga->markers;
ga->markers = m;
return m;
}
static void
gap_array_delete_marker (Gap_Array *ga, Gap_Array_Marker *m)
{
Gap_Array_Marker *p, *prev;
for (prev = 0, p = ga->markers; p && p != m; prev = p, p = p->next)
;
assert (p);
if (prev)
prev->next = p->next;
else
ga->markers = p->next;
m->next = gap_array_marker_freelist;
m->pos = 0xDEADBEEF; /* -559038737 as an int */
gap_array_marker_freelist = m;
}
static void
gap_array_delete_all_markers (Gap_Array *ga)
{
Gap_Array_Marker *p, *next;
for (p = ga->markers; p; p = next)
{
next = p->next;
p->next = gap_array_marker_freelist;
p->pos = 0xDEADBEEF; /* -559038737 as an int */
gap_array_marker_freelist = p;
}
}
static void
gap_array_move_marker (Gap_Array *ga, Gap_Array_Marker *m, int pos)
{
assert (pos >= 0 && pos <= ga->numels);
m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos);
}
#define gap_array_marker_pos(ga, m) \
GAP_ARRAY_MEMORY_TO_ARRAY_POS (ga, (m)->pos)
static Gap_Array *
make_gap_array (int elsize)
{
Gap_Array *ga = (Gap_Array *) xmalloc (sizeof(*ga));
memset (ga, 0, sizeof(*ga));
ga->elsize = elsize;
return ga;
}
static void
free_gap_array (Gap_Array *ga)
{
if (ga->array)
xfree (ga->array);
gap_array_delete_all_markers (ga);
xfree (ga);
}
/************************************************************************/
/* Extent list primitives */
/************************************************************************/
/* A list of extents is maintained as a double gap array: one gap array
is ordered by start index (the "display order") and the other is
ordered by end index (the "e-order"). Note that positions in an
extent list should logically be conceived of as referring *to*
a particular extent (as is the norm in programs) rather than
sitting between two extents. Note also that callers of these
functions should not be aware of the fact that the extent list is
implemented as an array, except for the fact that positions are
integers (this should be generalized to handle integers and linked
list equally well).
*/
/* Number of elements in an extent list */
#define extent_list_num_els(el) GAP_ARRAY_NUM_ELS(el->start)
/* Return the position at which EXTENT is located in the specified extent
list (in the display order if ENDP is 0, in the e-order otherwise).
If the extent is not found, the position where the extent would
be inserted is returned. If ENDP is 0, the insertion would go after
all other equal extents. If ENDP is not 0, the insertion would go
before all other equal extents. If FOUNDP is not 0, then whether
the extent was found will get written into it. */
static int
extent_list_locate (Extent_List *el, EXTENT extent, int endp, int *foundp)
{
Gap_Array *ga = endp ? el->end : el->start;
int left = 0, right = GAP_ARRAY_NUM_ELS (ga);
int oldfoundpos, foundpos;
int found;
EXTENT e;
while (left != right)
{
/* RIGHT might not point to a valid extent (i.e. it's at the end
of the list), so NEWPOS must round down. */
unsigned int newpos = (left + right) >> 1;
e = EXTENT_GAP_ARRAY_AT (ga, newpos);
if (endp ? EXTENT_E_LESS (e, extent) : EXTENT_LESS (e, extent))
left = newpos+1;
else
right = newpos;
}
/* Now we're at the beginning of all equal extents. */
found = 0;
oldfoundpos = foundpos = left;
while (foundpos < GAP_ARRAY_NUM_ELS (ga))
{
e = EXTENT_GAP_ARRAY_AT (ga, foundpos);
if (e == extent)
{
found = 1;
break;
}
if (!EXTENT_EQUAL (e, extent))
break;
foundpos++;
}
if (foundp)
*foundp = found;
if (found || !endp)
return foundpos;
else
return oldfoundpos;
}
/* Return the position of the first extent that begins at or after POS
(or ends at or after POS, if ENDP is not 0).
An out-of-range value for POS is allowed, and guarantees that the
position at the beginning or end of the extent list is returned. */
static int
extent_list_locate_from_pos (Extent_List *el, Memind pos, int endp)
{
struct extent fake_extent;
/*
Note that if we search for [POS, POS], then we get the following:
-- if ENDP is 0, then all extents whose start position is <= POS
lie before the returned position, and all extents whose start
position is > POS lie at or after the returned position.
-- if ENDP is not 0, then all extents whose end position is < POS
lie before the returned position, and all extents whose end
position is >= POS lie at or after the returned position.
*/
set_extent_start (&fake_extent, endp ? pos : pos-1);
set_extent_end (&fake_extent, endp ? pos : pos-1);
return extent_list_locate (el, &fake_extent, endp, 0);
}
/* Return the extent at POS. */
static EXTENT
extent_list_at (Extent_List *el, Memind pos, int endp)
{
Gap_Array *ga = endp ? el->end : el->start;
assert (pos >= 0 && pos < GAP_ARRAY_NUM_ELS (ga));
return EXTENT_GAP_ARRAY_AT (ga, pos);
}
/* Insert an extent into an extent list. */
static void
extent_list_insert (Extent_List *el, EXTENT extent)
{
int pos, foundp;
pos = extent_list_locate (el, extent, 0, &foundp);
assert (!foundp);
gap_array_insert_els (el->start, pos, &extent, 1);
pos = extent_list_locate (el, extent, 1, &foundp);
assert (!foundp);
gap_array_insert_els (el->end, pos, &extent, 1);
}
/* Delete an extent from an extent list. */
static void
extent_list_delete (Extent_List *el, EXTENT extent)
{
int pos, foundp;
pos = extent_list_locate (el, extent, 0, &foundp);
assert (foundp);
gap_array_delete_els (el->start, pos, 1);
pos = extent_list_locate (el, extent, 1, &foundp);
assert (foundp);
gap_array_delete_els (el->end, pos, 1);
}
static Extent_List_Marker *
extent_list_make_marker (Extent_List *el, int pos, int endp)
{
Extent_List_Marker *m;
if (extent_list_marker_freelist)
{
m = extent_list_marker_freelist;
extent_list_marker_freelist = extent_list_marker_freelist->next;
}
else
m = (Extent_List_Marker *) xmalloc (sizeof (*m));
m->m = gap_array_make_marker (endp ? el->end : el->start, pos);
m->endp = endp;
m->next = el->markers;
el->markers = m;
return m;
}
#define extent_list_move_marker(el, mkr, pos) \
gap_array_move_marker((mkr)->endp ? (el)->end : (el)->start, (mkr)->m, pos)
static void
extent_list_delete_marker (Extent_List *el, Extent_List_Marker *m)
{
Extent_List_Marker *p, *prev;
for (prev = 0, p = el->markers; p && p != m; prev = p, p = p->next)
;
assert (p);
if (prev)
prev->next = p->next;
else
el->markers = p->next;
m->next = extent_list_marker_freelist;
extent_list_marker_freelist = m;
gap_array_delete_marker (m->endp ? el->end : el->start, m->m);
}
#define extent_list_marker_pos(el, mkr) \
gap_array_marker_pos ((mkr)->endp ? (el)->end : (el)->start, (mkr)->m)
static Extent_List *
make_extent_list (void)
{
Extent_List *el = (Extent_List *) xmalloc (sizeof(*el));
el->start = make_gap_array (sizeof(EXTENT));
el->end = make_gap_array (sizeof(EXTENT));
el->markers = 0;
return el;
}
static void
free_extent_list (Extent_List *el)
{
free_gap_array (el->start);
free_gap_array (el->end);
xfree (el);
}
/************************************************************************/
/* Auxiliary extent structure */
/************************************************************************/
static Lisp_Object mark_extent_auxiliary (Lisp_Object obj,
void (*markobj) (Lisp_Object));
DEFINE_LRECORD_IMPLEMENTATION ("extent-auxiliary", extent_auxiliary,
mark_extent_auxiliary, 0, 0, 0, 0,
struct extent_auxiliary);
static Lisp_Object
mark_extent_auxiliary (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct extent_auxiliary *data =
(struct extent_auxiliary *) XEXTENT_AUXILIARY (obj);
((markobj) (data->begin_glyph));
((markobj) (data->end_glyph));
((markobj) (data->parent));
/* data->children is a list so it should be returned rather
than recursed on */
return (data->children);
}
void
allocate_extent_aux_struct (EXTENT ext)
{
Lisp_Object extent_aux = Qnil;
struct extent_auxiliary *data =
alloc_lcrecord (sizeof (struct extent_auxiliary),
lrecord_extent_auxiliary);
copy_lcrecord (data, &extent_auxiliary_defaults);
XSETEXTENT_AUXILIARY (extent_aux, data);
ext->plist = Fcons (extent_aux, ext->plist);
ext->flags.has_aux = 1;
}
/************************************************************************/
/* Buffer/string extent primitives */
/************************************************************************/
/* The functions in this section are the ONLY ones that should know
about the internal implementation of the extent lists. Other functions
should only know that there are two orderings on extents, the "display"
order (sorted by start position, basically) and the e-order (sorted
by end position, basically), and that certain operations are provided
to manipulate the list. */
/* ------------------------------- */
/* basic primitives */
/* ------------------------------- */
static Lisp_Object
decode_extent_object (Lisp_Object object)
{
if (NILP (object))
XSETBUFFER (object, current_buffer);
else
CHECK_LIVE_BUFFER_OR_STRING (object, 0);
return object;
}
static void
strings_not_supported (void)
{
error ("Extents over strings not currently supported");
}
EXTENT
extent_ancestor_1 (EXTENT e)
{
while (e->flags.has_parent)
{
/* There should be no circularities except in case of a logic
error somewhere in the extent code */
e = XEXTENT (XEXTENT_AUXILIARY (XCAR (e->plist))->parent);
}
return e;
}
/* Given a string or buffer, return its extent list */
static Extent_List *
extent_object_extent_list (Lisp_Object object)
{
if (STRINGP (object))
{
strings_not_supported ();
return 0;
}
else
{
assert (BUFFERP (object));
return XBUFFER (object)->extents;
}
}
/* Retrieve the extent list that an extent is a member of */
#define extent_extent_list(e) extent_object_extent_list (extent_object (e))
/* ------------------------------- */
/* stack of extents */
/* ------------------------------- */
#ifdef ERROR_CHECK_EXTENTS
void
sledgehammer_extent_check (Lisp_Object object)
{
int i;
int endp;
Extent_List *el = extent_object_extent_list (object);
struct buffer *buf = 0;
if (BUFFERP (object))
buf = XBUFFER (object);
for (endp = 0; endp < 2; endp++)
for (i = 1; i < extent_list_num_els (el); i++)
{
EXTENT e1 = extent_list_at (el, i-1, endp);
EXTENT e2 = extent_list_at (el, i, endp);
if (buf)
{
assert (extent_start (e1) <= buf->text.gpt ||
extent_start (e1) > buf->text.gpt + buf->text.gap_size);
assert (extent_end (e1) <= buf->text.gpt ||
extent_end (e1) > buf->text.gpt + buf->text.gap_size);
}
assert (extent_start (e1) <= extent_end (e1));
assert (endp ? (EXTENT_E_LESS_EQUAL (e1, e2)) :
(EXTENT_LESS_EQUAL (e1, e2)));
}
}
#endif
static Stack_Of_Extents *
extent_object_stack_of_extents (Lisp_Object object)
{
if (STRINGP (object))
{
/* Maybe not all strings will have a stack of extents. In such
a case, we need to keep a cache of stacks of extents for the
strings that don't have them, and return such a cache now.
Returning 0 is not allowed. */
strings_not_supported ();
return 0;
}
else
{
assert (BUFFERP (object));
return XBUFFER (object)->soe;
}
}
/* #define SOE_DEBUG */
#ifdef SOE_DEBUG
static char *print_extent_1 (char *buf, Lisp_Object extent);
static void
print_extent_2 (EXTENT e)
{
Lisp_Object extent;
char buf[200];
XSETEXTENT (extent, e);
print_extent_1 (buf, extent);
printf ("%s", buf);
}
static void
soe_dump (Lisp_Object obj)
{
int i;
Stack_Of_Extents *soe = extent_object_stack_of_extents (obj);
Extent_List *sel;
int endp;
sel = soe->extents;
printf ("SOE pos is %d (memind %d)\n",
extent_object_memind_to_bytind (obj, soe->pos),
soe->pos);
for (endp = 0; endp < 2; endp++)
{
printf (endp ? "SOE end:" : "SOE start:");
for (i = 0; i < extent_list_num_els (sel); i++)
{
EXTENT e = extent_list_at (sel, i, endp);
printf ("\t");
print_extent_2 (e);
}
printf ("\n");
}
printf ("\n");
}
#endif
/* Insert EXTENT into OBJ's stack of extents, if necessary. */
static void
soe_insert (Lisp_Object obj, EXTENT extent)
{
Stack_Of_Extents *soe = extent_object_stack_of_extents (obj);
#ifdef SOE_DEBUG
printf ("Inserting into SOE: ");
print_extent_2 (extent);
printf ("\n");
#endif
if (soe->pos < extent_start (extent) || soe->pos > extent_end (extent))
{
#ifdef SOE_DEBUG
printf ("(not needed)\n\n");
#endif
return;
}
extent_list_insert (soe->extents, extent);
#ifdef SOE_DEBUG
printf ("SOE afterwards is:\n");
soe_dump (obj);
#endif
}
/* Delete EXTENT from OBJ's stack of extents, if necessary. */
static void
soe_delete (Lisp_Object obj, EXTENT extent)
{
Stack_Of_Extents *soe = extent_object_stack_of_extents (obj);
#ifdef SOE_DEBUG
printf ("Deleting from SOE: ");
print_extent_2 (extent);
printf ("\n");
#endif
if (soe->pos < extent_start (extent) || soe->pos > extent_end (extent))
{
#ifdef SOE_DEBUG
printf ("(not needed)\n\n");
#endif
return;
}
extent_list_delete (soe->extents, extent);
#ifdef SOE_DEBUG
printf ("SOE afterwards is:\n");
soe_dump (obj);
#endif
}
/* Move BUF's stack of extents to lie over the specified position. */
static void
soe_move (Lisp_Object obj, Memind pos)
{
Stack_Of_Extents *soe = extent_object_stack_of_extents (obj);
Extent_List *sel = soe->extents;
int numsoe = extent_list_num_els (sel);
Extent_List *bel = extent_object_extent_list (obj);
int direction;
int endp;
#ifdef SOE_DEBUG
printf ("Moving SOE from %d (memind %d) to %d (memind %d)\n",
extent_object_memind_to_bytind (obj, soe->pos), soe->pos,
extent_object_memind_to_bytind (obj, pos), pos);
#endif
if (soe->pos < pos)
{
direction = 1;
endp = 0;
}
else if (soe->pos > pos)
{
direction = -1;
endp = 1;
}
else
{
#ifdef SOE_DEBUG
printf ("(not needed)\n\n");
#endif
return;
}
/* For DIRECTION = 1: Any extent that overlaps POS is either in the
SOE (if the extent starts at or before SOE->POS) or is greater
(in the display order) than any extent in the SOE (if it starts
after SOE->POS).
For DIRECTION = -1: Any extent that overlaps POS is either in the
SOE (if the extent ends at or after SOE->POS) or is less (in the
e-order) than any extent in the SOE (if it ends before SOE->POS).
We proceed in two stages:
1) delete all extents in the SOE that don't overlap POS.
2) insert all extents into the SOE that start (or end, when
DIRECTION = -1) in (SOE->POS, POS] and that overlap
POS. (Don't include SOE->POS in the range because those
extents would already be in the SOE.)
*/
/* STAGE 1. */
if (numsoe > 0)
{
/* Delete all extents in the SOE that don't overlap POS.
This is all extents that end before (or start after,
if DIRECTION = -1) POS.
*/
/* Deleting extents from the SOE is tricky because it changes
the positions of extents. If we are deleting in the forward
direction we have to call extent_list_at() on the same position
over and over again because positions after the deleted element
get shifted back by 1. To make life simplest, we delete forward
irrespective of DIRECTION.
*/
int start, end;
int i;
if (direction > 0)
{
start = 0;
end = extent_list_locate_from_pos (sel, pos, 1);
}
else
{
start = extent_list_locate_from_pos (sel, pos+1, 0);
end = numsoe;
}
for (i = start; i < end; i++)
extent_list_delete (sel, extent_list_at (sel, start /* see above */,
!endp));
}
/* STAGE 2. */
{
int start_pos;
if (direction < 0)
start_pos = extent_list_locate_from_pos (bel, soe->pos, endp) - 1;
else
start_pos = extent_list_locate_from_pos (bel, soe->pos + 1, endp);
for (; start_pos >= 0 && start_pos < extent_list_num_els (bel);
start_pos += direction)
{
EXTENT e = extent_list_at (bel, start_pos, endp);
if ((direction > 0) ?
(extent_start (e) > pos) :
(extent_end (e) < pos))
break; /* All further extents lie on the far side of POS
and thus can't overlap. */
if ((direction > 0) ?
(extent_end (e) >= pos) :
(extent_start (e) <= pos))
extent_list_insert (sel, e);
}
}
soe->pos = pos;
#ifdef SOE_DEBUG
printf ("SOE afterwards is:\n");
soe_dump (obj);
#endif
}
static struct stack_of_extents *
make_soe (void)
{
struct stack_of_extents *soe = (struct stack_of_extents *)
xmalloc (sizeof (*soe));
soe->extents = make_extent_list ();
soe->pos = 0;
return soe;
}
static void
free_soe (struct stack_of_extents *soe)
{
free_extent_list (soe->extents);
xfree (soe);
}
/* ------------------------------- */
/* other primitives */
/* ------------------------------- */
/* Return the start (endp == 0) or end (endp == 1) of an extent as
a byte index. If you want the value as a memory index, use
extent_endpoint(). If you want the value as a buffer position,
use extent_endpoint_bufpos(). */
static Bytind
extent_endpoint_bytind (EXTENT extent, int endp)
{
assert (EXTENT_LIVE_P (extent));
assert (!extent_detached_p (extent));
{
Memind i = (endp) ? (extent_end (extent)) :
(extent_start (extent));
Lisp_Object obj = extent_object (extent);
return extent_object_memind_to_bytind (obj, i);
}
}
static Bufpos
extent_endpoint_bufpos (EXTENT extent, int endp)
{
assert (EXTENT_LIVE_P (extent));
assert (!extent_detached_p (extent));
{
Memind i = (endp) ? (extent_end (extent)) :
(extent_start (extent));
Lisp_Object obj = extent_object (extent);
return extent_object_memind_to_bufpos (obj, i);
}
}
/* A change to an extent occurred that will change the display, so
notify redisplay. Maybe also recurse over all the extent's
descendants. */
static void
extent_changed_for_redisplay (EXTENT extent, int descendants_too)
{
Lisp_Object object;
struct buffer *b;
Lisp_Object rest;
/* we could easily encounter a detached extent while traversing the
children, but we should never be able to encounter a dead extent. */
assert (EXTENT_LIVE_P (extent));
if (descendants_too)
{
/* first mark all of the extent's children. We will lose big-time
if there are any circularities here, so we sure as hell better
ensure that there aren't. */
for (rest = extent_children (extent); !NILP (rest);
rest = XCDR (rest))
extent_changed_for_redisplay (XEXTENT (XCAR (rest)), 1);
}
/* now mark the extent itself. */
object = extent_object (extent);
if (!BUFFERP (object) || extent_detached_p (extent))
/* #### Can changes to string extents affect redisplay?
I will have to think about this. What about string glyphs?
Things in the modeline? etc. */
return;
b = XBUFFER (object);
BUF_FACECHANGE (b)++;
MARK_EXTENTS_CHANGED;
buffer_extent_signal_changed_region (b,
extent_endpoint_bufpos (extent, 0),
extent_endpoint_bufpos (extent, 1));
}
/* A change to an extent occurred that will might affect redisplay.
This is called when properties such as the endpoints, the layout,
or the priority changes. Redisplay will be affected only if
the extent has any displayable attributes. */
static void
extent_maybe_changed_for_redisplay (EXTENT extent, int descendants_too)
{
EXTENT anc = extent_ancestor (extent);
if (!NILP (extent_face (anc)) || !NILP (extent_begin_glyph (anc)) ||
!NILP (extent_end_glyph (anc)) || extent_highlight_p (anc) ||
extent_invisible_p (anc) || extent_intangible_p (anc))
extent_changed_for_redisplay (extent, descendants_too);
}
static EXTENT
make_extent_detached (Lisp_Object object)
{
EXTENT extent = make_extent ();
assert (NILP (object) || STRINGP (object) ||
(BUFFERP (object) && BUFFER_LIVE_P (XBUFFER (object))));
extent_object (extent) = object;
return extent;
}
static EXTENT
real_extent_at_forward (Extent_List *el, int pos, int endp)
{
for (; pos < extent_list_num_els (el); pos++)
{
EXTENT e = extent_list_at (el, pos, endp);
if (!extent_internal_p (e))
return e;
}
return 0;
}
static EXTENT
real_extent_at_backward (Extent_List *el, int pos, int endp)
{
for (; pos >= 0; pos--)
{
EXTENT e = extent_list_at (el, pos, endp);
if (!extent_internal_p (e))
return e;
}
return 0;
}
static EXTENT
extent_first (Lisp_Object obj)
{
return real_extent_at_forward (extent_object_extent_list (obj), 0, 0);
}
#ifdef DEBUG_XEMACS
static EXTENT
extent_e_first (Lisp_Object obj)
{
return real_extent_at_forward (extent_object_extent_list (obj), 0, 1);
}
#endif
static EXTENT
extent_next (EXTENT e)
{
Extent_List *el = extent_extent_list (e);
int foundp;
int pos;
pos = extent_list_locate (el, e, 0, &foundp);
assert (foundp);
return real_extent_at_forward (el, pos+1, 0);
}
#ifdef DEBUG_XEMACS
static EXTENT
extent_e_next (EXTENT e)
{
Extent_List *el = extent_extent_list (e);
int foundp;
int pos;
pos = extent_list_locate (el, e, 1, &foundp);
assert (foundp);
return real_extent_at_forward (el, pos+1, 1);
}
#endif
static EXTENT
extent_last (Lisp_Object obj)
{
Extent_List *el = extent_object_extent_list (obj);
return real_extent_at_backward (el, extent_list_num_els (el) - 1, 0);
}
#ifdef DEBUG_XEMACS
static EXTENT
extent_e_last (Lisp_Object obj)
{
Extent_List *el = extent_object_extent_list (obj);
return real_extent_at_backward (el, extent_list_num_els (el) - 1, 1);
}
#endif
static EXTENT
extent_previous (EXTENT e)
{
Extent_List *el = extent_extent_list (e);
int foundp;
int pos;
pos = extent_list_locate (el, e, 0, &foundp);
assert (foundp);
return real_extent_at_backward (el, pos-1, 0);
}
#ifdef DEBUG_XEMACS
static EXTENT
extent_e_previous (EXTENT e)
{
Extent_List *el = extent_extent_list (e);
int foundp;
int pos;
pos = extent_list_locate (el, e, 1, &foundp);
assert (foundp);
return real_extent_at_backward (el, pos-1, 1);
}
#endif
static void
extent_attach (EXTENT extent)
{
Extent_List *el = extent_extent_list (extent);
extent_list_insert (el, extent);
soe_insert (extent_object (extent), extent);
/* only this extent changed */
extent_maybe_changed_for_redisplay (extent, 0);
}
static void
extent_detach (EXTENT extent)
{
Extent_List *el = extent_extent_list (extent);
/* call this before messing with the extent. */
extent_maybe_changed_for_redisplay (extent, 0);
extent_list_delete (el, extent);
soe_delete (extent_object (extent), extent);
set_extent_start (extent, 0);
set_extent_end (extent, 0);
}
/* ------------------------------- */
/* map-extents et al. */
/* ------------------------------- */
/* Returns true iff map_extents() would visit the given extent.
See the comments at map_extents() for info on the overlap rule.
Assumes that all validation on the extent and buffer positions has
already been performed (see Fextent_in_region_p ()).
*/
static int
extent_in_region_p (EXTENT extent, Bytind from, Bytind to,
unsigned int flags)
{
Lisp_Object obj = extent_object (extent);
Endpoint_Index start, end, exs, exe;
int start_open, end_open;
unsigned int all_extents_flags = flags & ME_ALL_EXTENTS_MASK;
unsigned int in_region_flags = flags & ME_IN_REGION_MASK;
int retval;
/* A zero-length region is treated as closed-closed. */
if (from == to)
{
flags |= ME_END_CLOSED;
flags &= ~ME_START_OPEN;
}
switch (all_extents_flags)
{
case ME_ALL_EXTENTS_CLOSED:
start_open = end_open = 0; break;
case ME_ALL_EXTENTS_OPEN:
start_open = end_open = 1; break;
case ME_ALL_EXTENTS_CLOSED_OPEN:
start_open = 0; end_open = 1; break;
case ME_ALL_EXTENTS_OPEN_CLOSED:
start_open = 1; end_open = 0; break;
default:
start_open = extent_start_open_p (extent);
end_open = extent_end_open_p (extent);
break;
}
/* So is a zero-length extent. */
if (extent_start (extent) == extent_end (extent))
start_open = end_open = 0;
start = extent_object_bytind_to_startind (obj, from, flags & ME_START_OPEN);
end = extent_object_bytind_to_endind (obj, to, ! (flags & ME_END_CLOSED));
exs = memind_to_startind (extent_start (extent), start_open);
exe = memind_to_endind (extent_end (extent), end_open);
/* It's easy to determine whether an extent lies *outside* the
region -- just determine whether it's completely before
or completely after the region. Reject all such extents, so
we're now left with only the extents that overlap the region.
*/
if (exs > end || exe < start)
return 0;
/* See if any further restrictions are called for. */
switch (in_region_flags)
{
case ME_START_IN_REGION:
retval = start <= exs && exs <= end; break;
case ME_END_IN_REGION:
retval = start <= exe && exe <= end; break;
case ME_START_AND_END_IN_REGION:
retval = start <= exs && exe <= end; break;
case ME_START_OR_END_IN_REGION:
retval = (start <= exs && exs <= end) || (start <= exe && exe <= end);
break;
default:
retval = 1; break;
}
return flags & ME_NEGATE_IN_REGION ? !retval : retval;
}
struct map_extents_struct
{
Extent_List *el;
Extent_List_Marker *mkr;
EXTENT range;
};
static Lisp_Object
map_extents_unwind (Lisp_Object obj)
{
struct map_extents_struct *closure =
(struct map_extents_struct *) get_opaque_ptr (obj);
if (closure->range)
extent_detach (closure->range);
if (closure->mkr)
extent_list_delete_marker (closure->el, closure->mkr);
return Qnil;
}
/* This is the guts of `map-extents' and the other functions that
map over extents. In theory the operation of this function is
simple: just figure out what extents we're mapping over, and
call the function on each one of them in the range. Unfortunately
there are a wide variety of things that the mapping function
might do, and we have to be very tricky to avoid getting messed
up. Furthermore, this function needs to be very fast (it is
called multiple times every time text is inserted or deleted
from a buffer), and so we can't always afford the overhead of
dealing with all the possible things that the mapping function
might do; thus, there are many flags that can be specified
indicating what the mapping function might or might not do.
The result of all this is that this is the most complicated
function in this file. Change it at your own risk!
A potential simplification to the logic below is to determine
all the extents that the mapping function should be called on
before any calls are actually made and save them in an array.
That introduces its own complications, however (the array
needs to be marked for garbage-collection, and a static array
cannot be used because map_extents() needs to be reentrant).
Furthermore, the results might be a little less sensible than
the logic below. */
static void
map_extents_bytind (Bytind from, Bytind to, emf fn, void *arg,
Lisp_Object obj, EXTENT after, unsigned int flags)
{
Memind st, en; /* range we're mapping over */
EXTENT range = 0; /* extent for this, if ME_MIGHT_MODIFY_TEXT */
Extent_List *el = 0; /* extent list we're iterating over */
Extent_List_Marker *posm = 0; /* marker for extent list,
if ME_MIGHT_MODIFY_EXTENTS */
/* count and struct for unwind-protect, if ME_MIGHT_THROW */
int count = 0;
struct map_extents_struct closure;
#ifdef ERROR_CHECK_EXTENTS
assert (from <= to);
assert (from >= extent_object_absolute_start (obj) &&
from <= extent_object_absolute_limit (obj) &&
to >= extent_object_absolute_start (obj) &&
to <= extent_object_absolute_limit (obj));
#endif
if (after)
{
assert (EQ (obj, extent_object (after)));
assert (!extent_detached_p (after));
}
st = extent_object_bytind_to_memind (obj, from);
en = extent_object_bytind_to_memind (obj, to);
if (flags & ME_MIGHT_MODIFY_TEXT)
{
/* The mapping function might change the text in the buffer,
so make an internal extent to hold the range we're mapping
over. */
range = make_extent_detached (obj);
set_extent_start (range, st);
set_extent_end (range, en);
range->flags.start_open = flags & ME_START_OPEN;
range->flags.end_open = !(flags & ME_END_CLOSED);
range->flags.internal = 1;
range->flags.detachable = 0;
extent_attach (range);
}
if (flags & ME_MIGHT_THROW)
{
/* The mapping function might throw past us so we need to use an
unwind_protect() to eliminate the internal extent and range
that we use. */
count = specpdl_depth ();
closure.range = range;
closure.mkr = 0;
record_unwind_protect (map_extents_unwind,
make_opaque_ptr (&closure));
}
/* ---------- Figure out where we start and what direction
we move in. This is the trickiest part of this
function. ---------- */
/* If ME_START_IN_REGION, ME_END_IN_REGION or ME_START_AND_END_IN_REGION
was specified and ME_NEGATE_IN_REGION was not specified, our job
is simple because of the presence of the display order and e-order.
(Note that theoretically do something similar for
ME_START_OR_END_IN_REGION, but that would require more trickiness
than it's worth to avoid hitting the same extent twice.)
In the general case, all the extents that overlap a range can be
divided into two classes: those whose start position lies within
the range (including the range's end but not including the
range's start), and those that overlap the start position,
i.e. those in the SOE for the start position. Or equivalently,
the extents can be divided into those whose end position lies
within the range and those in the SOE for the end position. Note
that for this purpose we treat both the range and all extents in
the buffer as closed on both ends. If this is not what the ME_
flags specified, then we've mapped over a few too many extents,
but no big deal because extent_in_region_p() will filter them
out. Ideally, we could move the SOE to the closer of the range's
two ends and work forwards or backwards from there. However, in
order to make the semantics of the AFTER argument work out, we
have to always go in the same direction; so we choose to always
move the SOE to the start position.
When it comes time to do the SOE stage, we first call soe_move()
so that the SOE gets set up. Note that the SOE might get
changed while we are mapping over its contents. If we can
guarantee that the SOE won't get moved to a new position, we
simply need to put a marker in the SOE and we will track deletions
and insertions of extents in the SOE. If the SOE might get moved,
however (this would happen as a result of a recursive invocation
of map-extents or a call to a redisplay-type function), then
trying to track its changes is hopeless, so we just keep a
marker to the first (or last) extent in the SOE and use that as
our bound.
Finally, if DONT_USE_SOE is defined, we don't use the SOE at all
and instead just map from the beginning of the buffer. This is
used for testing purposes and allows the SOE to be calculated
using map_extents() instead of the other way around. */
{
int range_flag; /* ME_*_IN_REGION subset of flags */
int do_soe_stage = 0; /* Are we mapping over the SOE? */
/* Does the range stage map over start or end positions? */
int range_endp;
/* If type == 0, we include the start position in the range stage mapping.
If type == 1, we exclude the start position in the range stage mapping.
If type == 2, we begin at range_start_pos, an extent-list position.
*/
int range_start_type = 0;
int range_start_pos = 0;
int stage;
range_flag = flags & ME_IN_REGION_MASK;
if ((range_flag == ME_START_IN_REGION ||
range_flag == ME_START_AND_END_IN_REGION) &&
!(flags & ME_NEGATE_IN_REGION))
{
/* map over start position in [range-start, range-end]. No SOE
stage. */
range_endp = 0;
}
else if (range_flag == ME_END_IN_REGION && !(flags & ME_NEGATE_IN_REGION))
{
/* map over end position in [range-start, range-end]. No SOE
stage. */
range_endp = 1;
}
else
{
/* Need to include the SOE extents. */
#ifdef DONT_USE_SOE
/* Just brute-force it: start from the beginning. */
range_endp = 0;
range_start_type = 2;
range_start_pos = 0;
#else
Stack_Of_Extents *soe = extent_object_stack_of_extents (obj);
int numsoe;
/* Move the SOE to the closer end of the range. This dictates
whether we map over start positions or end positions. */
range_endp = 0;
soe_move (obj, st);
numsoe = extent_list_num_els (soe->extents);
if (numsoe)
{
if (flags & ME_MIGHT_MOVE_SOE)
{
int foundp;
/* Can't map over SOE, so just extend range to cover the
SOE. */
EXTENT e = extent_list_at (soe->extents, 0, 0);
range_start_pos =
extent_list_locate (extent_object_extent_list (obj), e, 0,
&foundp);
assert (foundp);
range_start_type = 2;
}
else
{
/* We can map over the SOE. */
do_soe_stage = 1;
range_start_type = 1;
}
}
else
{
/* No extents in the SOE to map over, so we act just as if
ME_START_IN_REGION or ME_END_IN_REGION was specified.
RANGE_ENDP already specified so no need to do anything else. */
}
}
#endif
/* ---------- Now loop over the extents. ---------- */
/* We combine the code for the two stages because much of it
overlaps. */
for (stage = 0; stage < 2; stage++)
{
int pos = 0; /* Position in extent list */
/* First set up start conditions */
if (stage == 0)
{ /* The SOE stage */
if (!do_soe_stage)
continue;
el = extent_object_stack_of_extents (obj)->extents;
/* We will always be looping over start extents here. */
assert (!range_endp);
pos = 0;
}
else
{ /* The range stage */
el = extent_object_extent_list (obj);
switch (range_start_type)
{
case 0:
pos = extent_list_locate_from_pos (el, st, range_endp);
break;
case 1:
pos = extent_list_locate_from_pos (el, st + 1, range_endp);
break;
case 2:
pos = range_start_pos;
break;
}
}
if (flags & ME_MIGHT_MODIFY_EXTENTS)
{
/* Create a marker to track changes to the extent list */
if (posm)
/* Delete the marker used in the SOE stage. */
extent_list_delete_marker
(extent_object_stack_of_extents (obj)->extents, posm);
posm = extent_list_make_marker (el, pos, range_endp);
/* tell the unwind function about the marker. */
closure.el = el;
closure.mkr = posm;
}
/* Now loop! */
for (;;)
{
EXTENT e;
Lisp_Object obj2;
/* ----- update position in extent list
and fetch next extent ----- */
if (posm)
/* fetch POS again to track extent insertions or deletions */
pos = extent_list_marker_pos (el, posm);
if (pos >= extent_list_num_els (el))
break;
e = extent_list_at (el, pos, range_endp);
pos++;
if (posm)
/* now point the marker to the next one we're going to process.
This ensures graceful behavior if this extent is deleted. */
extent_list_move_marker (el, posm, pos);
/* ----- deal with internal extents ----- */
if (extent_internal_p (e))
{
if (!(flags & ME_INCLUDE_INTERNAL))
continue;
else if (e == range)
{
/* We're processing internal extents and we've
come across our own special range extent.
(This happens only in adjust_extents*() and
process_extents*(), which handle text
insertion and deletion.) We need to omit
processing of this extent; otherwise
we will probably end up prematurely
terminating this loop. */
continue;
}
}
/* ----- deal with AFTER condition ----- */
if (after)
{
/* if e > after, then we can stop skipping extents. */
if (EXTENT_LESS (after, e))
after = 0;
else /* otherwise, skip this extent. */
continue;
}
/* ----- stop if we're completely outside the range ----- */
/* fetch ST and EN again to track text insertions or deletions */
if (range)
{
st = extent_start (range);
en = extent_end (range);
}
if (extent_endpoint (e, range_endp) > en)
{
/* Can't be mapping over SOE because all extents in
there should overlap ST */
assert (stage == 1);
break;
}
/* ----- Now actually call the function ----- */
obj2 = extent_object (e);
if (extent_in_region_p (e,
extent_object_memind_to_bytind (obj2, st),
extent_object_memind_to_bytind (obj2, en),
flags))
{
if ((*fn)(e, arg))
{
/* Function wants us to stop mapping. */
stage = 1; /* so outer for loop will terminate */
break;
}
}
}
}
/* ---------- Finished looping. ---------- */
}
if (flags & ME_MIGHT_THROW)
/* This deletes the range extent and frees the marker. */
unbind_to (count, Qnil);
else
{
/* Delete them ourselves */
if (range)
extent_detach (range);
if (posm)
extent_list_delete_marker (el, posm);
}
}
void
map_extents (Bufpos from, Bufpos to, emf fn, void *arg,
Lisp_Object obj, EXTENT after, unsigned int flags)
{
map_extents_bytind (extent_object_bufpos_to_bytind (obj, from),
extent_object_bufpos_to_bytind (obj, to), fn, arg, obj,
after, flags);
}
/* ------------------------------- */
/* adjust_extents() */
/* ------------------------------- */
/* Add AMOUNT to all extent endpoints in the range (FROM, TO]. This
happens whenever the gap is moved. The reason for this is that
extent endpoints behave just like markers (all memory indices do)
and this adjustment correct for markers -- see adjust_markers().
Note that it is important that we visit all extent endpoints in the
range, irrespective of whether the endpoints are open or closed.
We could use map_extents() for this (and in fact the function
was originally written that way), but the gap is in an incoherent
state when this function is called and this function plays
around with extent endpoints without detaching and reattaching
the extents (this is provably correct and saves lots of time),
so for safety we make it just look at the extent lists directly.
*/
void
adjust_extents (struct buffer *buf, Memind from, Memind to,
int amount)
{
int endp;
int pos;
int startpos[2];
Lisp_Object obj = Qnil;
Extent_List *el;
Stack_Of_Extents *soe;
XSETBUFFER (obj, buf);
#ifdef ERROR_CHECK_EXTENTS
sledgehammer_extent_check (obj);
#endif
el = extent_object_extent_list (obj);
/* IMPORTANT! Compute the starting positions of the extents to
modify BEFORE doing any modification! Otherwise the starting
position for the second time through the loop might get
incorrectly calculated (I got bit by this bug real bad). */
startpos[0] = extent_list_locate_from_pos (el, from+1, 0);
startpos[1] = extent_list_locate_from_pos (el, from+1, 1);
for (endp = 0; endp < 2; endp++)
{
for (pos = startpos[endp]; pos < extent_list_num_els (el);
pos++)
{
EXTENT e = extent_list_at (el, pos, endp);
if (extent_endpoint (e, endp) > to)
break;
set_extent_endpoint (e,
do_marker_adjustment (extent_endpoint (e, endp),
from, to, amount),
endp);
}
}
/* The index for the buffer's SOE is a memory index and thus
needs to be adjusted like a marker. */
soe = extent_object_stack_of_extents (obj);
soe->pos = do_marker_adjustment (soe->pos, from, to, amount);
}
/* ------------------------------- */
/* adjust_extents_for_deletion() */
/* ------------------------------- */
struct adjust_extents_for_deletion_arg
{
extent_dynarr *list;
};
static int
adjust_extents_for_deletion_mapper (EXTENT extent, void *arg)
{
struct adjust_extents_for_deletion_arg *closure =
(struct adjust_extents_for_deletion_arg *) arg;
Dynarr_add (closure->list, extent);
return 0; /* continue mapping */
}
/* For all extent endpoints in the range (FROM, TO], move them to the beginning
of the new gap. Note that it is important that we visit all extent
endpoints in the range, irrespective of whether the endpoints are open or
closed.
*/
void
adjust_extents_for_deletion (struct buffer *buf, Bytind from,
Bytind to, int gapsize, int numdel)
{
struct adjust_extents_for_deletion_arg closure;
int i;
Memind oldsoe, newsoe;
Lisp_Object bufobj = Qnil;
XSETBUFFER (bufobj, buf);
#ifdef ERROR_CHECK_EXTENTS
sledgehammer_extent_check (bufobj);
#endif
closure.list = (extent_dynarr *) Dynarr_new (EXTENT);
/* We're going to be playing weird games below with extents and the SOE
and such, so compute the list now of all the extents that we're going
to muck with. If we do the mapping and adjusting together, things can
get all screwed up. */
map_extents_bytind (from, to, adjust_extents_for_deletion_mapper,
(void *) &closure, bufobj, 0,
/* extent endpoints move like markers regardless
of their open/closeness. */
ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED |
ME_START_OR_END_IN_REGION | ME_INCLUDE_INTERNAL);
/*
Old and new values for the SOE's position. (It gets adjusted
like a marker, just like extent endpoints.)
*/
oldsoe = buf->soe->pos;
newsoe = do_marker_adjustment (buf->soe->pos,
(Memind) (to + gapsize),
(Memind) (to + gapsize),
- numdel - gapsize);
for (i = 0; i < Dynarr_length (closure.list); i++)
{
EXTENT extent = Dynarr_at (closure.list, i);
Memind new_start, new_end;
/* do_marker_adjustment() will not adjust values that should not be
adjusted. We're passing the same funky arguments to
do_marker_adjustment() as buffer_delete_range() does. */
new_start =
do_marker_adjustment (extent_start (extent),
(Memind) (to + gapsize),
(Memind) (to + gapsize),
- numdel - gapsize);
new_end =
do_marker_adjustment (extent_end (extent),
(Memind) (to + gapsize),
(Memind) (to + gapsize),
- numdel - gapsize);
/* We need to be very careful here so that the SOE doesn't get
corrupted. We are shrinking extents out of the deleted region
and simultaneously moving the SOE's pos out of the deleted
region, so the SOE should contain the same extents at the end
as at the beginning. However, extents may get reordered
by this process, so we have to operate by pulling the extents
out of the buffer and SOE, changing their bounds, and then
reinserting them. In order for the SOE not to get screwed up,
we have to make sure that the SOE's pos points to its old
location whenever we pull an extent out, and points to its
new location whenever we put the extent back in.
*/
if (new_start != extent_start (extent) ||
new_end != extent_end (extent))
{
extent_detach (extent);
set_extent_start (extent, new_start);
set_extent_end (extent, new_end);
buf->soe->pos = newsoe;
extent_attach (extent);
buf->soe->pos = oldsoe;
}
}
buf->soe->pos = newsoe;
#ifdef ERROR_CHECK_EXTENTS
sledgehammer_extent_check (bufobj);
#endif
Dynarr_free (closure.list);
}
/* ------------------------------- */
/* extent fragments */
/* ------------------------------- */
/* Imagine that the buffer is divided up into contiguous,
nonoverlapping "runs" of text such that no extent
starts or ends within a run (extents that abut the
run don't count). This function returns the position
of the beginning of the first run that begins after POS,
or returns POS if there are no such runs. */
static Bytind
extent_find_end_of_run (Lisp_Object obj, Bytind pos, int outside_accessible)
{
Extent_List *sel = extent_object_stack_of_extents (obj)->extents;
Extent_List *bel = extent_object_extent_list (obj);
Bytind pos1, pos2;
int elind1, elind2;
Memind mempos = extent_object_bytind_to_memind (obj, pos);
Bytind limit = outside_accessible ?
extent_object_absolute_limit (obj) :
extent_object_accessible_limit (obj);
soe_move (obj, mempos);
/* Find the first start position after POS. */
elind1 = extent_list_locate_from_pos (bel, mempos+1, 0);
if (elind1 < extent_list_num_els (bel))
pos1 = extent_object_memind_to_bytind
(obj, extent_start (extent_list_at (bel, elind1, 0)));
else
pos1 = limit;
/* Find the first end position after POS. The extent corresponding
to this position is either in the SOE or is greater than or
equal to POS1, so we just have to look in the SOE. */
elind2 = extent_list_locate_from_pos (sel, mempos+1, 1);
if (elind2 < extent_list_num_els (sel))
pos2 = extent_object_memind_to_bytind
(obj, extent_end (extent_list_at (sel, elind2, 1)));
else
pos2 = limit;
return min (min (pos1, pos2), limit);
}
static Bytind
extent_find_beginning_of_run (Lisp_Object obj, Bytind pos,
int outside_accessible)
{
Extent_List *sel = extent_object_stack_of_extents (obj)->extents;
Extent_List *bel = extent_object_extent_list (obj);
Bytind pos1, pos2;
int elind1, elind2;
Memind mempos = extent_object_bytind_to_memind (obj, pos);
Bytind limit = outside_accessible ?
extent_object_absolute_start (obj) :
extent_object_accessible_start (obj);
soe_move (obj, mempos);
/* Find the first end position before POS. */
elind1 = extent_list_locate_from_pos (bel, mempos, 1);
if (elind1 > 0)
pos1 = extent_object_memind_to_bytind
(obj,
extent_end (extent_list_at (bel, elind1 - 1, 1)));
else
pos1 = limit;
/* Find the first start position before POS. The extent corresponding
to this position is either in the SOE or is less than or
equal to POS1, so we just have to look in the SOE. */
elind2 = extent_list_locate_from_pos (sel, mempos, 0);
if (elind2 > 0)
pos2 = extent_object_memind_to_bytind
(obj, extent_start (extent_list_at (sel, elind2 - 1, 0)));
else
pos2 = limit;
return max (max (pos1, pos2), limit);
}
struct extent_fragment *
extent_fragment_new (struct buffer *buf, struct frame *frm)
{
struct extent_fragment *ef = (struct extent_fragment *)
xmalloc (sizeof (struct extent_fragment));
memset (ef, 0, sizeof (*ef));
ef->buf = buf;
ef->frm = frm;
ef->extents = Dynarr_new (EXTENT);
ef->begin_glyphs = Dynarr_new (struct glyph_block);
ef->end_glyphs = Dynarr_new (struct glyph_block);
return ef;
}
void
extent_fragment_delete (struct extent_fragment *ef)
{
Dynarr_free (ef->extents);
Dynarr_free (ef->begin_glyphs);
Dynarr_free (ef->end_glyphs);
xfree (ef);
}
static int
extent_priority_sort_function (const void *humpty, const void *dumpty)
{
EXTENT foo = * (EXTENT *) humpty;
EXTENT bar = * (EXTENT *) dumpty;
if (extent_priority (foo) < extent_priority (bar))
return -1;
return (extent_priority (foo) > extent_priority (bar));
}
static void
extent_fragment_sort_by_priority (extent_dynarr *extarr)
{
int i;
/* Sort our copy of the stack by extent_priority. We use a bubble
sort here because it's going to be faster than qsort() for small
numbers of extents (less than 10 or so), and 99.999% of the time
there won't ever be more extents than this in the stack. */
if (Dynarr_length (extarr) < 10)
{
for (i = 1; i < Dynarr_length (extarr); i++)
{
int j = i - 1;
while (j >= 0 &&
(extent_priority (Dynarr_at (extarr, j)) >
extent_priority (Dynarr_at (extarr, j+1))))
{
EXTENT tmp = Dynarr_at (extarr, j);
Dynarr_at (extarr, j) = Dynarr_at (extarr, j+1);
Dynarr_at (extarr, j+1) = tmp;
j--;
}
}
}
else
/* But some loser programs mess up and may create a large number
of extents overlapping the same spot. This will result in
catastrophic behavior if we use the bubble sort above. */
qsort (Dynarr_atp (extarr, 0), Dynarr_length (extarr),
sizeof (EXTENT), extent_priority_sort_function);
}
face_index
extent_fragment_update (struct window *w, struct extent_fragment *ef,
Bytind pos)
{
int i;
Extent_List *sel = ef->buf->soe->extents;
EXTENT lhe = 0;
struct extent dummy_lhe_extent;
Memind mempos = bytind_to_memind (ef->buf, pos);
assert (pos >= BI_BUF_BEGV (ef->buf) && pos <= BI_BUF_ZV (ef->buf));
Dynarr_reset (ef->extents);
Dynarr_reset (ef->begin_glyphs);
Dynarr_reset (ef->end_glyphs);
ef->invisible = 0;
/* Set up the begin and end positions. */
ef->pos = pos;
ef->end = extent_find_end_of_run (make_buffer (ef->buf), pos, 0);
/* Note that extent_find_end_of_run() already moved the SOE for us. */
/* soe_move (ef->buf, mempos); */
/* Determine the begin glyphs at POS. */
for (i = 0; i < extent_list_num_els (sel); i++)
{
EXTENT e = extent_list_at (sel, i, 0);
if (extent_start (e) == mempos && !NILP (extent_begin_glyph (e)))
{
Lisp_Object glyph = extent_begin_glyph (e);
struct glyph_block gb;
gb.glyph = glyph;
gb.extent = Qnil;
XSETEXTENT (gb.extent, e);
Dynarr_add (ef->begin_glyphs, gb);
}
}
/* Determine the end glyphs at POS. */
for (i = 0; i < extent_list_num_els (sel); i++)
{
EXTENT e = extent_list_at (sel, i, 1);
if (extent_end (e) == mempos && !NILP (extent_end_glyph (e)))
{
Lisp_Object glyph = extent_end_glyph (e);
struct glyph_block gb;
gb.glyph = glyph;
gb.extent = Qnil;
XSETEXTENT (gb.extent, e);
Dynarr_add (ef->end_glyphs, gb);
}
}
/* Determine whether the last-highlighted-extent is present. */
if (EXTENTP (Vlast_highlighted_extent))
lhe = XEXTENT (Vlast_highlighted_extent);
/* Now add all extents that overlap the character after POS and
have a non-nil face. Also check if the character is invisible. */
for (i = 0; i < extent_list_num_els (sel); i++)
{
EXTENT e = extent_list_at (sel, i, 0);
if (extent_end (e) > mempos)
{
if (extent_invisible_p (e))
ef->invisible = 1;
if (!NILP (extent_face (e)) || e == lhe)
{
Dynarr_add (ef->extents, e);
if (e == lhe)
{
/* memset isn't really necessary; we only deref `priority' */
memset (&dummy_lhe_extent, 0, sizeof (dummy_lhe_extent));
set_extent_priority (&dummy_lhe_extent,
mouse_highlight_priority);
Dynarr_add (ef->extents, &dummy_lhe_extent);
}
}
}
}
extent_fragment_sort_by_priority (ef->extents);
/* Now merge the faces together into a single face. The code to
do this is in faces.c because it involves manipulating faces. */
return get_extent_fragment_face_cache_index (w, ef, &dummy_lhe_extent);
}
/************************************************************************/
/* extent-object methods */
/************************************************************************/
/* These are the basic helper functions for handling the allocation of
extent objects and extent-replica objects. They are similar to
the functions for other lrecord objects. make_extent() is in
alloc.c, not here. */
static Lisp_Object mark_extent (Lisp_Object, void (*) (Lisp_Object));
static Lisp_Object mark_extent_replica (Lisp_Object, void (*) (Lisp_Object));
static int extent_equal (Lisp_Object, Lisp_Object, int depth);
static int extent_replica_equal (Lisp_Object, Lisp_Object, int depth);
static unsigned long extent_hash (Lisp_Object obj, int depth);
static unsigned long extent_replica_hash (Lisp_Object obj, int depth);
static void print_extent_or_replica (Lisp_Object obj,
Lisp_Object printcharfun, int escapeflag);
static int extent_getprop (Lisp_Object obj, Lisp_Object prop,
Lisp_Object *value_out);
static int extent_putprop (Lisp_Object obj, Lisp_Object prop,
Lisp_Object value);
static int extent_remprop (Lisp_Object obj, Lisp_Object prop);
static Lisp_Object extent_props (Lisp_Object obj);
DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("extent", extent,
mark_extent,
print_extent_or_replica, 0,
extent_equal, extent_hash,
extent_getprop, extent_putprop,
extent_remprop, extent_props,
struct extent);
DEFINE_LRECORD_IMPLEMENTATION ("extent-replica", extent_replica,
mark_extent_replica, print_extent_or_replica,
0, extent_replica_equal, extent_replica_hash,
struct extent_replica);
static Lisp_Object
mark_extent (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct extent *extent = XEXTENT (obj);
if (gc_record_type_p (extent_object (extent), lrecord_extent))
/* Can't be a replica here! */
abort ();
((markobj) (extent_object (extent)));
((markobj) (extent_face (extent)));
return (extent->plist);
}
/* Extents in a buffer are not threaded like normal Lisp_Objects, but
are stored in an array. Furthermore, the direct pointers are used
rather than the Lisp_Objects. (This would fail if we had a
relocating garbage collector, but that is not likely to ever
happen.) So we have to loop over them ourselves. This function
is called from mark_buffer(). */
void
mark_buffer_extents (struct buffer *buf, void (*markobj) (Lisp_Object))
{
int i;
Extent_List *list = buf->extents;
/* Vbuffer_defaults and Vbuffer_local_symbols are buffer-like
objects that are created specially and never have their extent
list initialized (or rather, it is set to zero in
nuke_all_buffer_slots()). However, these objects get
garbage-collected so we have to deal.
(Also the list can be zero when we're dealing with a destroyed
buffer.) */
if (!list)
return;
for (i = 0; i < extent_list_num_els (list); i++)
{
struct extent *extent = extent_list_at (list, i, 0);
Lisp_Object obj = Qnil;
XSETEXTENT (obj, extent);
((markobj) (obj));
((markobj) (extent->plist));
((markobj) (extent_object (extent)));
}
}
static Lisp_Object
mark_extent_replica (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct extent_replica *dup = XEXTENT_REPLICA (obj);
if (!gc_record_type_p (extent_replica_extent (dup), lrecord_extent))
/* Can't be an extent here! */
abort ();
return (extent_replica_extent (dup));
}
static char *
print_extent_1 (char *buf, Lisp_Object extent_obj)
{
Bufpos from = XINT (Fextent_start_position (extent_obj));
Bufpos to = XINT (Fextent_end_position (extent_obj));
EXTENT ext = XEXTENT (extent_obj);
EXTENT anc = extent_ancestor (ext);
char *bp = buf;
Lisp_Object tail;
/* Retrieve the ancestor and use it, for faster retrieval of properties */
if (!NILP (extent_begin_glyph (anc))) *bp++ = '*';
*bp++ = (extent_start_open_p (anc) ? '(': '[');
if (extent_detached_p (ext))
sprintf (bp, "detached");
else
sprintf (bp, "%d, %d", from, to);
bp += strlen (bp);
*bp++ = (extent_end_open_p (anc) ? ')': ']');
if (!NILP (extent_end_glyph (anc))) *bp++ = '*';
*bp++ = ' ';
if (extent_read_only_p (anc)) *bp++ = '%';
if (extent_highlight_p (anc)) *bp++ = 'H';
if (extent_unique_p (anc)) *bp++ = 'U';
else if (extent_duplicable_p (anc)) *bp++ = 'D';
if (extent_invisible_p (anc)) *bp++ = 'I';
if (extent_read_only_p (anc) || extent_highlight_p (anc) ||
extent_unique_p (anc) || extent_duplicable_p (anc) ||
extent_invisible_p (anc))
*bp++ = ' ';
tail = extent_plist (anc);
for (; !NILP (tail); tail = Fcdr (Fcdr (tail)))
{
struct Lisp_String *k = XSYMBOL (XCAR (tail))->name;
Lisp_Object v = XCAR (XCDR (tail));
if (NILP (v)) continue;
memcpy (bp, (char *) string_data (k), string_length (k));
bp += string_length (k);
*bp++ = ' ';
}
sprintf (bp, "0x%lx", (long) ext);
bp += strlen (bp);
*bp++ = 0;
return buf;
}
static char *
print_extent_replica_1 (char *buf, Lisp_Object extent_replica)
{
char buf2[256];
Lisp_Object extent =
extent_replica_extent (XEXTENT_REPLICA (extent_replica));
if (EXTENT_LIVE_P (XEXTENT (extent)))
sprintf (buf, "[%d, %d) of extent %s",
extent_replica_start (XEXTENT_REPLICA (extent_replica)),
extent_replica_end (XEXTENT_REPLICA (extent_replica)),
print_extent_1 (buf2, extent));
else
sprintf (buf, "[%d, %d) of destroyed extent",
extent_replica_start (XEXTENT_REPLICA (extent_replica)),
extent_replica_end (XEXTENT_REPLICA (extent_replica)));
return buf;
}
static void
print_extent_or_replica (Lisp_Object obj,
Lisp_Object printcharfun, int escapeflag)
{
char buf2[256];
if (EXTENTP (obj))
{
if (escapeflag)
{
CONST char *title = "";
CONST char *name = "";
Lisp_Object obj2 = Qnil;
char stringname[30];
/* Destroyed extents have 't' in the object field, causing
extent_object() to abort (maybe). */
if (EXTENT_LIVE_P (XEXTENT (obj)))
obj2 = extent_object (XEXTENT (obj));
if (NILP (obj2))
title = "no buffer";
else if (BUFFERP (obj2))
{
if (BUFFER_LIVE_P (XBUFFER (obj2)))
{
title = "buffer ";
name = (char *) string_data (XSTRING (XBUFFER (obj2)->name));
}
else
{
title = "Killed Buffer";
name = "";
}
}
else
{
assert (STRINGP (obj2));
title = "string ";
sprintf (stringname, "0x%x", (unsigned int) XSTRING (obj2));
}
if (print_readably)
{
if (!EXTENT_LIVE_P (XEXTENT (obj)))
error ("printing unreadable object #<destroyed extent>");
else
error ("printing unreadable object #<extent %s>",
print_extent_1 (buf2, obj));
}
if (!EXTENT_LIVE_P (XEXTENT (obj)))
write_c_string ("#<destroyed extent", printcharfun);
else
{
char buf[256];
write_c_string ("#<extent ", printcharfun);
if (extent_detached_p (XEXTENT (obj)))
sprintf (buf, "%s from %s%s",
print_extent_1 (buf2, obj), title, name);
else
sprintf (buf, "%s in %s%s",
print_extent_1 (buf2, obj),
title, name);
write_c_string (buf, printcharfun);
}
}
else
{
if (print_readably)
error ("printing unreadable object #<extent>");
write_c_string ("#<extent", printcharfun);
}
write_c_string (">", printcharfun);
}
else if (EXTENT_REPLICAP (obj))
{
if (escapeflag)
{
if (print_readably)
{
if (!EXTENT_REPLICA_LIVE_P (XEXTENT_REPLICA (obj)))
error
("printing unreadable object #<destroyed extent-replica>");
else
error ("printing unreadable object #<extent-replica %s>",
print_extent_replica_1 (buf2, obj));
}
if (!EXTENT_REPLICA_LIVE_P (XEXTENT_REPLICA (obj)))
write_c_string ("#<destroyed extent-replica", printcharfun);
else
{
write_c_string ("#<extent-replica ", printcharfun);
print_extent_replica_1 (buf2, obj);
write_c_string (buf2, printcharfun);
}
}
else
{
if (print_readably)
error ("printing unreadable object #<extent-replica>");
write_c_string ("#<extent-replica", printcharfun);
}
write_c_string (">", printcharfun);
}
}
static int
properties_equal (EXTENT e1, EXTENT e2, int depth)
{
/* When this function is called, all indirections have been followed.
Thus, the indirection checks in the various macros below will not
amount to anything, and could be removed. However, the time
savings would probably not be significant. */
if (!(EQ (extent_face (e1), extent_face (e2)) &&
extent_priority (e1) == extent_priority (e2) &&
internal_equal (extent_begin_glyph (e1), extent_begin_glyph (e2),
depth + 1) &&
internal_equal (extent_end_glyph (e1), extent_end_glyph (e2),
depth + 1)))
return 0;
/* compare the bit flags. */
{
/* The has_aux field should not be relevant. */
int e1_has_aux = e1->flags.has_aux;
int e2_has_aux = e2->flags.has_aux;
int value;
e1->flags.has_aux = e2->flags.has_aux = 0;
value = memcmp (&e1->flags, &e2->flags, sizeof (e1->flags));
e1->flags.has_aux = e1_has_aux;
e2->flags.has_aux = e2_has_aux;
if (value)
return 0;
}
/* compare the random elements of the plists. */
return (!plists_differ (extent_ancestor_plist (e1),
extent_ancestor_plist (e2),
depth + 1));
}
static int
extent_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
struct extent *e1 = XEXTENT (o1);
struct extent *e2 = XEXTENT (o2);
return
(extent_start (e1) == extent_start (e2) &&
extent_end (e1) == extent_end (e2) &&
internal_equal (extent_object (e1), extent_object (e2), depth + 1) &&
properties_equal (extent_ancestor (e1), extent_ancestor (e2),
depth));
}
static int
extent_replica_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
struct extent_replica *e1 = XEXTENT_REPLICA (o1);
struct extent_replica *e2 = XEXTENT_REPLICA (o2);
if (!EXTENT_REPLICA_LIVE_P (e1) && !EXTENT_REPLICA_LIVE_P (e2))
return 1;
return (extent_replica_start (e1) == extent_replica_start (e2) &&
extent_replica_end (e1) == extent_replica_end (e2) &&
internal_equal (extent_replica_extent (e1),
extent_replica_extent (e2), depth + 1));
}
static unsigned long
extent_hash (Lisp_Object obj, int depth)
{
struct extent *e = XEXTENT (obj);
/* No need to hash all of the elements; that would take too long.
Just hash the most common ones. */
return HASH3 (extent_start (e), extent_end (e),
internal_hash (extent_object (e), depth + 1));
}
static unsigned long
extent_replica_hash (Lisp_Object obj, int depth)
{
struct extent_replica *e = XEXTENT_REPLICA (obj);
if (!EXTENT_REPLICA_LIVE_P (e))
return 0;
return HASH3 (extent_replica_start (e), extent_replica_end (e),
internal_hash (extent_replica_extent (e), depth + 1));
}
static int
extent_getprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object *value_out)
{
error ("Not yet implemented"); /* #### */
return 0;
}
static int
extent_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
{
error ("Not yet implemented"); /* #### */
return 0;
}
static int
extent_remprop (Lisp_Object obj, Lisp_Object prop)
{
error ("Not yet implemented"); /* #### */
return 0;
}
static Lisp_Object
extent_props (Lisp_Object obj)
{
error ("Not yet implemented"); /* #### */
return Qnil;
}
/************************************************************************/
/* basic extent accessors */
/************************************************************************/
/* These functions are for checking externally-passed extent objects
and returning an extent's basic properties, which include the
buffer the extent is associated with, the endpoints of the extent's
range, the open/closed-ness of those endpoints, and whether the
extent is detached. Manipulating these properties requires
manipulating the ordered lists that hold extents; thus, functions
to do that are in a later section. */
/* Given a Lisp_Object that is supposed to be an extent, make sure it
is OK and return an extent pointer. Extents can be in one of four
states:
1) destroyed
2) detached and not associated with a buffer
3) detached and associated with a buffer
4) attached to a buffer
If FLAGS is 0, types 2-4 are allowed. If FLAGS is DE_MUST_HAVE_BUFFER,
types 3-4 are allowed. If FLAGS is DE_MUST_BE_ATTACHED, only type 4
is allowed.
*/
static EXTENT
decode_extent (Lisp_Object extent_obj, unsigned int flags)
{
EXTENT extent;
Lisp_Object obj;
CHECK_LIVE_EXTENT (extent_obj, 0);
extent = XEXTENT (extent_obj);
obj = extent_object (extent);
/* the following condition will fail if we're dealing with a freed extent
or an extent replica */
assert (NILP (obj) || BUFFERP (obj) || STRINGP (obj));
if (flags & DE_MUST_BE_ATTACHED)
flags |= DE_MUST_HAVE_BUFFER;
/* if buffer is dead, then convert extent to have no buffer. */
if (BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj)))
obj = extent_object (extent) = Qnil;
assert (!NILP (obj) || extent_detached_p (extent));
if (NILP (obj) && (flags & DE_MUST_HAVE_BUFFER))
{
Lisp_Object extent_obj;
XSETEXTENT (extent_obj, extent);
signal_simple_error ("extent doesn't belong to a buffer",
extent_obj);
}
if (extent_detached_p (extent) && (flags & DE_MUST_BE_ATTACHED))
{
Lisp_Object extent_obj;
XSETEXTENT (extent_obj, extent);
signal_simple_error ("extent cannot be detached", extent_obj);
}
return extent;
}
/* Note that the returned value is a buffer position, not a byte index. */
static Lisp_Object
extent_endpoint_external (Lisp_Object extent_obj, int endp)
{
EXTENT extent = decode_extent (extent_obj, 0);
if (extent_detached_p (extent))
return Qnil;
else
return make_number (extent_endpoint_bufpos (extent, endp));
}
DEFUN ("extentp", Fextentp, Sextentp, 1, 1, 0,
"T if OBJECT is an extent.")
(object)
Lisp_Object object;
{
if (EXTENTP (object))
return Qt;
return Qnil;
}
DEFUN ("extent-live-p", Fextent_live_p, Sextent_live_p, 1, 1, 0,
"T if OBJECT is an extent and the extent has not been destroyed.")
(object)
Lisp_Object object;
{
if (EXTENTP (object) && EXTENT_LIVE_P (XEXTENT (object)))
return Qt;
return Qnil;
}
DEFUN ("extent-detached-p", Fextent_detached_p, Sextent_detached_p, 1, 1, 0,
"T if EXTENT is detached.")
(extent)
Lisp_Object extent;
{
if (extent_detached_p (decode_extent (extent, 0)))
return Qt;
return Qnil;
}
/* #### This will soon get renamed to `extent-object', with
extent-buffer being an obsolete alias for it. */
DEFUN ("extent-buffer", Fextent_object, Sextent_object, 1, 1, 0,
"Return buffer of EXTENT.")
(extent)
Lisp_Object extent;
{
return extent_object (decode_extent (extent, 0));
}
DEFUN ("extent-start-position", Fextent_start_position,
Sextent_start_position, 1, 1, 0,
"Return start position of EXTENT, or nil if EXTENT is detached.")
(extent)
Lisp_Object extent;
{
return extent_endpoint_external (extent, 0);
}
DEFUN ("extent-end-position", Fextent_end_position,
Sextent_end_position, 1, 1, 0,
"Return end position of EXTENT, or nil if EXTENT is detached.")
(extent)
Lisp_Object extent;
{
return extent_endpoint_external (extent, 1);
}
DEFUN ("extent-length", Fextent_length, Sextent_length, 1, 1, 0,
"Return length of EXTENT in characters.")
(extent)
Lisp_Object extent;
{
EXTENT e = decode_extent (extent, DE_MUST_BE_ATTACHED);
return
make_number (extent_endpoint_bufpos (e, 1) -
extent_endpoint_bufpos (e, 0));
}
DEFUN ("next-extent", Fnext_extent, Snext_extent, 1, 1, 0,
"Find next extent after EXTENT.\n\
If EXTENT is a buffer return the first extent in the buffer.\n\
Extents in a buffer are ordered in what is called the \"display\"\n\
order, which sorts by increasing start positions and then by *decreasing*\n\
end positions.\n\
If you want to perform an operation on a series of extents, use\n\
`map-extents' instead of this function; it is much more efficient.\n\
The primary use of this function should be to enumerate all the\n\
extents in a buffer.\n\
Note: The display order is not necessarily the order that `map-extents'\n\
processes extents in!")
(extent)
Lisp_Object extent;
{
Lisp_Object val;
EXTENT next;
if (EXTENTP (extent))
next = extent_next (decode_extent (extent, DE_MUST_BE_ATTACHED));
else
next = extent_first (decode_extent_object (extent));
if (!next)
return (Qnil);
XSETEXTENT (val, next);
return (val);
}
DEFUN ("previous-extent", Fprevious_extent, Sprevious_extent, 1, 1, 0,
"Find last extent before EXTENT.\n\
If EXTENT is a buffer return the last extent in the buffer.\n\
This function is analogous to `next-extent'.")
(extent)
Lisp_Object extent;
{
Lisp_Object val;
EXTENT prev;
if (EXTENTP (extent))
prev = extent_previous (decode_extent (extent, DE_MUST_BE_ATTACHED));
else
prev = extent_last (decode_extent_object (extent));
if (!prev)
return (Qnil);
XSETEXTENT (val, prev);
return (val);
}
#ifdef DEBUG_XEMACS
DEFUN ("next-e-extent", Fnext_e_extent, Snext_e_extent, 1, 1, 0,
"Find next extent after EXTENT using the \"e\" order.\n\
If EXTENT is a buffer, return the first extent in the buffer.")
(extent)
Lisp_Object extent;
{
Lisp_Object val;
EXTENT next;
if (EXTENTP (extent))
next = extent_e_next (decode_extent (extent, DE_MUST_BE_ATTACHED));
else
next = extent_e_first (decode_extent_object (extent));
if (!next)
return (Qnil);
XSETEXTENT (val, next);
return (val);
}
DEFUN ("previous-e-extent", Fprevious_e_extent, Sprevious_e_extent, 1, 1, 0,
"Find last extent before EXTENT using the \"e\" order.\n\
If EXTENT is a buffer return the last extent in the buffer.\n\
This function is analogous to `next-e-extent'.")
(extent)
Lisp_Object extent;
{
Lisp_Object val;
EXTENT prev;
if (EXTENTP (extent))
prev = extent_e_previous (decode_extent (extent, DE_MUST_BE_ATTACHED));
else
prev = extent_e_last (decode_extent_object (extent));
if (!prev)
return (Qnil);
XSETEXTENT (val, prev);
return (val);
}
#endif
DEFUN ("next-extent-change", Fnext_extent_change, Snext_extent_change,
1, 2, 0,
"Return the next position after POS where an extent begins or ends.\n\
If POS is at the end of the buffer, POS will be returned; otherwise a\n\
position greater than POS will always be returned.\n\
If BUFFER is nil, the current buffer is assumed.")
(pos, buffer)
Lisp_Object pos, buffer;
{
Lisp_Object obj = decode_extent_object (buffer);
Bytind bpos;
if (BUFFERP (obj))
bpos = get_bytind (XBUFFER (obj), pos, GB_ALLOW_PAST_ACCESSIBLE);
else
{
assert (STRINGP (obj));
bpos = get_string_bytepos (obj, pos);
}
bpos = extent_find_end_of_run (obj, bpos, 1);
return make_number (extent_object_bytind_to_bufpos (obj, bpos));
}
DEFUN ("previous-extent-change", Fprevious_extent_change,
Sprevious_extent_change, 1, 2, 0,
"Return the last position before POS where an extent begins or ends.\n\
If POS is at the beginning of the buffer, POS will be returned; otherwise a\n\
position less than POS will always be returned.\n\
If BUFFER is nil, the current buffer is assumed.")
(pos, buffer)
Lisp_Object pos, buffer;
{
Lisp_Object obj = decode_extent_object (buffer);
Bytind bpos;
if (BUFFERP (obj))
bpos = get_bytind (XBUFFER (obj), pos, GB_ALLOW_PAST_ACCESSIBLE);
else
{
assert (STRINGP (obj));
bpos = get_string_bytepos (obj, pos);
}
bpos = extent_find_beginning_of_run (obj, bpos, 1);
return make_number (extent_object_bytind_to_bufpos (obj, bpos));
}
/************************************************************************/
/* parent and children stuff */
/************************************************************************/
DEFUN ("extent-parent", Fextent_parent, Sextent_parent, 1, 1, 0,
"Return the parent (if any) of EXTENT.\n\
If an extent has a parent, it derives all its properties from that extent\n\
and has no properties of its own. It is possible for an extent's parent\n\
to itself have a parent.")
(extent)
Lisp_Object extent;
/* do I win the prize for the strangest split infinitive? */
{
EXTENT e = decode_extent (extent, 0);
return extent_parent (e);
}
DEFUN ("extent-children", Fextent_children, Sextent_children, 1, 1, 0,
"Return a list of the children (if any) of EXTENT.\n\
The children of an extent are all those extents whose parent is that extent.\n\
This function does not recursively trace children of children.")
(extent)
Lisp_Object extent;
{
EXTENT e = decode_extent (extent, 0);
return Fcopy_sequence (extent_children (e));
}
static void
remove_extent_from_children_list (EXTENT e, Lisp_Object child)
{
Lisp_Object children = extent_children (e);
#ifdef ERROR_CHECK_EXTENTS
assert (!NILP (memq_no_quit (child, children)));
#endif
set_extent_ancestor_aux_field (e, children, delq_no_quit (child, children));
}
static void
add_extent_to_children_list (EXTENT e, Lisp_Object child)
{
Lisp_Object children = extent_children (e);
#ifdef ERROR_CHECK_EXTENTS
assert (NILP (memq_no_quit (child, children)));
#endif
set_extent_ancestor_aux_field (e, children, Fcons (child, children));
}
DEFUN ("set-extent-parent", Fset_extent_parent, Sset_extent_parent, 2, 2, 0,
"Set the parent of EXTENT to PARENT (may be nil).\n\
See `extent-parent'.")
(extent, parent)
Lisp_Object extent, parent;
{
EXTENT e = decode_extent (extent, 0);
Lisp_Object cur_parent = extent_parent (e);
Lisp_Object rest;
XSETEXTENT (extent, e);
if (!NILP (parent))
CHECK_LIVE_EXTENT (parent, 1);
if (EQ (parent, cur_parent))
return Qnil;
for (rest = parent; !NILP (rest); rest = extent_parent (XEXTENT (rest)))
if (EQ (rest, extent))
signal_simple_error ("Circular parent chain would result", extent);
if (NILP (parent))
{
remove_extent_from_children_list (XEXTENT (cur_parent), extent);
set_extent_ancestor_aux_field (e, parent, Qnil);
e->flags.has_parent = 0;
}
else
{
add_extent_to_children_list (XEXTENT (parent), extent);
set_extent_ancestor_aux_field (e, parent, parent);
e->flags.has_parent = 1;
}
/* changing the parent also changes the properties of all children. */
extent_maybe_changed_for_redisplay (e, 1);
return Qnil;
}
/************************************************************************/
/* basic extent mutators */
/************************************************************************/
/* Note: If you track non-duplicable extents by undo, you'll get bogus
undo records for transient extents via update-extent.
For example, query-replace will do this.
*/
static void
set_extent_endpoints_1 (EXTENT extent, Memind start, Memind end)
{
#ifdef ERROR_CHECK_EXTENTS
Lisp_Object obj = extent_object (extent);
assert (start <= end);
if (BUFFERP (obj))
{
assert (valid_memind_p (XBUFFER (obj), start));
assert (valid_memind_p (XBUFFER (obj), end));
}
#endif
/* Optimization: if the extent is already where we want it to be,
do nothing. */
if (!extent_detached_p (extent) && extent_start (extent) == start &&
extent_end (extent) == end)
return;
if (extent_detached_p (extent))
{
if (extent_duplicable_p (extent))
{
Lisp_Object extent_obj;
XSETEXTENT (extent_obj, extent);
record_extent (extent_obj, 1);
}
}
else
extent_detach (extent);
set_extent_start (extent, start);
set_extent_end (extent, end);
extent_attach (extent);
}
static void
set_extent_endpoints (EXTENT extent, Bytind s, Bytind e)
{
Lisp_Object obj = extent_object (extent);
Memind start, end;
assert (!NILP (obj));
start = s < 0 ? extent_start (extent) :
extent_object_bytind_to_memind (obj, s);
end = e < 0 ? extent_end (extent) :
extent_object_bytind_to_memind (obj, e);
set_extent_endpoints_1 (extent, start, end);
}
static void
set_extent_openness (EXTENT extent, int start_open, int end_open)
{
if (start_open == -1)
start_open = extent_start_open_p (extent);
if (end_open == -1)
end_open = extent_end_open_p (extent);
extent_start_open_p (extent) = start_open;
extent_end_open_p (extent) = end_open;
/* changing the open/closedness of an extent does not affect
redisplay. */
}
void
set_extent_face (EXTENT extent, Lisp_Object face)
{
extent = extent_ancestor (extent);
extent_face (extent) = face;
extent_changed_for_redisplay (extent, 1);
}
static void
set_extent_invisible (EXTENT extent, int flag)
{
if (extent_invisible_p (extent) != flag)
{
extent_invisible_p (extent) = flag;
extent_changed_for_redisplay (extent, 1);
}
}
static void
set_extent_intangible (EXTENT extent, int flag)
{
if (extent_intangible_p (extent) != flag)
{
extent_intangible_p (extent) = flag;
extent_changed_for_redisplay (extent, 1);
}
}
static EXTENT
make_extent_internal (Lisp_Object object, Bytind from, Bytind to)
{
EXTENT extent;
extent = make_extent_detached (object);
set_extent_endpoints (extent, from, to);
return extent;
}
static EXTENT
copy_extent (EXTENT original, Bytind from, Bytind to, Lisp_Object object)
{
EXTENT e;
e = make_extent_detached (object);
if (from != 0)
set_extent_endpoints (e, from, to);
e->plist = Fcopy_sequence (original->plist);
memcpy (&e->flags, &original->flags, sizeof (e->flags));
if (e->flags.has_aux)
{
/* also need to copy the aux struct. It won't work for
this extent to share the same aux struct as the original
one. */
struct extent_auxiliary *data =
alloc_lcrecord (sizeof (struct extent_auxiliary),
lrecord_extent_auxiliary);
copy_lcrecord (data, XEXTENT_AUXILIARY (XCAR (original->plist)));
XSETEXTENT_AUXILIARY (XCAR (e->plist), data);
}
{
/* we may have just added another child to the parent extent. */
Lisp_Object parent = extent_parent (e);
if (!NILP (parent))
{
Lisp_Object extent;
XSETEXTENT (extent, e);
add_extent_to_children_list (XEXTENT (parent), extent);
}
}
/* #### it's still unclear to me that this Energize-specific junk
needs to be in here. Just use the general mechanisms, or fix
them up! --ben */
#ifdef ENERGIZE
if (energize_extent_data (original))
{
extent_plist (e) = Qnil; /* slightly antisocial... */
restore_energize_extent_state (e);
}
#endif
return e;
}
Lisp_Object Fset_extent_parent (Lisp_Object, Lisp_Object);
static void
destroy_extent (EXTENT extent)
{
Lisp_Object rest;
Lisp_Object extent_obj = Qnil;
if (!extent_detached_p (extent))
extent_detach (extent);
/* disassociate the extent from its children and parent */
LIST_LOOP (rest, extent_children (extent))
Fset_extent_parent (XCAR (rest), Qnil);
XSETEXTENT (extent_obj, extent);
Fset_extent_parent (extent_obj, Qnil);
/* mark the extent as destroyed */
extent_object (extent) = Qt;
}
void
init_buffer_extents (struct buffer *b)
{
b->extents = make_extent_list ();
b->soe = make_soe ();
}
void
uninit_buffer_extents (struct buffer *b)
{
int i;
free_soe (b->soe);
b->soe = 0;
for (i = 0; i < extent_list_num_els (b->extents); i++)
{
EXTENT e = extent_list_at (b->extents, i, 0);
/* No need to do detach_extent(). (Anyway, the SOE has already
been freed.) Just nuke the damn things. */
set_extent_start (e, 0);
set_extent_end (e, 0);
/* Don't destroy the extent here -- there may still be extent
replicas pointing to the extent. */
}
free_extent_list (b->extents);
b->extents = 0;
}
DEFUN ("make-extent", Fmake_extent, Smake_extent, 2, 3, 0,
"Make an extent for the range [FROM, TO) in BUFFER-OR-STRING.\n\
BUFFER-OR-STRING defaults to the current buffer. (Note: Currently\n\
extents over strings are not supported, but will be in the future.)\n\
Insertions at point TO will be outside of the extent; insertions at\n\
FROM will be inside the extent, causing the extent to grow. (This is\n\
the same way that markers behave.) You can change the behavior of\n\
insertions at the endpoints using `set-extent-property'. The extent is\n\
initially detached if both FROM and TO are nil, and in this case\n\
BUFFER-OR-STRING defaults to nil, meaning the extent is in no buffer\n\
and no string.")
(from, to, buffer_or_string)
Lisp_Object from, to, buffer_or_string;
{
Lisp_Object extent_obj = Qnil;
Lisp_Object obj;
if (STRINGP (buffer_or_string))
strings_not_supported ();
obj = decode_extent_object (buffer_or_string);
if (NILP (from) && NILP (to))
{
if (NILP (buffer_or_string))
obj = Qnil;
XSETEXTENT (extent_obj, make_extent_detached (obj));
}
else
{
Bytind start, end;
if (STRINGP (obj))
get_string_range (obj, from, to, &start, &end);
else
get_bufrange_bytind (XBUFFER (obj), from, to, &start, &end,
GB_ALLOW_PAST_ACCESSIBLE);
XSETEXTENT (extent_obj, make_extent_internal (obj, start, end));
}
return extent_obj;
}
DEFUN ("copy-extent", Fcopy_extent, Scopy_extent, 1, 2, 0,
"Make a copy of EXTENT. It is initially detached.\n\
Optional argument BUFFER-OR-STRING defaults to EXTENT's buffer or string.")
(extent, buffer_or_string)
Lisp_Object extent, buffer_or_string;
{
EXTENT ext = decode_extent (extent, 0);
if (NILP (buffer_or_string))
buffer_or_string = extent_object (ext);
else
buffer_or_string = decode_extent_object (buffer_or_string);
XSETEXTENT (extent, copy_extent (ext, 0, 0, buffer_or_string));
return extent;
}
DEFUN ("delete-extent", Fdelete_extent, Sdelete_extent, 1, 1, 0,
"Remove EXTENT from its buffer and destroy it.\n\
This does not modify the buffer's text, only its display properties.\n\
The extent cannot be used thereafter.")
(extent)
Lisp_Object extent;
{
EXTENT ext;
/* We do not call decode_extent() here because already-destroyed
extents are OK. */
CHECK_EXTENT (extent, 0);
ext = XEXTENT (extent);
if (!EXTENT_LIVE_P (ext))
return Qnil;
destroy_extent (ext);
return Qnil;
}
DEFUN ("detach-extent", Fdetach_extent, Sdetach_extent, 1, 1, 0,
"Remove EXTENT from its buffer in such a way that it can be re-inserted.\n\
An extent is also detached when all of its characters are all killed by a\n\
deletion, unless its `detachable' property has been unset.\n\
\n\
Extents which have the `duplicable' attribute are tracked by the undo\n\
mechanism. Detachment via `detach-extent' and string deletion is recorded,\n\
as is attachment via `insert-extent' and string insertion. Extent motion,\n\
face changes, and attachment via `make-extent' and `set-extent-endpoints'\n\
are not recorded. This means that extent changes which are to be undo-able\n\
must be performed by character editing, or by insertion and detachment of\n\
duplicable extents.")
(extent)
Lisp_Object extent;
{
EXTENT ext = decode_extent (extent, 0);
if (extent_detached_p (ext))
return extent;
if (extent_duplicable_p (ext))
record_extent (extent, 0);
extent_detach (ext);
return extent;
}
DEFUN ("set-extent-endpoints", Fset_extent_endpoints, Sset_extent_endpoints,
3, 3, 0,
"Set the endpoints of EXTENT to START, END.\n\
If START and END are null, call detach-extent on EXTENT.\n\
See documentation on `detach-extent' for a discussion of undo recording.")
(extent, start, end)
Lisp_Object extent, start, end;
{
EXTENT ext;
Bytind s, e;
Lisp_Object obj;
if (NILP (start) && NILP (end))
return Fdetach_extent (extent);
ext = decode_extent (extent, DE_MUST_HAVE_BUFFER);
obj = extent_object (ext);
if (STRINGP (obj))
get_string_range (obj, start, end, &s, &e);
else
get_bufrange_bytind (XBUFFER (obj), start, end, &s, &e,
GB_ALLOW_PAST_ACCESSIBLE);
set_extent_endpoints (ext, s, e);
return extent;
}
/************************************************************************/
/* mapping over extents */
/************************************************************************/
static unsigned int
decode_map_extents_flags (Lisp_Object flags)
{
unsigned int retval = 0;
unsigned int all_extents_specified = 0;
unsigned int in_region_specified = 0;
if (EQ (flags, Qt)) /* obsoleteness compatibility */
return ME_END_CLOSED;
if (EQ (flags, Qnil))
return 0;
if (SYMBOLP (flags))
flags = Fcons (flags, Qnil);
while (!NILP (flags))
{
Lisp_Object sym;
CHECK_CONS (flags, 0);
sym = XCAR (flags);
CHECK_SYMBOL (sym, 0);
if (EQ (sym, Qall_extents_closed) || EQ (sym, Qall_extents_open) ||
EQ (sym, Qall_extents_closed_open) ||
EQ (sym, Qall_extents_open_closed))
{
if (all_extents_specified)
error ("Only one `all-extents-*' flag may be specified");
all_extents_specified = 1;
}
if (EQ (sym, Qstart_in_region) || EQ (sym, Qend_in_region) ||
EQ (sym, Qstart_and_end_in_region) ||
EQ (sym, Qstart_or_end_in_region))
{
if (in_region_specified)
error ("Only one `*-in-region' flag may be specified");
in_region_specified = 1;
}
/* I do so love that conditional operator ... */
retval |=
EQ (sym, Qend_closed) ? ME_END_CLOSED :
EQ (sym, Qstart_open) ? ME_START_OPEN :
EQ (sym, Qall_extents_closed) ? ME_ALL_EXTENTS_CLOSED :
EQ (sym, Qall_extents_open) ? ME_ALL_EXTENTS_OPEN :
EQ (sym, Qall_extents_closed_open) ? ME_ALL_EXTENTS_CLOSED_OPEN :
EQ (sym, Qall_extents_open_closed) ? ME_ALL_EXTENTS_OPEN_CLOSED :
EQ (sym, Qstart_in_region) ? ME_START_IN_REGION :
EQ (sym, Qend_in_region) ? ME_END_IN_REGION :
EQ (sym, Qstart_and_end_in_region) ? ME_START_AND_END_IN_REGION :
EQ (sym, Qstart_or_end_in_region) ? ME_START_OR_END_IN_REGION :
EQ (sym, Qnegate_in_region) ? ME_NEGATE_IN_REGION :
(signal_simple_error ("Invalid `map-extents' flag", sym), 0);
flags = XCDR (flags);
}
return retval;
}
DEFUN ("extent-in-region-p", Fextent_in_region_p, Sextent_in_region_p, 1, 4, 0,
"Return whether EXTENT overlaps a specified region.\n\
This is equivalent to whether `map-extents' would visit EXTENT when called\n\
with these args.")
(extent, from, to, flags)
Lisp_Object extent, from, to, flags;
{
EXTENT ext;
Lisp_Object obj;
Bytind start, end;
ext = decode_extent (extent, DE_MUST_BE_ATTACHED);
obj = extent_object (ext);
if (STRINGP (obj))
strings_not_supported ();
get_bufrange_bytind (XBUFFER (obj), from, to, &start, &end, GB_ALLOW_NIL |
GB_ALLOW_PAST_ACCESSIBLE);
if (extent_in_region_p (ext, start, end, decode_map_extents_flags (flags)))
return Qt;
return Qnil;
}
struct slow_map_extents_arg
{
Lisp_Object map_arg;
Lisp_Object map_routine;
Lisp_Object result;
Lisp_Object property;
Lisp_Object value;
};
static int
slow_map_extents_function (EXTENT extent, void *arg)
{
/* This function can GC */
struct slow_map_extents_arg *closure = (struct slow_map_extents_arg *) arg;
Lisp_Object extent_obj;
XSETEXTENT (extent_obj, extent);
/* make sure this extent qualifies according to the PROPERTY
and VALUE args */
if (!NILP (closure->property))
{
Lisp_Object value = Fextent_property (extent_obj, closure->property);
if ((NILP (closure->value) && NILP (value)) ||
(!NILP (closure->value) && !EQ (value, closure->value)))
return 0;
}
closure->result = call2 (closure->map_routine, extent_obj,
closure->map_arg);
if (NILP (closure->result))
return 0;
else
return 1;
}
/* This comment supplies the doc string for map-extents.
for make-docfile to see. We cannot put this in the real DEFUN
due to limits in the Unix cpp.
DEFUN ("map-extents", Fmap_extents, Smap_extents, 1, 8, 0,
"Map FUNCTION over the extents which overlap a region in BUFFER.\n\
The region is normally bounded by [FROM, TO) (i.e. the beginning of the\n\
region is closed and the end of the region is open), but this can be\n\
changed with the FLAGS argument (see below for a complete discussion).\n\
\n\
FUNCTION is called with the arguments (extent, MAPARG). The arguments\n\
BUFFER, FROM, TO, MAPARG, and CLOSED-END are all optional and default to\n\
the current buffer, the beginning of BUFFER, the end of BUFFER, nil, and\n\
nil, respectively. MAP-EXTENTS returns the first non-nil result produced\n\
by FUNCTION, and no more calls to FUNCTION are made after it returns\n\
non-nil.\n\
\n\
If BUFFER is an extent, FROM and TO default to the extent's endpoints,\n\
and the mapping omits that extent and its predecessors. This feature\n\
supports restarting a loop based on `map-extents'.\n\
\n\
An extent overlaps the region if there is any point in the extent that is\n\
also in the region. (For the purpose of overlap, zero-length extents and\n\
regions are treated as closed on both ends regardless of their endpoints'\n\
specified open/closedness.) Note that the endpoints of an extent or region\n\
are considered to be in that extent or region if and only if the\n\
corresponding end is closed. For example, the extent [5,7] overlaps the\n\
region [2,5] because 5 is in both the extent and the region. However, (5,7]\n\
does not overlap [2,5] because 5 is not in the extent, and neither [5,7] nor\n\
(5,7] overlaps the region [2,5) because 5 is not in the region.\n\
\n\
The optional FLAGS can be a symbol or a list of one or more symbols,\n\
modifying the behavior of `map-extents'. Allow symbols are:\n\
\n\
end-closed The region's end is closed.\n\
\n\
start-open The region's start is open.\n\
\n\
all-extents-closed Treat all extents as closed on both ends for the\n\
purpose of determining whether they overlap the\n\
region, irrespective of their actual open- or\n\
closedness.\n\
all-extents-open Treat all extents as open on both ends.\n\
all-extents-closed-open Treat all extents as start-closed, end-open.\n\
all-extents-open-closed Treat all extents as start-open, end-closed.\n\
\n\
start-in-region In addition to the above conditions for extent\n\
overlap, the extent's start position must lie within\n\
the specified region. Note that, for this\n\
condition, open start positions are treated as if\n\
0.5 was added to the endpoint's value, and open\n\
end positions are treated as if 0.5 was subtracted\n\
from the endpoint's value.\n\
end-in-region The extent's end position must lie within the
region.\n\
start-and-end-in-region Both the extent's start and end positions must lie\n\
within the region.\n\
start-or-end-in-region Either the extent's start or end position must lie\n\
within the region.\n\
\n\
negate-in-region The condition specified by a `*-in-region' flag\n\
must NOT hold for the extent to be considered.\n\
\n\
\n\
At most one of `all-extents-closed', `all-extents-open',\n\
`all-extents-closed-open', and `all-extents-open-closed' may be specified.\n\
\n\
At most one of `start-in-region', `end-in-region',\n\
`start-and-end-in-region', and `start-or-end-in-region' may be specified.\n\
\n\
If optional arg PROPERTY is non-nil, only extents with that property set\n\
on them will be visited. If optional arg VALUE is non-nil, only extents\n\
whose value for that property is `eq' to VALUE will be visited.")
(function, buffer, from, to, maparg, flags, property, value)
*/
DEFUN ("map-extents", Fmap_extents, Smap_extents, 1, 8, 0, 0)
(function, buffer, from, to, maparg, flags, property, value)
Lisp_Object function, buffer, from, to, maparg, flags, property, value;
{
/* This function can GC */
struct slow_map_extents_arg closure;
unsigned int me_flags;
Bytind start, end;
struct gcpro gcpro1, gcpro2, gcpro3;
EXTENT after = 0;
struct buffer *b;
if (EXTENTP (buffer))
{
after = decode_extent (buffer, DE_MUST_BE_ATTACHED);
b = XBUFFER (extent_object (after));
if (NILP (from)) from = Fextent_start_position (buffer);
if (NILP (to)) to = Fextent_end_position (buffer);
}
else
b = decode_buffer (buffer, 0);
get_bufrange_bytind (b, from, to, &start, &end, GB_ALLOW_NIL |
GB_ALLOW_PAST_ACCESSIBLE);
me_flags = decode_map_extents_flags (flags);
if (!NILP (property))
CHECK_SYMBOL (property, 6);
GCPRO3 (function, maparg, buffer);
closure.map_arg = maparg;
closure.map_routine = function;
closure.result = Qnil;
closure.property = property;
closure.value = value;
map_extents_bytind (start, end, slow_map_extents_function,
(void *) &closure, make_buffer (b), after,
/* You never know what the user might do ... */
me_flags | ME_MIGHT_CALL_ELISP);
UNGCPRO;
return closure.result;
}
/************************************************************************/
/* mapping over extents -- other functions */
/************************************************************************/
/* ------------------------------- */
/* map-extent-children */
/* ------------------------------- */
struct slow_map_extent_children_arg
{
Lisp_Object map_arg;
Lisp_Object map_routine;
Lisp_Object result;
Lisp_Object property;
Lisp_Object value;
Bytind start_min;
Bytind prev_start;
Bytind prev_end;
};
static int
slow_map_extent_children_function (EXTENT extent, void *arg)
{
/* This function can GC */
struct slow_map_extent_children_arg *closure =
(struct slow_map_extent_children_arg *) arg;
Lisp_Object extent_obj;
Bytind start = extent_endpoint_bytind (extent, 0);
Bytind end = extent_endpoint_bytind (extent, 1);
/* Make sure the extent starts inside the region of interest,
rather than just overlaps it.
*/
if (start < closure->start_min)
return 0;
/* Make sure the extent is not a child of a previous visited one.
We know already, because of extent ordering,
that start >= prev_start, and that if
start == prev_start, then end <= prev_end.
*/
if (start == closure->prev_start)
{
if (end < closure->prev_end)
return 0;
}
else /* start > prev_start */
{
if (start < closure->prev_end)
return 0;
/* corner case: prev_end can be -1 if there is no prev */
}
XSETEXTENT (extent_obj, extent);
/* make sure this extent qualifies according to the PROPERTY
and VALUE args */
if (!NILP (closure->property))
{
Lisp_Object value = Fextent_property (extent_obj, closure->property);
if ((NILP (closure->value) && NILP (value)) ||
(!NILP (closure->value) && !EQ (value, closure->value)))
return 0;
}
closure->result = call2 (closure->map_routine, extent_obj,
closure->map_arg);
/* Since the callback may change the buffer, compute all stored
buffer positions here.
*/
closure->start_min = -1; /* no need for this any more */
closure->prev_start = extent_endpoint_bytind (extent, 0);
closure->prev_end = extent_endpoint_bytind (extent, 1);
if (NILP (closure->result))
return 0;
else
return 1;
}
DEFUN ("map-extent-children", Fmap_extent_children, Smap_extent_children,
1, 8, 0,
"Map FUNCTION over the extents in the region from FROM to TO.\n\
FUNCTION is called with arguments (extent, MAPARG). See `map-extents'\n\
for a full discussion of the arguments FROM, TO, and FLAGS.\n\
\n\
The arguments are the same as for `map-extents', but this function differs\n\
in that it only visits extents which start in the given region, and also\n\
in that, after visiting an extent E, it skips all other extents which start\n\
inside E but end before E's end.\n\
\n\
Thus, this function may be used to walk a tree of extents in a buffer:\n\
(defun walk-extents (buffer &optional ignore)\n\
(map-extent-children 'walk-extents buffer))")
(function, buffer, from, to, maparg, flags, property, value)
Lisp_Object function, buffer, from, to, maparg, flags, property, value;
{
/* This function can GC */
struct slow_map_extent_children_arg closure;
unsigned int me_flags;
Bytind start, end;
struct gcpro gcpro1, gcpro2, gcpro3;
EXTENT after = 0;
struct buffer *b;
if (EXTENTP (buffer))
{
after = decode_extent (buffer, DE_MUST_BE_ATTACHED);
b = XBUFFER (extent_object (after));
if (NILP (from)) from = Fextent_start_position (buffer);
if (NILP (to)) to = Fextent_end_position (buffer);
}
else
b = decode_buffer (buffer, 0);
get_bufrange_bytind (b, from, to, &start, &end, GB_ALLOW_NIL |
GB_ALLOW_PAST_ACCESSIBLE);
me_flags = decode_map_extents_flags (flags);
if (!NILP (property))
CHECK_SYMBOL (property, 6);
GCPRO3 (function, maparg, buffer);
closure.map_arg = maparg;
closure.map_routine = function;
closure.result = Qnil;
closure.property = property;
closure.value = value;
closure.start_min = start;
closure.prev_start = -1;
closure.prev_end = -1;
map_extents_bytind (start, end, slow_map_extent_children_function,
(void *) &closure, make_buffer (b), after,
/* You never know what the user might do ... */
me_flags | ME_MIGHT_CALL_ELISP);
UNGCPRO;
return closure.result;
}
/* ------------------------------- */
/* extent-at */
/* ------------------------------- */
/* find "smallest" matching extent containing pos -- (flag == 0) means
all extents match, else (EXTENT_FLAGS (extent) & flag) must be true;
for more than one matching extent with precisely the same endpoints,
we choose the last extent in the extents_list.
The search stops just before "before", if that is non-null.
*/
struct extent_at_arg
{
EXTENT best_match;
Memind best_start;
Memind best_end;
Lisp_Object prop;
EXTENT before;
};
static int
extent_at_mapper (EXTENT e, void *arg)
{
struct extent_at_arg *closure = (struct extent_at_arg *) arg;
if (e == closure->before)
return 1;
/* If closure->prop is non-nil, then the extent is only acceptable
if it has a non-nil value for that property. */
if (!NILP (closure->prop))
{
Lisp_Object extent;
XSETEXTENT (extent, e);
if (NILP (Fextent_property (extent, closure->prop)))
return 0;
}
{
EXTENT current = closure->best_match;
if (!current)
goto accept;
/* redundant but quick test */
else if (extent_start (current) > extent_start (e))
return 0;
/* we return the "last" best fit, instead of the first --
this is because then the glyph closest to two equivalent
extents corresponds to the "extent-at" the text just past
that same glyph */
else if (!EXTENT_LESS_VALS (e, closure->best_start,
closure->best_end))
goto accept;
else
return 0;
accept:
closure->best_match = e;
closure->best_start = extent_start (e);
closure->best_end = extent_end (e);
}
return 0;
}
DEFUN ("extent-at", Fextent_at, Sextent_at, 1, 4, 0,
"Find \"smallest\" extent at POS in BUFFER having PROPERTY set.\n\
An extent is \"at\" POS if it overlaps the region (POS, POS+1); i.e. if\n\
it covers the character after POS. \"Smallest\" means the extent\n\
that comes last in the display order; this normally means the extent\n\
whose start position is closest to POS. See `next-extent' for more\n\
information.\n\
BUFFER defaults to the current buffer.\n\
PROPERTY defaults to nil, meaning that any extent will do.\n\
Properties are attached to extents with `set-extent-property', which see.\n\
Returns nil if POS is invalid or there is no matching extent at POS.\n\
If the fourth argument BEFORE is not nil, it must be an extent; any returned\n\
extent will precede that extent. This feature allows `extent-at' to be\n\
used by a loop over extents.")
(pos, buffer, property, before)
Lisp_Object pos, buffer, property, before;
{
Bytind position;
Lisp_Object extent_obj = Qnil;
EXTENT extent;
struct buffer *buf;
struct extent_at_arg closure;
buf = decode_buffer (buffer, 0);
XSETBUFFER (buffer, buf);
position = get_bytind (buf, pos, GB_NO_ERROR_IF_BAD);
CHECK_SYMBOL (property, 0);
if (NILP (before))
extent = 0;
else
extent = decode_extent (before, DE_MUST_BE_ATTACHED);
if (extent && !EQ (buffer, extent_object (extent)))
{
XSETBUFFER (buffer, buf);
signal_simple_error ("extent not in specified buffer", buffer);
}
/* it might be argued that invalid positions should cause
errors, but the principle of least surprise dictates that
nil should be returned (extent-at is often used in
response to a mouse event, and in many cases previous events
have changed the buffer contents). */
if (!position || position == BI_BUF_Z (buf))
return Qnil;
closure.best_match = 0;
closure.prop = property;
closure.before = extent;
map_extents_bytind (position, position+1, extent_at_mapper,
(void *) &closure, make_buffer (buf), 0, ME_START_OPEN);
if (!closure.best_match)
return Qnil;
XSETEXTENT (extent_obj, closure.best_match);
return extent_obj;
}
/* ------------------------------- */
/* verify_extent_modification() */
/* ------------------------------- */
/* verify_extent_modification() is called when a buffer is modified to
check whether the modification is occuring inside a read-only extent.
*/
#ifdef ENERGIZE
extern int inside_parse_buffer; /* total kludge */
#endif
struct verify_extents_arg
{
struct buffer *buf;
Memind start;
Memind end;
};
static int
verify_extent_mapper (EXTENT extent, void *arg)
{
if (extent_read_only_p (extent))
{
struct verify_extents_arg *closure = (struct verify_extents_arg *) arg;
/* Allow deletion if the extent is completely contained in
the region being deleted.
This is important for supporting tokens which are internally
write-protected, but which can be killed and yanked as a whole.
Ignore open/closed distinctions at this point.
-- Rose
*/
if (closure->start != closure->end &&
extent_start (extent) >= closure->start &&
extent_end (extent) <= closure->end)
return 0;
{
Lisp_Object b;
XSETBUFFER (b, closure->buf);
while (1)
Fsignal (Qbuffer_read_only, (list1 (b)));
}
}
return 0;
}
void
verify_extent_modification (struct buffer *buf, Bytind from, Bytind to)
{
int closed;
struct verify_extents_arg closure;
if (inside_undo
#ifdef ENERGIZE
|| inside_parse_buffer
#endif
)
return;
/* If insertion, visit closed-endpoint extents touching the insertion
point because the text would go inside those extents. If deletion,
treat the range as open on both ends so that touching extents are not
visited. Note that we assume that an insertion is occurring if the
changed range has zero length, and a deletion otherwise. This
fails if a change (i.e. non-insertion, non-deletion) is happening.
As far as I know, this doesn't currently occur in XEmacs. --ben */
closed = (from==to);
closure.buf = buf;
closure.start = bytind_to_memind (buf, from);
closure.end = bytind_to_memind (buf, to);
map_extents_bytind (from, to, verify_extent_mapper, (void *) &closure,
make_buffer (buf), 0,
closed ? ME_END_CLOSED : ME_START_OPEN);
}
/* ------------------------------------ */
/* process_extents_for_insertion() */
/* ------------------------------------ */
struct process_extents_for_insertion_arg
{
Bytind opoint;
int length;
struct buffer *buf;
};
/* A region of length LENGTH was just inserted at OPOINT. Modify all
of the extents as required for the insertion, based on their
start-open/end-open properties.
*/
static int
process_extents_for_insertion_mapper (EXTENT extent, void *arg)
{
struct process_extents_for_insertion_arg *closure =
(struct process_extents_for_insertion_arg *) arg;
struct buffer *buf = closure->buf;
Memind index = bytind_to_memind (buf, closure->opoint);
/* When this function is called, one end of the newly-inserted text should
be adjacent to some endpoint of the extent, or disjoint from it. If
the insertion overlaps any existing extent, something is wrong.
*/
#ifdef ERROR_CHECK_EXTENTS
if (extent_start (extent) > index &&
extent_start (extent) < index + closure->length)
abort ();
if (extent_end (extent) > index &&
extent_end (extent) < index + closure->length)
abort ();
#endif
/* The extent-adjustment code adjusted the extent's endpoints as if
they were markers -- endpoints at the gap (i.e. the insertion
point) go to the left of the insertion point, which is correct
for [) extents. We need to fix the other kinds of extents.
Note that both conditions below will hold for zero-length (]
extents at the gap. Zero-length () extents would get adjusted
such that their start is greater than their end; we treat them
as [) extents. This is unfortunately an inelegant part of the
extent model, but there is no way around it. */
{
Memind new_start, new_end;
new_start = extent_start (extent);
new_end = extent_end (extent);
if (index == extent_start (extent) && extent_start_open_p (extent) &&
/* coerce zero-length () extents to [) */
new_start != new_end)
new_start += closure->length;
if (index == extent_end (extent) && !extent_end_open_p (extent))
new_end += closure->length;
set_extent_endpoints_1 (extent, new_start, new_end);
}
return 0;
}
void
process_extents_for_insertion (struct buffer *buf, Bytind opoint, int length)
{
struct process_extents_for_insertion_arg closure;
closure.opoint = opoint;
closure.length = length;
closure.buf = buf;
map_extents_bytind (opoint, opoint + length,
process_extents_for_insertion_mapper,
(void *) &closure, make_buffer (buf), 0,
ME_END_CLOSED | ME_MIGHT_MODIFY_EXTENTS |
ME_INCLUDE_INTERNAL);
}
/* ------------------------------------ */
/* process_extents_for_deletion() */
/* ------------------------------------ */
struct process_extents_for_deletion_arg
{
Memind start, end;
int destroy_included_extents;
};
/* This function is called when we're about to delete the range [from, to].
Detach all of the extents that are completely inside the range [from, to],
if they're detachable or open-open. */
static int
process_extents_for_deletion_mapper (EXTENT extent, void *arg)
{
struct process_extents_for_deletion_arg *closure =
(struct process_extents_for_deletion_arg *) arg;
/* If the extent lies completely within the range that
is being deleted, then nuke the extent if it's detachable
(otherwise, it will become a zero-length extent). */
if (closure->start <= extent_start (extent) &&
extent_end (extent) <= closure->end)
{
if (extent_detachable_p (extent))
{
if (closure->destroy_included_extents)
destroy_extent (extent);
else
extent_detach (extent);
}
}
return 0;
}
/* DESTROY_THEM means destroy the extents instead of just deleting them.
It is unused currently, but perhaps might be used (there used to
be a function process_extents_for_destruction(), #if 0'd out,
that did the equivalent). */
void
process_extents_for_deletion (struct buffer *buf, Bytind from,
Bytind to, int destroy_them)
{
struct process_extents_for_deletion_arg closure;
closure.start = bytind_to_memind (buf, from);
closure.end = bytind_to_memind (buf, to);
closure.destroy_included_extents = destroy_them;
map_extents_bytind (from, to, process_extents_for_deletion_mapper,
(void *) &closure, make_buffer (buf), 0,
ME_END_CLOSED | ME_MIGHT_MODIFY_EXTENTS);
}
/************************************************************************/
/* extent properties */
/************************************************************************/
/* return the value of PROPERTY in EXTENT's property list. */
Lisp_Object
extent_getf (EXTENT extent, Lisp_Object property)
{
Lisp_Object tail = extent_plist (extent);
Lisp_Object value;
assert (SYMBOLP (property));
return internal_getf (tail, property, &value) ? value : Qnil;
}
/* set the value of PROPERTY in EXTENT's property list to VALUE. */
void
extent_putf (EXTENT extent, Lisp_Object property, Lisp_Object value)
{
Lisp_Object *location = extent_plist_addr (extent);
assert (SYMBOLP (property));
internal_putf (location, property, value);
}
void
set_extent_glyph (EXTENT extent, Lisp_Object glyph, int endp,
unsigned int layout)
{
extent = extent_ancestor (extent);
if (!endp)
{
set_extent_begin_glyph (extent, glyph);
extent_begin_glyph_layout (extent) = layout;
}
else
{
set_extent_end_glyph (extent, glyph);
extent_end_glyph_layout (extent) = layout;
}
extent_changed_for_redisplay (extent, 1);
}
static Lisp_Object
glyph_layout_to_symbol (unsigned int layout)
{
switch (layout)
{
case GL_TEXT: return Qtext;
case GL_OUTSIDE_MARGIN: return Qoutside_margin;
case GL_INSIDE_MARGIN: return Qinside_margin;
case GL_WHITESPACE: return Qwhitespace;
default: abort ();
}
return Qnil; /* shut up compiler */
}
static unsigned int
symbol_to_glyph_layout (Lisp_Object layout_obj)
{
unsigned int layout = 0;
if (NILP (layout_obj))
layout = GL_TEXT;
else
{
CHECK_SYMBOL (layout_obj, 0);
if (EQ (Qoutside_margin, layout_obj))
layout = GL_OUTSIDE_MARGIN;
else if (EQ (Qinside_margin, layout_obj))
layout = GL_INSIDE_MARGIN;
else if (EQ (Qwhitespace, layout_obj))
layout = GL_WHITESPACE;
else if (EQ (Qtext, layout_obj))
layout = GL_TEXT;
else
signal_simple_error ("unknown glyph layout type", layout_obj);
}
return layout;
}
static Lisp_Object
set_extent_glyph_1 (Lisp_Object extent_obj, Lisp_Object glyph, int endp,
Lisp_Object layout_obj)
{
EXTENT extent = decode_extent (extent_obj, DE_MUST_HAVE_BUFFER);
unsigned int layout = symbol_to_glyph_layout (layout_obj);
/* Make sure we've actually been given a glyph or it's nil (meaning
we're deleting a glyph from an extent. */
if (!NILP (glyph))
CHECK_GLYPH (glyph, 0);
set_extent_glyph (extent, glyph, endp, layout);
return glyph;
}
DEFUN ("set-extent-begin-glyph", Fset_extent_begin_glyph,
Sset_extent_begin_glyph, 2, 3, 0,
"Display a bitmap, subwindow or string at the beginning of EXTENT.\n\
BEGIN-GLYPH must be a glyph object. The layout policy defaults to `text'.")
(extent, begin_glyph, layout)
Lisp_Object extent, begin_glyph, layout;
{
return set_extent_glyph_1 (extent, begin_glyph, 0, layout);
}
DEFUN ("set-extent-end-glyph", Fset_extent_end_glyph,
Sset_extent_end_glyph, 2, 3, 0,
"Display a bitmap, subwindow or string at the end of the EXTENT.\n\
END-GLYPH must be a glyph object. The layout policy defaults to `text'.")
(extent, end_glyph, layout)
Lisp_Object extent, end_glyph, layout;
{
return set_extent_glyph_1 (extent, end_glyph, 1, layout);
}
DEFUN ("extent-begin-glyph", Fextent_begin_glyph, Sextent_begin_glyph, 1, 1, 0,
"Return the glyph object displayed at the beginning of EXTENT.\n\
If there is none, nil is returned.")
(extent_obj)
Lisp_Object extent_obj;
{
return extent_begin_glyph (decode_extent (extent_obj, 0));
}
DEFUN ("extent-end-glyph", Fextent_end_glyph, Sextent_end_glyph, 1, 1, 0,
"Return the glyph object displayed at the end of EXTENT.\n\
If there is none, nil is returned.")
(extent_obj)
Lisp_Object extent_obj;
{
return extent_end_glyph (decode_extent (extent_obj, 0));
}
DEFUN ("set-extent-begin-glyph-layout", Fset_extent_begin_glyph_layout,
Sset_extent_begin_glyph_layout, 2, 2, 0,
"Set the layout policy of the given extent's begin glyph.\n\
Access this using the `extent-begin-glyph-layout' function.")
(extent, layout)
Lisp_Object extent, layout;
{
EXTENT e = decode_extent (extent, 0);
e = extent_ancestor (e);
extent_begin_glyph_layout (e) = symbol_to_glyph_layout (layout);
extent_maybe_changed_for_redisplay (e, 1);
return layout;
}
DEFUN ("set-extent-end-glyph-layout", Fset_extent_end_glyph_layout,
Sset_extent_end_glyph_layout, 2, 2, 0,
"Set the layout policy of the given extent's end glyph.\n\
Access this using the `extent-end-glyph-layout' function.")
(extent, layout)
Lisp_Object extent, layout;
{
EXTENT e = decode_extent (extent, 0);
e = extent_ancestor (e);
extent_end_glyph_layout (e) = symbol_to_glyph_layout (layout);
extent_maybe_changed_for_redisplay (e, 1);
return layout;
}
DEFUN ("extent-begin-glyph-layout", Fextent_begin_glyph_layout,
Sextent_begin_glyph_layout, 1, 1, 0,
"Return the layout policy associated with the given extent's begin glyph.\n\
Set this using the `set-extent-begin-glyph-layout' function.")
(extent)
Lisp_Object extent;
{
EXTENT e = decode_extent (extent, 0);
return glyph_layout_to_symbol (extent_begin_glyph_layout (e));
}
DEFUN ("extent-end-glyph-layout", Fextent_end_glyph_layout,
Sextent_end_glyph_layout, 1, 1, 0,
"Return the layout policy associated with the given extent's end glyph.\n\
Set this using the `set-extent-end-glyph-layout' function.")
(extent)
Lisp_Object extent;
{
EXTENT e = decode_extent (extent, 0);
return glyph_layout_to_symbol (extent_end_glyph_layout (e));
}
DEFUN ("set-extent-priority", Fset_extent_priority, Sset_extent_priority,
2, 2, 0,
"Changes the display priority of EXTENT.\n\
When the extent attributes are being merged for display, the priority\n\
is used to determine which extent takes precedence in the event of a\n\
conflict (two extents whose faces both specify font, for example: the\n\
font of the extent with the higher priority will be used).\n\
Extents are created with priority 0; priorities may be negative.")
(extent, pri)
Lisp_Object extent, pri;
{
EXTENT e = decode_extent (extent, 0);
CHECK_INT (pri, 0);
e = extent_ancestor (e);
set_extent_priority (e, XINT (pri));
extent_maybe_changed_for_redisplay (e, 1);
return pri;
}
DEFUN ("extent-priority", Fextent_priority, Sextent_priority, 1, 1, 0,
"Return the display priority of EXTENT; see `set-extent-priority'.")
(extent)
Lisp_Object extent;
{
EXTENT e = decode_extent (extent, 0);
return make_number (extent_priority (e));
}
DEFUN ("set-extent-property", Fset_extent_property, Sset_extent_property,
3, 3, 0,
"Change a property of an extent.\n\
PROPERTY may be any symbol; the value stored may be accessed with\n\
the `extent-property' function.\n\
The following symbols have predefined meanings:\n\
\n\
detached Removes the extent from its buffer; setting this is the same\n\
as calling `detach-extent'.\n\
\n\
destroyed Removes the extent from its buffer, and makes it unusable in\n\
the future; this is the same calling `delete-extent'.\n\
\n\
priority Change redisplay priority; same as `set-extent-priority'.\n\
\n\
start-open Whether the set of characters within the extent is treated\n\
being open on the left, that is, whether the start position\n\
is an exclusive, rather than inclusive, boundary. If true,\n\
then characters inserted exactly at the beginning of the\n\
extent will remain outside of the extent; otherwise they\n\
will go into the extent, extending it.\n\
\n\
end-open Whether the set of characters within the extent is treated\n\
being open on the right, that is, whether the end position\n\
is an exclusive, rather than inclusive, boundary. If true,\n\
then characters inserted exactly at the end of the extent\n\
will remain outside of the extent; otherwise they will go\n\
into the extent, extending it.\n\
\n\
By default, extents have the `end-open' but not the\n\
`start-open' property set.\n\
\n\
read-only Text within this extent will be unmodifiable.\n\
\n\
detachable Whether the extent gets detached (as with `detach-extent')\n\
when all the text within the extent is deleted. This\n\
is true by default. If this property is not set, the\n\
extent becomes a zero-length extent when its text is\n\
deleted. (In such a case, the `start-open' property is\n\
automatically removed if both the `start-open' and\n\
`end-open' properties are set, since zero-length extents\n\
open on both ends are not allowed.)\n\
\n\
face The face in which to display the text. Setting this is the\n\
same as calling `set-extent-face'.\n\
\n\
highlight Highlight the extent when the mouse moves over it.\n\
\n\
duplicable Whether this extent should be copied into strings, so that\n\
kill, yank, and undo commands will restore or copy it.\n\
\n\
unique Meaningful only in conjunction with `duplicable'. When this\n\
is set, there may be only one instance of this extent\n\
attached at a time: if it is copied to the kill ring and\n\
then yanked, the extent is not copied. If, however, it is\n\
killed (removed from the buffer) and then yanked, it will\n\
be re-attached at the new position.\n\
\n\
invisible Text under this extent is treated as not present for the\n\
purpose of redisplay. The text is still visible to other\n\
functions that examine a buffer's text, however.\n\
\n\
intangible (not yet implemented) Text under this extent is treated as\n\
not present. Neither redisplay nor any other functions that\n\
examine a buffer's text will see the text under this extent.\n\
\n\
keymap This keymap is consulted for mouse clicks on this extent, or\n\
keypresses made while point is within the extent.\n\
\n\
copy-function This is a hook that is run when a duplicable extent is about\n\
to be copied from a buffer to a string (or the kill ring).\n\
It is called with three arguments, the extent, and the\n\
buffer-positions within it which are being copied. If this\n\
function returns nil, then the extent will not be copied;\n\
otherwise it will.\n\
\n\
paste-function This is a hook that is run when a duplicable extent is\n\
about to be copied from a string (or the kill ring) into a\n\
buffer. It is called with three arguments, the original\n\
extent, and the buffer positions which the copied extent\n\
will occupy. (This hook is run after the corresponding text\n\
has already been inserted into the buffer.) Note that the\n\
extent argument may be detached when this function is run.\n\
If this function returns nil, no extent will be inserted.\n\
Otherwise, there will be an extent covering the range in\n\
question.\n\
\n\
If the original extent is not attached to a buffer, then it\n\
will be re-attached at this range. Otherwise, a copy will\n\
be made, and that copy attached here.\n\
\n\
The copy-function and paste-function are meaningful only for\n\
extents with the `duplicable' flag set, and if they are not\n\
specified, behave as if `t' was the returned value. When\n\
these hooks are invoked, the current buffer is the buffer\n\
which the extent is being copied from/to, respectively.")
(extent, property, value)
Lisp_Object extent, property, value;
{
/* This function can GC if property is `keymap' */
EXTENT e = decode_extent (extent, 0);
CHECK_SYMBOL (property, 0);
if (EQ (property, Qread_only))
extent_read_only_p (e) = !NILP (value);
else if (EQ (property, Qhighlight))
extent_highlight_p (e) = !NILP (value);
else if (EQ (property, Qunique))
extent_unique_p (e) = !NILP (value);
else if (EQ (property, Qduplicable))
extent_duplicable_p (e) = !NILP (value);
else if (EQ (property, Qinvisible))
{
set_extent_invisible (e, !NILP (value));
}
else if (EQ (property, Qintangible))
{
set_extent_intangible (e, !NILP (value));
}
else if (EQ (property, Qdetachable))
extent_detachable_p (e) = !NILP (value);
else if (EQ (property, Qdetached))
{
if (NILP (value)) error ("can only set `detached' to t");
Fdetach_extent (extent);
}
else if (EQ (property, Qdestroyed))
{
if (NILP (value)) error ("can only set `destroyed' to t");
Fdelete_extent (extent);
}
else if (EQ (property, Qpriority))
{
Fset_extent_priority (extent, value);
}
else if (EQ (property, Qface))
{
Fset_extent_face (extent, value);
}
else if (EQ (property, Qbegin_glyph_layout))
{
Fset_extent_begin_glyph_layout (extent, value);
}
else if (EQ (property, Qend_glyph_layout))
{
Fset_extent_end_glyph_layout (extent, value);
}
/* For backwards compatibility. We use begin glyph because it is by
far the more used of the two. */
else if (EQ (property, Qglyph_layout))
{
Fset_extent_begin_glyph_layout (extent, value);
}
else if (EQ (property, Qbegin_glyph))
Fset_extent_begin_glyph (extent, value, Qnil);
else if (EQ (property, Qend_glyph))
Fset_extent_end_glyph (extent, value, Qnil);
else if (EQ (property, Qstart_open) ||
EQ (property, Qend_open) ||
EQ (property, Qstart_closed) ||
EQ (property, Qend_closed))
{
int start_open = -1, end_open = -1;
if (EQ (property, Qstart_open))
start_open = !NILP (value);
else if (EQ (property, Qend_open))
end_open = !NILP (value);
/* Support (but don't document...) the obvious antonyms. */
else if (EQ (property, Qstart_closed))
start_open = NILP (value);
else
end_open = NILP (value);
set_extent_openness (e, start_open, end_open);
}
else
{
#ifdef ENERGIZE
if (EQ (property, Qenergize))
error ("Thou shalt not change the `energize' extent property");
#endif
if (EQ (property, Qkeymap))
while (NILP (Fkeymapp (value)))
value = wrong_type_argument (Qkeymapp, value);
extent_putf (e, property, value);
}
return value;
}
DEFUN ("extent-property", Fextent_property, Sextent_property, 2, 2, 0,
"Return EXTENT's value for property PROPERTY.\n\
See `set-extent-property' for the built-in property names.")
(extent, property)
Lisp_Object extent, property;
{
EXTENT e = decode_extent (extent, 0);
CHECK_SYMBOL (property, 0);
if (EQ (property, Qdetached))
return (extent_detached_p (e) ? Qt : Qnil);
else if (EQ (property, Qdestroyed))
return (!EXTENT_LIVE_P (e) ? Qt : Qnil);
#define RETURN_FLAG(flag) \
return (extent_normal_field (e, flag) ? Qt : Qnil)
else if (EQ (property, Qstart_open)) RETURN_FLAG (start_open);
else if (EQ (property, Qend_open)) RETURN_FLAG (end_open);
else if (EQ (property, Qread_only)) RETURN_FLAG (read_only);
else if (EQ (property, Qhighlight)) RETURN_FLAG (highlight);
else if (EQ (property, Qunique)) RETURN_FLAG (unique);
else if (EQ (property, Qduplicable)) RETURN_FLAG (duplicable);
else if (EQ (property, Qinvisible)) RETURN_FLAG (invisible);
else if (EQ (property, Qintangible)) RETURN_FLAG (intangible);
else if (EQ (property, Qdetachable)) RETURN_FLAG (detachable);
#undef RETURN_FLAG
/* Support (but don't document...) the obvious antonyms. */
else if (EQ (property, Qstart_closed))
return (extent_start_open_p (e) ? Qnil : Qt);
else if (EQ (property, Qend_closed))
return (extent_end_open_p (e) ? Qnil : Qt);
else if (EQ (property, Qpriority))
return make_number (extent_priority (e));
else if (EQ (property, Qface))
return Fextent_face (extent);
else if (EQ (property, Qbegin_glyph_layout))
return Fextent_begin_glyph_layout (extent);
else if (EQ (property, Qend_glyph_layout))
return Fextent_end_glyph_layout (extent);
/* For backwards compatibility. We use begin glyph because it is by
far the more used of the two. */
else if (EQ (property, Qglyph_layout))
return Fextent_begin_glyph_layout (extent);
else if (EQ (property, Qbegin_glyph))
return extent_begin_glyph (e);
else if (EQ (property, Qend_glyph))
return extent_end_glyph (e);
else
return extent_getf (e, property);
}
DEFUN ("extent-properties", Fextent_properties, Sextent_properties, 1, 1, 0,
"Return a property list of the attributes of the given extent.\n\
Do not modify this list; use `set-extent-property' instead.")
(extent)
Lisp_Object extent;
{
EXTENT e, anc;
Lisp_Object result, face, anc_obj = Qnil;
CHECK_EXTENT (extent, 0);
e = XEXTENT (extent);
if (!EXTENT_LIVE_P (e))
return Fcons (Qdestroyed, Fcons (Qt, Qnil));
anc = extent_ancestor (e);
XSETEXTENT (anc_obj, anc);
/* For efficiency, use the ancestor for all properties except detached */
result = extent_plist (anc);
face = Fextent_face (anc_obj);
if (!NILP (face))
result = Fcons (Qface, Fcons (face, result));
/* For now continue to include this for backwards compatibility. */
if (extent_begin_glyph_layout (anc) != GL_TEXT)
result = Fcons (Qglyph_layout,
glyph_layout_to_symbol (extent_begin_glyph_layout (anc)));
if (extent_begin_glyph_layout (anc) != GL_TEXT)
result = Fcons (Qbegin_glyph_layout,
glyph_layout_to_symbol (extent_begin_glyph_layout (anc)));
if (extent_end_glyph_layout (anc) != GL_TEXT)
result = Fcons (Qend_glyph_layout,
glyph_layout_to_symbol (extent_end_glyph_layout (anc)));
if (!NILP (extent_end_glyph (anc)))
result = Fcons (Qend_glyph, Fcons (extent_end_glyph (anc), result));
if (!NILP (extent_begin_glyph (anc)))
result = Fcons (Qbegin_glyph, Fcons (extent_begin_glyph (anc), result));
if (extent_priority (anc) != 0)
result = Fcons (Qpriority, Fcons (make_number (extent_priority (anc)),
result));
#define CONS_FLAG(flag, sym) if (extent_normal_field (anc, flag)) \
result = Fcons (sym, Fcons (Qt, result))
CONS_FLAG (end_open, Qend_open);
CONS_FLAG (start_open, Qstart_open);
CONS_FLAG (invisible, Qinvisible);
CONS_FLAG (intangible, Qintangible);
CONS_FLAG (detachable, Qdetachable);
CONS_FLAG (duplicable, Qduplicable);
CONS_FLAG (unique, Qunique);
CONS_FLAG (highlight, Qhighlight);
CONS_FLAG (read_only, Qread_only);
#undef CONS_FLAG
/* detached is not an inherited property */
if (extent_detached_p (e))
result = Fcons (Qdetached, Fcons (Qt, result));
return result;
}
/************************************************************************/
/* highlighting */
/************************************************************************/
/* The display code looks into the Vlast_highlighted_extent variable to
correctly display highlighted extents. This updates that variable,
and marks the appropriate buffers as needing some redisplay.
*/
static void
do_highlight (Lisp_Object extent_obj, int highlight_p)
{
if (( highlight_p && (EQ (Vlast_highlighted_extent, extent_obj))) ||
(!highlight_p && (EQ (Vlast_highlighted_extent, Qnil))))
return;
if (EXTENTP (Vlast_highlighted_extent) &&
EXTENT_LIVE_P (XEXTENT (Vlast_highlighted_extent)))
{
/* do not recurse on descendants. Only one extent is highlighted
at a time. */
extent_changed_for_redisplay (XEXTENT (Vlast_highlighted_extent), 0);
}
Vlast_highlighted_extent = Qnil;
if (!NILP (extent_obj)
&& BUFFERP (extent_object (XEXTENT (extent_obj)))
&& highlight_p)
{
extent_changed_for_redisplay (XEXTENT (extent_obj), 0);
Vlast_highlighted_extent = extent_obj;
}
}
DEFUN ("force-highlight-extent", Fforce_highlight_extent,
Sforce_highlight_extent, 1, 2, 0,
"Highlight or unhighlight the given extent.\n\
If the second arg is non-nil, it will be highlighted, else dehighlighted.\n\
This is the same as `highlight-extent', except that it will work even\n\
on extents without the 'highlight property.")
(extent_obj, highlight_p)
Lisp_Object extent_obj, highlight_p;
{
if (NILP (extent_obj))
highlight_p = Qnil;
else
XSETEXTENT (extent_obj, decode_extent (extent_obj, DE_MUST_BE_ATTACHED));
do_highlight (extent_obj, !NILP (highlight_p));
return Qnil;
}
DEFUN ("highlight-extent", Fhighlight_extent, Shighlight_extent, 1, 2, 0,
"Highlight the given extent, if it is highlightable\n(\
that is, if it has the 'highlight property).\n\
If the second arg is non-nil, it will be highlighted, else dehighlighted.\n\
Highlighted extents are displayed as if they were merged with the 'highlight\n\
face.")
(extent_obj, highlight_p)
Lisp_Object extent_obj, highlight_p;
{
if (EXTENTP (extent_obj) && !extent_highlight_p (XEXTENT (extent_obj)))
return Qnil;
else
return (Fforce_highlight_extent (extent_obj, highlight_p));
}
/************************************************************************/
/* extent replicas */
/************************************************************************/
/* #### All of this shit needs to be reviewed. I personally think that
extent replicas should be trashed and extents should just be extended
so they work over strings as well as buffers. --ben */
/* copy/paste hooks */
static int
run_extent_copy_paste_internal (EXTENT e, Bufpos from, Bufpos to,
Lisp_Object buffer,
Lisp_Object prop)
{
/* This function can GC */
Lisp_Object extent;
Lisp_Object copy_fn;
XSETEXTENT (extent, e);
copy_fn = Fextent_property (extent, prop);
if (!NILP (copy_fn))
{
Lisp_Object flag;
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (extent, copy_fn, buffer);
flag = call3_in_buffer (XBUFFER (buffer), copy_fn, extent,
make_number (from), make_number (to));
UNGCPRO;
if (NILP (flag) || !EXTENT_LIVE_P (XEXTENT (extent)))
return 0;
}
return 1;
}
static int
run_extent_copy_function_bufpos (EXTENT e, Bufpos from, Bufpos to)
{
/* This function can GC */
return run_extent_copy_paste_internal (e, from, to, extent_object (e),
Qcopy_function);
}
static int
run_extent_paste_function (EXTENT e, Bytind from, Bytind to,
struct buffer *buf)
{
/* This function can GC */
return run_extent_copy_paste_internal (e, bytind_to_bufpos (buf, from),
bytind_to_bufpos (buf, to),
make_buffer (buf),
Qpaste_function);
}
static void
update_extent (EXTENT extent, Bytind from, Bytind to)
{
set_extent_endpoints (extent, from, to);
#ifdef ENERGIZE
restore_energize_extent_state (extent);
#endif
}
/* Insert an extent, usually from the dup_list of a string which
has just been inserted.
This code does not handle the case of undo.
*/
static Lisp_Object
insert_extent (EXTENT extent, Bytind new_start, Bytind new_end,
struct buffer *buf, int run_hooks)
{
/* This function can GC */
Lisp_Object tmp;
if (!BUFFERP (extent_object (extent)))
goto copy_it;
if (XBUFFER (extent_object (extent)) != buf)
goto copy_it;
if (extent_detached_p (extent))
{
if (run_hooks &&
!run_extent_paste_function (extent, new_start, new_end, buf))
/* The paste-function said don't re-attach this extent here. */
return Qnil;
else
update_extent (extent, new_start, new_end);
}
else
{
Bytind exstart = extent_endpoint_bytind (extent, 0);
Bytind exend = extent_endpoint_bytind (extent, 1);
if (exend < new_start || exstart > new_end)
goto copy_it;
else
{
new_start = min (exstart, new_start);
new_end = max (exend, new_end);
if (exstart != new_start || exend != new_end)
update_extent (extent, new_start, new_end);
}
}
XSETEXTENT (tmp, extent);
return tmp;
copy_it:
if (run_hooks &&
!run_extent_paste_function (extent, new_start, new_end, buf))
/* The paste-function said don't attach a copy of the extent here. */
return Qnil;
else
{
XSETEXTENT (tmp, copy_extent (extent, new_start, new_end,
make_buffer (buf)));
return tmp;
}
}
DEFUN ("insert-extent", Finsert_extent, Sinsert_extent, 1, 4, 0,
"Insert EXTENT from START to END in the current buffer.\n\
This operation does not insert any characters,\n\
but otherwise acts like `insert' of a string whose\n\
string-extent-data calls for EXTENT to be inserted.\n\
Returns the newly-inserted extent.\n\
The fourth arg, NO-HOOKS, can be used to inhibit the running of the\n\
extent's `paste-function' property if it has one.\n\
See documentation on `detach-extent' for a discussion of undo recording.")
(extent, start, end, no_hooks)
Lisp_Object extent, start, end, no_hooks;
{
EXTENT ext = decode_extent (extent, 0);
Lisp_Object copy;
Bytind s, e;
get_bufrange_bytind (current_buffer, start, end, &s, &e,
GB_ALLOW_PAST_ACCESSIBLE);
copy = insert_extent (ext, s, e, current_buffer, NILP (no_hooks));
if (EXTENTP (copy))
{
if (extent_duplicable_p (XEXTENT (copy)))
record_extent (copy, 1);
}
return copy;
}
/* #### A lot of this stuff is going to change, don't use it yet -- jwz */
DEFUN ("string-extent-data", Fstring_extent_data, Sstring_extent_data, 1, 1, 0,
"Return the saved extent data associated with the given string.\n\
\n\
NOTE: this function may go away in the future, in favor of making\n\
`map-extents' accept a string as an argument.\n\
\n\
The format is a list of extent-replica objects, each with an extent\n\
and start and end positions within the string itself.\n\
Set this using the `set-string-extent-data' function.\n\
\n\
The `concat' function logically concatenates this list, reconstructing\n\
the extent information with adjusted start and end positions.\n\
\n\
When `buffer-substring' or a similar function creates a string,\n\
it stores an entry on this list for every `duplicable' extent overlapping\n\
the string. See `set-extent-property'.\n\
\n\
When `insert' or a similar function inserts the string into a buffer,\n\
each saved extent is copied into the buffer. If the saved extent is\n\
already in the buffer at an adjacent location, it is extended. If the\n\
saved extent is detached from the buffer, it is reattached. If the saved\n\
extent is already attached, or is detached from a different buffer, it is\n\
copied as if by `copy-extent', and the extent's `paste-function' is\n\
consulted. This entire sequence of events is also available in the\n\
function `insert-extent'.")
(string)
Lisp_Object string;
{
CHECK_STRING (string, 0);
return string_dups (XSTRING (string));
}
DEFUN ("set-string-extent-data", Fset_string_extent_data,
Sset_string_extent_data, 2, 2, 0,
"Set the saved extent data associated with the given string.\n\
Access this using the `string-extent-data' function.")
(string, data)
Lisp_Object string, data;
{
CHECK_STRING (string, 0);
CHECK_LIST (data, 1);
CHECK_IMPURE (string);
set_string_dups (XSTRING (string), data);
return string;
}
static EXTENT_REPLICA
decode_extent_replica (Lisp_Object obj)
{
CHECK_LIVE_EXTENT_REPLICA (obj, 0);
return XEXTENT_REPLICA (obj);
}
/* Extent replica goo.
This is a read-only data structure.
As far as the Lisp programmer is concerned, it is used ONLY as a carrier for
string-extent-data information.
*/
DEFUN ("make-extent-replica", Fmake_extent_replica, Smake_extent_replica,
3, 3, 0,
"Make an object suitable for use with `set-string-extent-data'.\n\
The arguments are EXTENT, START, and END.\n\
There are no mutator functions for this data structure, only accessors.")
(extent, start, end)
Lisp_Object extent, start, end;
{
EXTENT_REPLICA dup;
Lisp_Object res;
CHECK_LIVE_EXTENT (extent, 0);
CHECK_INT_COERCE_MARKER (start, 1);
CHECK_INT_COERCE_MARKER (end, 2);
dup = make_extent_replica (extent, XINT (start), XINT (end));
XSETEXTENT_REPLICA (res, dup);
return res;
}
DEFUN ("extent-replica-p", Fextent_replica_p, Sextent_replica_p, 1, 1, 0,
"T if OBJECT is an extent replica.")
(object)
Lisp_Object object;
{
if (EXTENT_REPLICAP (object))
return Qt;
return Qnil;
}
DEFUN ("extent-replica-live-p", Fextent_replica_live_p, Sextent_replica_live_p,
1, 1, 0,
"T if OBJECT is an extent replica that has not been destroyed.")
(object)
Lisp_Object object;
{
if (EXTENT_REPLICA_LIVE_P (XEXTENT_REPLICA (object)))
return Qt;
return Qnil;
}
DEFUN ("extent-replica-extent", Fextent_replica_extent, Sextent_replica_extent,
1, 1, 0,
"Return the extent of the specified extent replica.\n\
See `make-extent-replica'.")
(extent_replica)
Lisp_Object extent_replica;
{
return extent_replica_extent (decode_extent_replica (extent_replica));
}
DEFUN ("extent-replica-start", Fextent_replica_start, Sextent_replica_start,
1, 1, 0,
"Return the start of the specified extent replica.\n\
See `make-extent-replica'.")
(extent_replica)
Lisp_Object extent_replica;
{
return make_number (extent_replica_start
(decode_extent_replica (extent_replica)));
}
DEFUN ("extent-replica-end", Fextent_replica_end, Sextent_replica_end,
1, 1, 0,
"Return the end of the specified extent replica.\n\
See `make-extent-replica'.")
(extent_replica)
Lisp_Object extent_replica;
{
return make_number (extent_replica_end
(decode_extent_replica (extent_replica)));
}
/* replicating extents */
struct replicate_extents_arg
{
Bufpos from;
Charcount length;
struct buffer *buf;
Lisp_Object head;
Lisp_Object nconc_cell;
};
static int
replicate_extents_mapper (EXTENT extent, void *arg)
{
/* This function can GC */
struct replicate_extents_arg *closure =
(struct replicate_extents_arg *) arg;
Lisp_Object head = closure->head;
Lisp_Object tail = closure->nconc_cell;
Charcount start = extent_endpoint_bufpos (extent, 0) - closure->from;
Charcount end = extent_endpoint_bufpos (extent, 1) - closure->from;
if (inside_undo || extent_duplicable_p (extent))
{
start = max (start, 0);
end = min (end, closure->length);
/* Run the copy-function to give an extent the option of
not being copied into the string (or kill ring).
*/
if (extent_duplicable_p (extent) &&
!run_extent_copy_function_bufpos (extent,
start + closure->from,
end + closure->from))
return 0;
/* Make a dup and put it on the string-extent-data. */
{
Lisp_Object new_cell;
Lisp_Object replica;
EXTENT_REPLICA dup;
XSETEXTENT (replica, extent);
dup = make_extent_replica (replica, start, end);
XSETEXTENT_REPLICA (replica, dup);
new_cell = Fcons (replica, Qnil);
if (NILP (head))
closure->head = new_cell;
else
Fsetcdr (tail, new_cell);
closure->nconc_cell = new_cell;
}
}
return 0;
}
Lisp_Object
replicate_extents (struct buffer *buf, Bufpos opoint, Charcount length)
{
/* This function can GC */
struct replicate_extents_arg closure;
closure.from = opoint;
closure.length = length;
closure.head = Qnil;
closure.buf = buf;
closure.nconc_cell = Qzero;
map_extents (opoint, opoint + length, replicate_extents_mapper,
(void *) &closure, make_buffer (buf), 0,
/* ignore extents that just abut the region */
ME_END_CLOSED | ME_ALL_EXTENTS_OPEN |
/* we are calling E-Lisp (the extent's copy function)
so anything might happen */
ME_MIGHT_CALL_ELISP);
return closure.head;
}
/* We have just inserted a string of size "length" at "opoint"; the string
was taken from an original string at position pos. We have the contents
of the extents slot of the original string on hand, and we now need
to do "whatever" is necessary to make the extents in the buffer be
correctly updated. If there are no extents on the string, then that is
nothing. If there are extents and we are inside_undo, then the extents
argument is taken as revealed truth and the state of the buffer extents
must be restored so that the function above would return the same string
extents if this corresponding string were to be deleted. If we are not
inside undo then we just splice in those extents that correspond to
deleted extents.
Note: At the moment we ONLY handle the case of the dup_list argument
be a list of extent_replicas.
*/
void
splice_in_extent_replicas (struct buffer *buf, Bufpos opoint,
Charcount length, Charcount pos,
Lisp_Object dup_list)
{
Lisp_Object tail;
Bufpos base_start = opoint;
Bufpos base_end = opoint + length;
if (NILP (dup_list))
return;
assert (CONSP (dup_list));
for (tail = dup_list; !NILP (tail); tail = Fcdr (tail))
{
Lisp_Object current_replica = Fcar (tail);
/* only process replicas at the moment */
if (EXTENT_REPLICAP (current_replica))
{
EXTENT_REPLICA dup = XEXTENT_REPLICA (current_replica);
EXTENT extent = XEXTENT (extent_replica_extent (dup));
Bufpos new_start = base_start + extent_replica_start (dup) - pos;
Bufpos new_end = base_start + extent_replica_end (dup) - pos;
Bufpos exstart = 0;
Bufpos exend = 0;
if (!EXTENT_LIVE_P (extent))
continue;
if (!extent_detached_p (extent))
{
exstart = extent_endpoint_bufpos (extent, 0);
exend = extent_endpoint_bufpos (extent, 1);
}
#if 0
/* utter hogwash. The "invalid" condition that this code
was attempting to catch is in fact quite valid, and occurs
often with text properties, because of the way the text-
property mechanism re-uses existing extents. I don't
know why this code was in here in the first place, other
than a braino on the part of the original implementor. */
if (inside_undo)
{
if (!extent_detached_p (extent) &&
(exend > base_end || exstart < base_start))
error ("extent 0x%lx is all fouled up wrt. dup 0x%lx",
(long) extent, (long) dup);
}
#endif
/* The extra comparisons defend against set-string-extent-data
and support insert_lisp_string. */
if (new_start < base_start)
new_start = base_start;
if (new_end > base_end)
new_end = base_end;
if (new_end <= new_start)
continue;
#ifdef ENERGIZE
/* Energize extents like toplevel-forms can only be pasted
in the buffer they come from. This should be parametrized
in the generic extent objects. Right now just silently
skip the extents if it's not from the same buffer.
*/
if (XBUFFER (extent_object (extent)) != buf
&& energize_extent_data (extent))
continue;
#endif
/* If this is a `unique' extent, and it is currently attached
somewhere other than here (non-overlapping), then don't copy
it (that's what `unique' means). If however it is detached,
or if we are inserting inside/adjacent to the original
extent, then insert_extent() will simply reattach it, which
is what we want.
*/
if (extent_unique_p (extent)
&& !extent_detached_p (extent)
&& (XBUFFER (extent_object (extent)) != buf
|| exend > new_end
|| exstart < new_start))
continue;
insert_extent (extent, bufpos_to_bytind (buf, new_start),
bufpos_to_bytind (buf, new_end), buf, !inside_undo);
}
}
}
static void
add_to_replicas_lists (c_hashtable table,
Lisp_Object dup_list,
Charcount offset, Charcount length,
int clip_parts, Charcount total_length,
Lisp_Object *cells_vec)
{
Lisp_Object tail;
for (tail = dup_list; !NILP (tail); tail = Fcdr (tail))
{
Lisp_Object current_replica = Fcar (tail);
if (EXTENT_REPLICAP (current_replica))
{
EXTENT_REPLICA dup = XEXTENT_REPLICA (current_replica);
Bufpos new_start = extent_replica_start (dup);
Bufpos new_end = extent_replica_end (dup);
EXTENT extent = XEXTENT (extent_replica_extent (dup));
Lisp_Object pre_existing_cell;
Lisp_Object tmp;
EXTENT_REPLICA new_dup;
CONST void *vval;
if (clip_parts)
{
/* The extra clipping defends against set-string-extent-data.
It is not necessary in shift_replicas, since the
check against total_length still applies below.
*/
if (new_start > length) new_start = length;
if (new_end > length) new_end = length;
}
new_start += offset;
new_end += offset;
/* These checks are needed because of Fsubstring, and are a good
idea in any case:
*/
if (new_end <= 0)
continue;
if (new_start >= total_length)
continue;
if (new_start <= 0)
new_start = 0;
if (new_end >= total_length)
new_end = total_length;
if (!EXTENT_LIVE_P (extent))
continue;
new_dup = make_extent_replica (extent_replica_extent (dup),
new_start, new_end);
if (!gethash ((void *) extent, table, &vval))
pre_existing_cell = Qnil;
else
VOID_TO_LISP (pre_existing_cell, vval);
XSETEXTENT_REPLICA (tmp, new_dup);
tmp = Fcons (tmp, pre_existing_cell);
puthash (extent, LISP_TO_VOID (tmp), table);
}
#if 0
else
{
/* Save away misc. trash in the order encountered. */
Lisp_Object cell;
cell = Fcons (current_replica, Qnil);
if (NILP (cells_vec[0]))
cells_vec[0] = cell;
else
nconc2 (cells_vec[1], cell);
cells_vec[1] = cell;
}
#endif
}
}
/* Merge dup_list[i] into a list of replicas -- if a dup
in listi "overlaps at the end" matches a dup from listi+1 that "overlaps
at the beginning", merge them into one contiguous dup in the returned
list. It is weird and probably bogus if a "detached dup" doesn't merge
entirely, but it isn't an error.
This code also handles construction of a dup_list for Fsubstring,
by handing in a single list with a possibly negative offset and
a length which is possibly less than the length of the original string.
*/
static void
merge_replicas_concating_mapper (CONST void *key, void *contents, void *arg)
{
Lisp_Object extent_cell;
Lisp_Object *cells_vec = (Lisp_Object *) arg;
VOID_TO_LISP (extent_cell, contents);
if (NILP (cells_vec[0]))
cells_vec[0] = extent_cell;
else
nconc2 (cells_vec[1], extent_cell);
cells_vec[1] = extent_cell;
return;
}
static int
mrp_pred (Lisp_Object x, Lisp_Object y, Lisp_Object dummy)
{
EXTENT_REPLICA dup1 = XEXTENT_REPLICA (x);
EXTENT_REPLICA dup2 = XEXTENT_REPLICA (y);
if (extent_replica_start (dup1) < extent_replica_start (dup2))
return 1;
else if (extent_replica_start (dup1) == extent_replica_start (dup2))
{
if (extent_replica_end (dup1) <= extent_replica_end (dup2))
return 1;
else
return -1;
}
return -1;
}
static void
merge_replicas_pruning_mapper (CONST void *key, void *contents, void *arg)
{
Lisp_Object dup_list;
c_hashtable table = (c_hashtable) arg;
VOID_TO_LISP (dup_list, contents);
if (NILP (dup_list))
return;
if (NILP (Fcdr (dup_list)))
return;
/* sort and merge the dup_list */
dup_list = list_sort (dup_list, Qnil, mrp_pred);
{
Lisp_Object current = dup_list;
Lisp_Object tail = Fcdr (dup_list);
EXTENT_REPLICA current_dup = XEXTENT_REPLICA (Fcar (current));
while (!NILP (tail))
{
EXTENT_REPLICA tail_dup = XEXTENT_REPLICA (Fcar (tail));
if (extent_replica_start (tail_dup) <=
extent_replica_end (current_dup) - 1)
{
set_extent_replica_end (current_dup,
max (extent_replica_end (tail_dup),
extent_replica_end (current_dup)));
Fsetcdr (current, Fcdr (tail));
}
else
{
current = tail;
current_dup = XEXTENT_REPLICA (Fcar (current));
}
tail = Fcdr (tail);
}
}
/* now put back the munged list */
puthash (key, LISP_TO_VOID (dup_list), table);
}
static Lisp_Object
merge_replicas_internal (int number_of_lists,
struct merge_replicas_struct *vec,
int shiftp)
{
c_hashtable table = 0;
Lisp_Object cells_vec[2];
int i;
int total_length;
int clip_parts = !shiftp;
cells_vec[0] = Qnil;
cells_vec[1] = Qnil;
total_length = 0;
for (i = 0; i < number_of_lists; i++)
total_length += vec[i].entry_length;
for (i = 0; i < number_of_lists; i++)
{
Lisp_Object dup_list = vec[i].dup_list;
Charcount offset = vec[i].entry_offset;
Charcount length = vec[i].entry_length;
if (!NILP (dup_list))
{
if (!table)
table = make_hashtable (10);
add_to_replicas_lists (table, dup_list,
offset, length,
clip_parts, total_length,
cells_vec);
}
}
if (table)
{
maphash (merge_replicas_pruning_mapper, table, (void*)table);
maphash (merge_replicas_concating_mapper, table, (void*)&(cells_vec[0]));
free_hashtable (table);
}
return (cells_vec[0]);
}
Lisp_Object
merge_replicas (int number_of_lists, struct merge_replicas_struct *vec)
{
return merge_replicas_internal (number_of_lists, vec, 0);
}
/* Like merge_replicas, but operates on just one dup_list,
applying an offset and clipping the results to [0..length).
The offset is non-positive if the caller is Fsubstring.
*/
Lisp_Object
shift_replicas (Lisp_Object dup_list, int offset, int length)
{
struct merge_replicas_struct mr_struct;
mr_struct.dup_list = dup_list;
mr_struct.entry_offset = offset;
mr_struct.entry_length = length;
return merge_replicas_internal (1, &mr_struct, 1);
}
/* Checklist for sanity checking:
- {kill, yank, copy} at {open, closed} {start, end} of {writable, read-only} extent
- {kill, copy} & yank {once, repeatedly} duplicable extent in {same, different} buffer
*/
/************************************************************************/
/* text properties */
/************************************************************************/
/* Text properties
Originally this stuff was implemented in lisp (all of the functionality
exists to make that possible) but speed was a problem.
*/
Lisp_Object Qtext_prop;
Lisp_Object Qtext_prop_extent_paste_function;
struct put_text_prop_arg
{
Lisp_Object prop, value; /* The property and value we are storing */
Bytind start, end; /* The region into which we are storing it */
struct buffer *buffer;
int changed_p; /* Output: whether we have modified anything */
Lisp_Object the_extent; /* Our chosen extent; this is used for
communication between subsequent passes. */
};
static int
put_text_prop_mapper (EXTENT e, void *arg)
{
struct put_text_prop_arg *closure = (struct put_text_prop_arg *) arg;
Lisp_Object value = closure->value;
Bytind e_start, e_end;
Bytind start = closure->start;
Bytind end = closure->end;
Lisp_Object extent, e_val;
XSETEXTENT (extent, e);
e_start = extent_endpoint_bytind (e, 0);
e_end = extent_endpoint_bytind (e, 1);
e_val = Fextent_property (extent, closure->prop);
if (!EQ (Fextent_property (extent, Qtext_prop), closure->prop))
{
/* It's not for this property; do nothing. */
;
}
else if (!NILP (value) &&
NILP (closure->the_extent) &&
EQ (value, e_val))
{
/* We want there to be an extent here at the end, and we haven't picked
one yet, so use this one. Extend it as necessary. We only reuse an
extent which has an EQ value for the prop in question to avoid
side-effecting the kill ring (that is, we never change the property
on an extent after it has been created.)
*/
if (e_start != start || e_end != end)
{
set_extent_endpoints (e, min (e_start, start),
max (e_end, end));
closure->changed_p = 1;
}
closure->the_extent = extent;
}
/* Even if we're adding a prop, at this point, we want all other extents of
this prop to go away (as now they overlap). So the theory here is that,
when we are adding a prop to a region that has multiple (disjoint)
occurences of that prop in it already, we pick one of those and extend
it, and remove the others.
*/
else if (EQ (extent, closure->the_extent))
{
/* just in case map-extents hits it again (does that happen?) */
;
}
else if (e_start >= start && e_end <= end)
{
/* Extent is contained in region; remove it. Don't destroy or modify
it, because we don't want to change the attributes pointed to by the
duplicates in the kill ring.
*/
extent_detach (e);
closure->changed_p = 1;
}
else if (!NILP (closure->the_extent) &&
EQ (value, e_val) &&
e_start <= end &&
e_end >= start)
{
EXTENT te = XEXTENT (closure->the_extent);
/* This extent overlaps, and has the same prop/value as the extent we've
decided to reuse, so we can remove this existing extent as well (the
whole thing, even the part outside of the region) and extend
the-extent to cover it, resulting in the minimum number of extents in
the buffer.
*/
Bytind the_start = extent_endpoint_bytind (te, 0);
Bytind the_end = extent_endpoint_bytind (te, 1);
if (e_start != the_start && /* note AND not OR */
e_end != the_end)
{
set_extent_endpoints (te,
min (the_start, e_start),
max (the_end, e_end));
closure->changed_p = 1;
}
extent_detach (e);
}
else if (e_end <= end)
{
/* Extent begins before start but ends before end, so we can just
decrease its end position.
*/
if (e_end != start)
{
set_extent_endpoints (e, e_start, start);
closure->changed_p = 1;
}
}
else if (e_start >= start)
{
/* Extent ends after end but begins after start, so we can just
increase its start position.
*/
if (e_start != end)
{
set_extent_endpoints (e, end, e_end);
closure->changed_p = 1;
}
}
else
{
/* Otherwise, `extent' straddles the region. We need to split it.
*/
set_extent_endpoints (e, e_start, start);
copy_extent (e, end, e_end, extent_object (e));
closure->changed_p = 1;
}
return 0; /* to continue mapping. */
}
static int
put_text_prop (Bytind start, Bytind end, struct buffer *b,
Lisp_Object prop, Lisp_Object value,
int duplicable_p)
{
/* This function can GC */
struct put_text_prop_arg closure;
if (start == end) /* There are no characters in the region. */
return 0;
closure.prop = prop;
closure.value = value;
closure.start = start;
closure.end = end;
closure.buffer = b;
closure.changed_p = 0;
closure.the_extent = Qnil;
map_extents_bytind (start, end,
put_text_prop_mapper,
(void *) &closure, make_buffer (b), 0,
/* get all extents that abut the region */
ME_ALL_EXTENTS_CLOSED | ME_END_CLOSED |
ME_MIGHT_MODIFY_EXTENTS);
/* If we made it through the loop without reusing an extent
(and we want there to be one) make it now.
*/
if (!NILP (value) && NILP (closure.the_extent))
{
Lisp_Object extent = Qnil;
Lisp_Object object = Qnil;
XSETBUFFER (object, b);
XSETEXTENT (extent, make_extent_internal (object, start, end));
closure.changed_p = 1;
Fset_extent_property (extent, Qtext_prop, prop);
Fset_extent_property (extent, prop, value);
if (duplicable_p)
{
extent_duplicable_p (XEXTENT (extent)) = 1;
Fset_extent_property (extent, Qpaste_function,
Qtext_prop_extent_paste_function);
}
}
return closure.changed_p;
}
DEFUN ("put-text-property", Fput_text_property, Sput_text_property, 4, 5, 0,
"Adds the given property/value to all characters in the specified region.\n\
The property is conceptually attached to the characters rather than the\n\
region. The properties are copied when the characters are copied/pasted.")
(start, end, prop, value, buffer)
Lisp_Object start, end, prop, value, buffer;
{
/* This function can GC */
Bytind s, e;
struct buffer *b = decode_buffer (buffer, 0);
get_bufrange_bytind (b, start, end, &s, &e, 0);
CHECK_SYMBOL (prop, 0);
put_text_prop (s, e, b, prop, value, 1);
return prop;
}
DEFUN ("put-nonduplicable-text-property", Fput_nonduplicable_text_property,
Sput_nonduplicable_text_property, 4, 5, 0,
"Adds the given property/value to all characters in the specified region.\n\
The property is conceptually attached to the characters rather than the\n\
region, however the properties will not be copied when the characters\n\
are copied.")
(start, end, prop, value, buffer)
Lisp_Object start, end, prop, value, buffer;
{
/* This function can GC */
Bytind s, e;
struct buffer *b = decode_buffer (buffer, 0);
get_bufrange_bytind (b, start, end, &s, &e, 0);
CHECK_SYMBOL (prop, 0);
put_text_prop (s, e, b, prop, value, 0);
return prop;
}
DEFUN ("add-text-properties", Fadd_text_properties, Sadd_text_properties,
3, 4, 0,
"Add properties to the characters from START to END.\n\
The third argument PROPS is a property list specifying the property values\n\
to add. The optional fourth argument, OBJECT, is the buffer containing the\n\
text. Returns t if any property was changed, nil otherwise.")
(start, end, props, buffer)
Lisp_Object start, end, props, buffer;
{
/* This function can GC */
int changed = 0;
Bytind s, e;
struct buffer *b = decode_buffer (buffer, 0);
get_bufrange_bytind (b, start, end, &s, &e, 0);
CHECK_LIST (props, 0);
for (; !NILP (props); props = Fcdr (Fcdr (props)))
{
Lisp_Object prop = XCAR (props);
Lisp_Object value = Fcar (XCDR (props));
CHECK_SYMBOL (prop, 0);
changed |= put_text_prop (s, e, b, prop, value, 1);
}
return (changed ? Qt : Qnil);
}
DEFUN ("remove-text-properties", Fremove_text_properties,
Sremove_text_properties, 3, 4, 0,
"Remove the given properties from all characters in the specified region.\n\
PROPS should be a plist, but the values in that plist are ignored (treated\n\
as nil). Returns t if any property was changed, nil otherwise.")
(start, end, props, buffer)
Lisp_Object start, end, props, buffer;
{
/* This function can GC */
int changed = 0;
Bytind s, e;
struct buffer *b = decode_buffer (buffer, 0);
get_bufrange_bytind (b, start, end, &s, &e, 0);
CHECK_LIST (props, 0);
for (; !NILP (props); props = Fcdr (Fcdr (props)))
{
Lisp_Object prop = XCAR (props);
CHECK_SYMBOL (prop, 0);
changed |= put_text_prop (s, e, b, prop, Qnil, 1);
}
return (changed ? Qt : Qnil);
}
/* Whenever a text-prop extent is pasted into a buffer (via `yank' or `insert'
or whatever) we attach the properties to the buffer by calling
`put-text-property' instead of by simply allowing the extent to be copied or
re-attached. Then we return nil, telling the extents code not to attach it
again. By handing the insertion hackery in this way, we make kill/yank
behave consistently with put-text-property and not fragment the extents
(since text-prop extents must partition, not overlap).
The lisp implementation of this was probably fast enough, but since I moved
the rest of the put-text-prop code here, I moved this as well for
completeness.
*/
DEFUN ("text-prop-extent-paste-function", Ftext_prop_extent_paste_function,
Stext_prop_extent_paste_function, 3, 3, 0,
"Used as the `paste-function' property of `text-prop' extents.")
(extent, from, to)
Lisp_Object extent, from, to;
{
/* This function can GC */
Lisp_Object prop, val;
prop = Fextent_property (extent, Qtext_prop);
if (NILP (prop))
signal_simple_error ("internal error: no text-prop", extent);
val = Fextent_property (extent, prop);
if (NILP (val))
signal_simple_error_2 ("internal error: no text-prop",
extent, prop);
Fput_text_property (from, to, prop, val, Qnil);
return Qnil; /* important! */
}
/* This function could easily be written in Lisp but the C code wants
to use it in connection with invisible extents (at least currently).
If this changes, consider moving this back into Lisp. */
DEFUN ("next-single-property-change", Fnext_single_property_change,
Snext_single_property_change, 2, 4, 0,
"Return the position of next property change for a specific property.\n\
Scans characters forward from POS till it finds a change in the PROP\n\
property, then returns the position of the change. The optional third\n\
argument BUFFER is the buffer to scan (defaults to the current buffer).\n\
The property values are compared with `eq'.\n\
Return nil if the property is constant all the way to the end of BUFFER.\n\
If the value is non-nil, it is a position greater than POS, never equal.\n\n\
If the optional fourth argument LIMIT is non-nil, don't search\n\
past position LIMIT; return LIMIT if nothing is found before LIMIT.\n\
If two or more extents with conflicting non-nil values for PROP overlap\n\
a particular character, it is undefined which value is considered to be\n\
the value of PROP. (Note that this situation will not happen if you always\n\
use the text-property primitives.)")
(pos, prop, buffer, limit)
Lisp_Object pos, prop, buffer, limit;
{
struct buffer *buf = decode_buffer (buffer, 0);
Bufpos bpos = get_bufpos (buf, pos, 0);
Bufpos blim;
Lisp_Object extent, value;
int limit_was_nil;
if (NILP (limit))
{
blim = BUF_ZV (buf);
limit_was_nil = 1;
}
else
{
blim = get_bufpos (buf, limit, 0);
limit_was_nil = 0;
}
CHECK_SYMBOL (prop, 1);
XSETBUFFER (buffer, buf);
extent = Fextent_at (make_number (bpos), buffer, prop, Qnil);
if (!NILP (extent))
value = Fextent_property (extent, prop);
else
value = Qnil;
while (1)
{
bpos = XINT (Fnext_extent_change (make_number (bpos), buffer));
if (bpos >= blim)
break; /* property is the same all the way to the end */
extent = Fextent_at (make_number (bpos), buffer, prop, Qnil);
if ((NILP (extent) && !NILP (value)) ||
(!NILP (extent) && !EQ (value, Fextent_property (extent, prop))))
return make_number (bpos);
}
/* I think it's more sensible for this function to return nil always
in this situation and it used to do it this way, but it's been changed
for FSF compatibility. */
if (limit_was_nil)
return Qnil;
else
return make_number (blim);
}
/* See comment on previous function about why this is written in C. */
DEFUN ("previous-single-property-change", Fprevious_single_property_change,
Sprevious_single_property_change, 2, 4, 0,
"Return the position of next property change for a specific property.\n\
Scans characters backward from POS till it finds a change in the PROP\n\
property, then returns the position of the change. The optional third\n\
argument BUFFER is the buffer to scan (defaults to the current buffer).\n\
The property values are compared with `eq'.\n\
Return nil if the property is constant all the way to the start of BUFFER.\n\
If the value is non-nil, it is a position less than POS, never equal.\n\n\
If the optional fourth argument LIMIT is non-nil, don't search back\n\
past position LIMIT; return LIMIT if nothing is found until LIMIT.\n\
If two or more extents with conflicting non-nil values for PROP overlap\n\
a particular character, it is undefined which value is considered to be\n\
the value of PROP. (Note that this situation will not happen if you always\n\
use the text-property primitives.)")
(pos, prop, buffer, limit)
Lisp_Object pos, prop, buffer, limit;
{
struct buffer *buf = decode_buffer (buffer, 0);
Bufpos bpos = get_bufpos (buf, pos, 0);
Bufpos blim;
Lisp_Object extent, value;
int limit_was_nil;
if (NILP (limit))
{
blim = BUF_BEGV (buf);
limit_was_nil = 1;
}
else
{
blim = get_bufpos (buf, limit, 0);
limit_was_nil = 0;
}
CHECK_SYMBOL (prop, 1);
XSETBUFFER (buffer, buf);
/* extent-at refers to the character AFTER bpos, but we want the
character before bpos. Thus the - 1. extent-at simply
returns nil on bogus positions, so not to worry. */
extent = Fextent_at (make_number (bpos - 1), buffer, prop, Qnil);
if (!NILP (extent))
value = Fextent_property (extent, prop);
else
value = Qnil;
while (1)
{
bpos = XINT (Fprevious_extent_change (make_number (bpos), buffer));
if (bpos <= blim)
break; /* property is the same all the way to the beginning */
extent = Fextent_at (make_number (bpos - 1), buffer, prop, Qnil);
if ((NILP (extent) && !NILP (value)) ||
(!NILP (extent) && !EQ (value, Fextent_property (extent, prop))))
return make_number (bpos);
}
/* I think it's more sensible for this function to return nil always
in this situation and it used to do it this way, but it's been changed
for FSF compatibility. */
if (limit_was_nil)
return Qnil;
else
return make_number (blim);
}
/************************************************************************/
/* initialization */
/************************************************************************/
void
syms_of_extents (void)
{
defsymbol (&Qextentp, "extentp");
defsymbol (&Qextent_replicap, "extent-replicap");
defsymbol (&Qextent_live_p, "extent-live-p");
defsymbol (&Qextent_replica_live_p, "extent-replica-live-p");
defsymbol (&Qend_closed, "end-closed");
defsymbol (&Qstart_open, "start-open");
defsymbol (&Qall_extents_closed, "all-extents-closed");
defsymbol (&Qall_extents_open, "all-extents-open");
defsymbol (&Qall_extents_closed_open, "all-extents-closed-open");
defsymbol (&Qall_extents_open_closed, "all-extents-open-closed");
defsymbol (&Qstart_in_region, "start-in-region");
defsymbol (&Qend_in_region, "end-in-region");
defsymbol (&Qstart_and_end_in_region, "start-and-end-in-region");
defsymbol (&Qstart_or_end_in_region, "start-or-end-in-region");
defsymbol (&Qnegate_in_region, "negate-in-region");
defsymbol (&Qdetached, "detached");
defsymbol (&Qdestroyed, "destroyed");
defsymbol (&Qbegin_glyph, "begin-glyph");
defsymbol (&Qend_glyph, "end-glyph");
defsymbol (&Qstart_open, "start-open");
defsymbol (&Qend_open, "end-open");
defsymbol (&Qstart_closed, "start-closed");
defsymbol (&Qend_closed, "end-closed");
defsymbol (&Qread_only, "read-only");
/* defsymbol (&Qhighlight, "highlight"); in faces.c */
defsymbol (&Qunique, "unique");
defsymbol (&Qduplicable, "duplicable");
defsymbol (&Qinvisible, "invisible");
defsymbol (&Qintangible, "intangible");
defsymbol (&Qdetachable, "detachable");
defsymbol (&Qpriority, "priority");
defsymbol (&Qglyph_layout, "glyph-layout"); /* backwards compatibility */
defsymbol (&Qbegin_glyph_layout, "begin-glyph-layout");
defsymbol (&Qbegin_glyph_layout, "end-glyph-layout");
defsymbol (&Qoutside_margin, "outside-margin");
defsymbol (&Qinside_margin, "inside-margin");
defsymbol (&Qwhitespace, "whitespace");
/* Qtext defined in general.c */
defsymbol (&Qglyph_invisible, "glyph-invisible");
defsymbol (&Qpaste_function, "paste-function");
defsymbol (&Qcopy_function, "copy-function");
defsymbol (&Qtext_prop, "text-prop");
defsymbol (&Qtext_prop_extent_paste_function,
"text-prop-extent-paste-function");
defsymbol (&Qdup_list, "dup-list");
defsubr (&Sextentp);
defsubr (&Sextent_live_p);
defsubr (&Sextent_detached_p);
defsubr (&Sextent_start_position);
defsubr (&Sextent_end_position);
defsubr (&Sextent_object);
defsubr (&Sextent_length);
#if 0
defsubr (&Sstack_of_extents);
#endif
defsubr (&Smake_extent);
defsubr (&Scopy_extent);
defsubr (&Sdelete_extent);
defsubr (&Sdetach_extent);
defsubr (&Sset_extent_endpoints);
defsubr (&Snext_extent);
defsubr (&Sprevious_extent);
#if DEBUG_XEMACS
defsubr (&Snext_e_extent);
defsubr (&Sprevious_e_extent);
#endif
defsubr (&Snext_extent_change);
defsubr (&Sprevious_extent_change);
defsubr (&Sextent_parent);
defsubr (&Sextent_children);
defsubr (&Sset_extent_parent);
defsubr (&Sextent_in_region_p);
defsubr (&Smap_extents);
defsubr (&Smap_extent_children);
defsubr (&Sextent_at);
defsubr (&Sset_extent_begin_glyph);
defsubr (&Sset_extent_end_glyph);
defsubr (&Sextent_begin_glyph);
defsubr (&Sextent_end_glyph);
defsubr (&Sset_extent_begin_glyph_layout);
defsubr (&Sset_extent_end_glyph_layout);
defsubr (&Sextent_begin_glyph_layout);
defsubr (&Sextent_end_glyph_layout);
defsubr (&Sset_extent_priority);
defsubr (&Sextent_priority);
defsubr (&Sset_extent_property);
defsubr (&Sextent_property);
defsubr (&Sextent_properties);
defsubr (&Shighlight_extent);
defsubr (&Sforce_highlight_extent);
defsubr (&Sinsert_extent);
defsubr (&Sstring_extent_data);
defsubr (&Sset_string_extent_data);
defsubr (&Smake_extent_replica);
defsubr (&Sextent_replica_p);
defsubr (&Sextent_replica_live_p);
defsubr (&Sextent_replica_extent);
defsubr (&Sextent_replica_start);
defsubr (&Sextent_replica_end);
defsubr (&Sput_text_property);
defsubr (&Sput_nonduplicable_text_property);
defsubr (&Sadd_text_properties);
defsubr (&Sremove_text_properties);
defsubr (&Stext_prop_extent_paste_function);
defsubr (&Snext_single_property_change);
defsubr (&Sprevious_single_property_change);
}
void
vars_of_extents (void)
{
DEFVAR_INT ("mouse-highlight-priority", &mouse_highlight_priority,
"The priority to use for the mouse-highlighting pseudo-extent\n\
that is used to highlight extents with the `highlight' attribute set.\n\
See `set-extent-priority'.");
/* Set mouse-highlight-priority (which ends up being used both for the
mouse-highlighting pseudo-extent and the primary selection extent)
to a very high value because very few extents should override it.
1000 gives lots of room below it for different-prioritied extents.
10 doesn't. ediff, for example, likes to use priorities around 100.
--ben */
mouse_highlight_priority = /* 10 */ 1000;
staticpro (&Vlast_highlighted_extent);
Vlast_highlighted_extent = Qnil;
extent_auxiliary_defaults.begin_glyph = Qnil;
extent_auxiliary_defaults.end_glyph = Qnil;
extent_auxiliary_defaults.parent = Qnil;
extent_auxiliary_defaults.children = Qnil;
extent_auxiliary_defaults.priority = 0;
staticpro (&Vthis_is_a_dead_extent_replica);
XSETEXTENT (Vthis_is_a_dead_extent_replica, make_extent ());
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.