/* Copyright (c) 1994, 1995 Free Software Foundation, Inc.
Copyright (c) 1995 Sun Microsystems, Inc.
- Copyright (c) 1995, 1996 Ben Wing.
+ Copyright (c) 1995, 1996, 2000 Ben Wing.
This file is part of XEmacs.
#define DE_MUST_BE_ATTACHED 2
Lisp_Object Vlast_highlighted_extent;
-int mouse_highlight_priority;
+Fixnum mouse_highlight_priority;
Lisp_Object Qextentp;
Lisp_Object Qextent_live_p;
EXFUN (Fextent_properties, 1);
EXFUN (Fset_extent_property, 3);
+/* if true, we don't want to set any redisplay flags on modeline extent
+ changes */
+int in_modeline_generation;
+
\f
/************************************************************************/
/* Generalized gap array */
set_extent_start (e, -1);
set_extent_end (e, -1);
}
+
+ /* But we need to clear all the lists containing extents or
+ havoc will result. */
+ extent_list_delete_all (data->extents);
}
- /* But we need to clear all the lists containing extents or
- havoc will result. */
- extent_list_delete_all (data->extents);
soe_invalidate (object);
}
}
else if (STRINGP (object))
{
/* #### Changes to string extents can affect redisplay if they are
- in the modeline or in the gutters.
-
+ in the modeline or in the gutters.
+
If the extent is in some generated-modeline-string: when we
change an extent in generated-modeline-string, this changes its
parent, which is in `modeline-format', so we should force the
is not very efficient. Should we add all
`generated-modeline-string' strings to a hash table? Maybe
efficiency is not the greatest concern here and there's no big
- loss in looping over the buffers.
+ loss in looping over the buffers.
If the extent is in a gutter we mark the gutter as
changed. This means (a) we can update extents in the gutters
when we need it. (b) we don't have to update the gutters when
only extents attached to buffers have changed. */
- MARK_EXTENTS_CHANGED;
+ if (!in_modeline_generation)
+ MARK_EXTENTS_CHANGED;
gutter_extent_signal_changed_region_maybe (object,
extent_endpoint_bufpos (extent, 0),
extent_endpoint_bufpos (extent, 1));
case ME_ALL_EXTENTS_OPEN: start_open = 1, 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: abort(); break;
+ default: ABORT(); return 0;
}
start = buffer_or_string_bytind_to_startind (obj, from,
retval = (start <= exs && exs <= end) || (start <= exe && exe <= end);
break;
default:
- abort(); break;
+ ABORT(); return 0;
}
return flags & ME_NEGATE_IN_REGION ? !retval : retval;
}
face_index
extent_fragment_update (struct window *w, struct extent_fragment *ef,
- Bytind pos)
+ Bytind pos, Lisp_Object last_glyph)
{
int i;
+ int seen_glyph = NILP (last_glyph) ? 1 : 0;
Extent_List *sel =
buffer_or_string_stack_of_extents_force (ef->object)->extents;
EXTENT lhe = 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;
- XSETEXTENT (gb.extent, e);
- Dynarr_add (ef->begin_glyphs, gb);
+ if (seen_glyph) {
+ struct glyph_block gb;
+
+ gb.glyph = glyph;
+ XSETEXTENT (gb.extent, e);
+ Dynarr_add (ef->begin_glyphs, gb);
+ }
+ else if (EQ (glyph, last_glyph))
+ seen_glyph = 1;
}
}
if (extent_end (e) == mempos && !NILP (extent_end_glyph (e)))
{
Lisp_Object glyph = extent_end_glyph (e);
- struct glyph_block gb;
+ if (seen_glyph) {
+ struct glyph_block gb;
- gb.glyph = glyph;
- XSETEXTENT (gb.extent, e);
- Dynarr_add (ef->end_glyphs, gb);
+ gb.glyph = glyph;
+ XSETEXTENT (gb.extent, e);
+ Dynarr_add (ef->end_glyphs, gb);
+ }
+ else if (EQ (glyph, last_glyph))
+ seen_glyph = 1;
}
}
strcpy (bp, "detached");
else
sprintf (bp, "%ld, %ld",
- (long) XINT (Fextent_start_position (obj)),
- (long) XINT (Fextent_end_position (obj)));
+ XINT (Fextent_start_position (obj)),
+ XINT (Fextent_end_position (obj)));
bp += strlen (bp);
*bp++ = (extent_end_open_p (anc) ? ')': ']');
if (!NILP (extent_end_glyph (anc))) *bp++ = '*';
Lisp_Object obj2 = Qnil;
/* Destroyed extents have 't' in the object field, causing
- extent_object() to abort (maybe). */
+ extent_object() to ABORT (maybe). */
if (EXTENT_LIVE_P (XEXTENT (obj)))
obj2 = extent_object (XEXTENT (obj));
if ((NILP (obj) && (flags & DE_MUST_HAVE_BUFFER))
|| (extent_detached_p (extent) && (flags & DE_MUST_BE_ATTACHED)))
{
- signal_simple_error ("extent doesn't belong to a buffer or string",
- extent_obj);
+ invalid_argument ("extent doesn't belong to a buffer or string",
+ extent_obj);
}
return extent;
Return the next position after POS where an extent begins or ends.
If POS is at the end of the buffer or string, POS will be returned;
otherwise a position greater than POS will always be returned.
-If BUFFER is nil, the current buffer is assumed.
+If OBJECT is nil, the current buffer is assumed.
*/
(pos, object))
{
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);
+ signal_type_error (Qinvalid_change,
+ "Circular parent chain would result",
+ extent);
if (NILP (parent))
{
remove_extent_from_children_list (XEXTENT (cur_parent), extent);
get_buffer_or_string_range_byte (buffer_or_string, start, end, &s, &e,
GB_ALLOW_PAST_ACCESSIBLE);
+ buffer_or_string_extent_info_force (buffer_or_string);
set_extent_endpoints (ext, s, e, buffer_or_string);
return extent;
}
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);
+ (invalid_argument ("Invalid `map-extents' flag", sym), 0);
flags = XCDR (flags);
}
struct extent_at_arg
{
- EXTENT best_match;
+ Lisp_Object best_match; /* or list of extents */
Memind best_start;
Memind best_end;
Lisp_Object prop;
EXTENT before;
+ int all_extents;
};
enum extent_at_flag
if (EQ (at_flag, Qbefore)) return EXTENT_AT_BEFORE;
if (EQ (at_flag, Qat)) return EXTENT_AT_AT;
- signal_simple_error ("Invalid AT-FLAG in `extent-at'", at_flag);
+ invalid_argument ("Invalid AT-FLAG in `extent-at'", at_flag);
return EXTENT_AT_AFTER; /* unreached */
}
return 0;
}
+ if (!closure->all_extents)
{
- EXTENT current = closure->best_match;
+ EXTENT current;
- if (!current)
+ if (NILP (closure->best_match))
goto accept;
+ current = XEXTENT (closure->best_match);
/* redundant but quick test */
- else if (extent_start (current) > extent_start (e))
+ if (extent_start (current) > extent_start (e))
return 0;
/* we return the "last" best fit, instead of the first --
else
return 0;
accept:
- closure->best_match = e;
+ XSETEXTENT (closure->best_match, e);
closure->best_start = extent_start (e);
closure->best_end = extent_end (e);
}
+ else
+ {
+ Lisp_Object extent;
+
+ XSETEXTENT (extent, e);
+ closure->best_match = Fcons (extent, closure->best_match);
+ }
return 0;
}
static Lisp_Object
extent_at_bytind (Bytind position, Lisp_Object object, Lisp_Object property,
- EXTENT before, enum extent_at_flag at_flag)
+ EXTENT before, enum extent_at_flag at_flag, int all_extents)
{
struct extent_at_arg closure;
- Lisp_Object extent_obj;
+ struct gcpro gcpro1;
/* it might be argued that invalid positions should cause
errors, but the principle of least surprise dictates that
: position > buffer_or_string_absolute_end_byte (object)))
return Qnil;
- closure.best_match = 0;
+ closure.best_match = Qnil;
closure.prop = property;
closure.before = before;
+ closure.all_extents = all_extents;
+ GCPRO1 (closure.best_match);
map_extents_bytind (at_flag == EXTENT_AT_BEFORE ? position - 1 : position,
at_flag == EXTENT_AT_AFTER ? position + 1 : position,
extent_at_mapper, (void *) &closure, object, 0,
ME_START_OPEN | ME_ALL_EXTENTS_CLOSED);
+ if (all_extents)
+ closure.best_match = Fnreverse (closure.best_match);
+ UNGCPRO;
- if (!closure.best_match)
- return Qnil;
-
- XSETEXTENT (extent_obj, closure.best_match);
- return extent_obj;
+ return closure.best_match;
}
DEFUN ("extent-at", Fextent_at, 1, 5, 0, /*
else
before_extent = decode_extent (before, DE_MUST_BE_ATTACHED);
if (before_extent && !EQ (object, extent_object (before_extent)))
- signal_simple_error ("extent not in specified buffer or string", object);
+ invalid_argument ("extent not in specified buffer or string", object);
+ fl = decode_extent_at_flag (at_flag);
+
+ return extent_at_bytind (position, object, property, before_extent, fl, 0);
+}
+
+DEFUN ("extents-at", Fextents_at, 1, 5, 0, /*
+Find all extents at POS in OBJECT having PROPERTY set.
+Normally, an extent is "at" POS if it overlaps the region (POS, POS+1);
+ i.e. if it covers the character after POS. (However, see the definition
+ of AT-FLAG.)
+This provides similar functionality to `extent-list', but does so in a way
+ that is compatible with `extent-at'. (For example, errors due to POS out of
+ range are ignored; this makes it safer to use this function in response to
+ a mouse event, because in many cases previous events have changed the buffer
+ contents.)
+OBJECT specifies a buffer or string and defaults to the current buffer.
+PROPERTY defaults to nil, meaning that any extent will do.
+Properties are attached to extents with `set-extent-property', which see.
+Returns nil if POS is invalid or there is no matching extent at POS.
+If the fourth argument BEFORE is not nil, it must be an extent; any returned
+ extent will precede that extent. This feature allows `extents-at' to be
+ used by a loop over extents.
+AT-FLAG controls how end cases are handled, and should be one of:
+
+nil or `after' An extent is at POS if it covers the character
+ after POS. This is consistent with the way
+ that text properties work.
+`before' An extent is at POS if it covers the character
+ before POS.
+`at' An extent is at POS if it overlaps or abuts POS.
+ This includes all zero-length extents at POS.
+
+Note that in all cases, the start-openness and end-openness of the extents
+considered is ignored. If you want to pay attention to those properties,
+you should use `map-extents', which gives you more control.
+*/
+ (pos, object, property, before, at_flag))
+{
+ Bytind position;
+ EXTENT before_extent;
+ enum extent_at_flag fl;
+
+ object = decode_buffer_or_string (object);
+ position = get_buffer_or_string_pos_byte (object, pos, GB_NO_ERROR_IF_BAD);
+ if (NILP (before))
+ before_extent = 0;
+ else
+ before_extent = decode_extent (before, DE_MUST_BE_ATTACHED);
+ if (before_extent && !EQ (object, extent_object (before_extent)))
+ invalid_argument ("extent not in specified buffer or string", object);
fl = decode_extent_at_flag (at_flag);
- return extent_at_bytind (position, object, property, before_extent, fl);
+ return extent_at_bytind (position, object, property, before_extent, fl, 1);
}
/* ------------------------------- */
#ifdef ERROR_CHECK_EXTENTS
if (extent_start (extent) > indice &&
extent_start (extent) < indice + closure->length)
- abort ();
+ ABORT ();
if (extent_end (extent) > indice &&
extent_end (extent) < indice + closure->length)
- abort ();
+ 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.
+ all extents were closed-open -- endpoints at the insertion point
+ remain unchanged. We need to fix the other kinds of extents:
+
+ 1. Start position of start-open extents needs to be moved.
- 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. */
+ 2. End position of end-closed extents needs to be moved.
+
+ Note that both conditions hold for zero-length (] extents at the
+ insertion point. But under these rules, zero-length () extents
+ would get adjusted such that their start is greater than their
+ end; instead of allowing that, we treat them as [) extents by
+ modifying condition #1 to not fire nothing when dealing with a
+ zero-length open-open extent.
+
+ Existence of zero-length open-open extents is unfortunately an
+ inelegant part of the extent model, but there is no way around
+ it. */
{
- Memind new_start, new_end;
+ Memind new_start = extent_start (extent);
+ Memind new_end = extent_end (extent);
- new_start = extent_start (extent);
- new_end = extent_end (extent);
- if (indice == extent_start (extent) && extent_start_open_p (extent) &&
- /* coerce zero-length () extents to [) */
- new_start != new_end)
+ if (indice == extent_start (extent) && extent_start_open_p (extent)
+ /* zero-length () extents are exempt; see comment above. */
+ && !(new_start == new_end && extent_end_open_p (extent))
+ )
new_start += closure->length;
if (indice == extent_end (extent) && !extent_end_open_p (extent))
new_end += closure->length;
+
set_extent_endpoints_1 (extent, new_start, new_end);
}
unbind_to (closure.speccount, Qnil). This is because
map_extents_bytind() unbinds before, and with a smaller
speccount. The additional unbind_to() in
- report_extent_modification() would cause XEmacs to abort. */
+ report_extent_modification() would cause XEmacs to ABORT. */
if (closure->speccount == -1)
{
closure->speccount = specpdl_depth ();
/* Do we need a lisp-level function ? */
DEFUN ("set-extent-initial-redisplay-function", Fset_extent_initial_redisplay_function,
- 2,2,0,/*
+ 2,2,0, /*
Note: This feature is experimental!
Set initial-redisplay-function of EXTENT to the function
case GL_INSIDE_MARGIN: return Qinside_margin;
case GL_WHITESPACE: return Qwhitespace;
default:
- abort ();
+ ABORT ();
return Qnil; /* unreached */
}
}
if (EQ (layout_obj, Qwhitespace)) return GL_WHITESPACE;
if (EQ (layout_obj, Qtext)) return GL_TEXT;
- signal_simple_error ("Unknown glyph layout type", layout_obj);
+ invalid_argument ("Unknown glyph layout type", layout_obj);
return GL_TEXT; /* unreached */
}
`inside-margin', or `outside-margin') of the extent's
begin glyph.
- end-glyph-layout The layout policy of the extent's end glyph.
+ end-glyph-layout The layout policy of the extent's end glyph.
+
+ syntax-table A cons or a syntax table object. If a cons, the car must
+ be an integer (interpreted as a syntax code, applicable to
+ all characters in the extent). Otherwise, syntax of
+ characters in the extent is looked up in the syntax table.
+ You should use the text property API to manipulate this
+ property. (This may be required in the future.)
*/
(extent, property, value))
{
DEFUN ("extent-property", Fextent_property, 2, 3, 0, /*
Return EXTENT's value for property PROPERTY.
+If no such property exists, DEFAULT is returned.
See `set-extent-property' for the built-in property names.
*/
(extent, property, default_))
/* text_props_only specifies whether we only consider text-property
extents (those with the 'text-prop property set) or all extents. */
if (!text_props_only)
- extent = extent_at_bytind (position, object, prop, 0, fl);
+ extent = extent_at_bytind (position, object, prop, 0, fl, 0);
else
{
EXTENT prior = 0;
while (1)
{
extent = extent_at_bytind (position, object, Qtext_prop, prior,
- fl);
+ fl, 0);
if (NILP (extent))
return Qnil;
if (EQ (prop, Fextent_property (extent, Qtext_prop, Qnil)))
prop = Fextent_property (extent, Qtext_prop, Qnil);
if (NILP (prop))
- signal_simple_error ("Internal error: no text-prop", extent);
+ signal_type_error (Qinternal_error,
+ "Internal error: no text-prop", extent);
val = Fextent_property (extent, prop, Qnil);
#if 0
/* removed by bill perry, 2/9/97
** with a value of Qnil. This is bad bad bad.
*/
if (NILP (val))
- signal_simple_error_2 ("Internal error: no text-prop",
- extent, prop);
+ signal_type_error_2 (Qinternal_error,
+ "Internal error: no text-prop",
+ extent, prop);
#endif
Fput_text_property (from, to, prop, val, Qnil);
return Qnil; /* important! */
argument OBJECT is the buffer or string to scan (defaults to the current
buffer).
The property values are compared with `eq'.
-Return nil if the property is constant all the way to the end of BUFFER.
+Return nil if the property is constant all the way to the end of OBJECT.
If the value is non-nil, it is a position greater than POS, never equal.
If the optional fourth argument LIMIT is non-nil, don't search
argument OBJECT is the buffer or string to scan (defaults to the current
buffer).
The property values are compared with `eq'.
-Return nil if the property is constant all the way to the start of BUFFER.
+Return nil if the property is constant all the way to the start of OBJECT.
If the value is non-nil, it is a position less than POS, never equal.
If the optional fourth argument LIMIT is non-nil, don't search back
DEFSUBR (Fmap_extents);
DEFSUBR (Fmap_extent_children);
DEFSUBR (Fextent_at);
+ DEFSUBR (Fextents_at);
DEFSUBR (Fset_extent_initial_redisplay_function);
DEFSUBR (Fextent_face);
projects / chise / xemacs-chise.git.1 / blobdiff