print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
size_t i;
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
size_t len = bit_vector_length (v);
size_t last = len;
static int
bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
- struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
+ Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
+ Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
!memcmp (v1->bits, v2->bits,
static unsigned long
bit_vector_hash (Lisp_Object obj, int depth)
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
return HASH2 (bit_vector_length (v),
memory_hash (v->bits,
BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
sizeof (long)));
}
+static size_t
+size_bit_vector (const void *lheader)
+{
+ Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
+ return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
+ BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
+}
+
static const struct lrecord_description bit_vector_description[] = {
- { XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next), 1 },
+ { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
{ XD_END }
};
-DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
- mark_bit_vector, print_bit_vector, 0,
- bit_vector_equal, bit_vector_hash,
- bit_vector_description,
- struct Lisp_Bit_Vector);
+DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
+ mark_bit_vector, print_bit_vector, 0,
+ bit_vector_equal, bit_vector_hash,
+ bit_vector_description, size_bit_vector,
+ Lisp_Bit_Vector);
\f
DEFUN ("identity", Fidentity, 1, 1, 0, /*
Return the argument unchanged.
return XINT (Flength (seq));
else
{
- struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
+ Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
return (f->flags.interactivep ? COMPILED_INTERACTIVE :
f->flags.domainp ? COMPILED_DOMAIN :
#endif /* LOSING_BYTECODE */
void
-check_losing_bytecode (CONST char *function, Lisp_Object seq)
+check_losing_bytecode (const char *function, Lisp_Object seq)
{
if (COMPILED_FUNCTIONP (seq))
error_with_frob
(s1, s2))
{
Bytecount len;
- struct Lisp_String *p1, *p2;
+ Lisp_String *p1, *p2;
if (SYMBOLP (s1))
p1 = XSYMBOL (s1)->name;
*/
(s1, s2))
{
- struct Lisp_String *p1, *p2;
+ Lisp_String *p1, *p2;
Charcount end, len2;
int i;
*/
(string))
{
- struct Lisp_String *s;
+ Lisp_String *s;
CHECK_STRING (string);
s = XSTRING (string);
void
bump_string_modiff (Lisp_Object str)
{
- struct Lisp_String *s = XSTRING (str);
+ Lisp_String *s = XSTRING (str);
Lisp_Object *ptr = &s->plist;
#ifdef I18N3
}
DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
-Return a subsequence of SEQ, starting at index FROM and ending before TO.
-TO may be nil or omitted; then the subsequence runs to the end of SEQ.
-If FROM or TO is negative, it counts from the end.
-The resulting subsequence is always the same type as the original
- sequence.
-If SEQ is a string, relevant parts of the string-extent-data are copied
- to the new string.
+Return the subsequence of SEQUENCE starting at START and ending before END.
+END may be omitted; then the subsequence runs to the end of SEQUENCE.
+If START or END is negative, it counts from the end.
+The returned subsequence is always of the same type as SEQUENCE.
+If SEQUENCE is a string, relevant parts of the string-extent-data
+are copied to the new string.
*/
- (seq, from, to))
+ (sequence, start, end))
{
- EMACS_INT len, f, t;
+ EMACS_INT len, s, e;
- if (STRINGP (seq))
- return Fsubstring (seq, from, to);
+ if (STRINGP (sequence))
+ return Fsubstring (sequence, start, end);
- if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
- {
- check_losing_bytecode ("subseq", seq);
- seq = wrong_type_argument (Qsequencep, seq);
- }
+ len = XINT (Flength (sequence));
- len = XINT (Flength (seq));
+ CHECK_INT (start);
+ s = XINT (start);
+ if (s < 0)
+ s = len + s;
- CHECK_INT (from);
- f = XINT (from);
- if (f < 0)
- f = len + f;
-
- if (NILP (to))
- t = len;
+ if (NILP (end))
+ e = len;
else
{
- CHECK_INT (to);
- t = XINT (to);
- if (t < 0)
- t = len + t;
+ CHECK_INT (end);
+ e = XINT (end);
+ if (e < 0)
+ e = len + e;
}
- if (!(0 <= f && f <= t && t <= len))
- args_out_of_range_3 (seq, make_int (f), make_int (t));
+ if (!(0 <= s && s <= e && e <= len))
+ args_out_of_range_3 (sequence, make_int (s), make_int (e));
- if (VECTORP (seq))
+ if (VECTORP (sequence))
{
- Lisp_Object result = make_vector (t - f, Qnil);
+ Lisp_Object result = make_vector (e - s, Qnil);
EMACS_INT i;
- Lisp_Object *in_elts = XVECTOR_DATA (seq);
+ Lisp_Object *in_elts = XVECTOR_DATA (sequence);
Lisp_Object *out_elts = XVECTOR_DATA (result);
- for (i = f; i < t; i++)
- out_elts[i - f] = in_elts[i];
+ for (i = s; i < e; i++)
+ out_elts[i - s] = in_elts[i];
return result;
}
-
- if (LISTP (seq))
+ else if (LISTP (sequence))
{
Lisp_Object result = Qnil;
EMACS_INT i;
- seq = Fnthcdr (make_int (f), seq);
+ sequence = Fnthcdr (make_int (s), sequence);
- for (i = f; i < t; i++)
+ for (i = s; i < e; i++)
{
- result = Fcons (Fcar (seq), result);
- seq = Fcdr (seq);
+ result = Fcons (Fcar (sequence), result);
+ sequence = Fcdr (sequence);
}
return Fnreverse (result);
}
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Object result = make_bit_vector (e - s, Qzero);
+ EMACS_INT i;
- /* bit vector */
- {
- Lisp_Object result = make_bit_vector (t - f, Qzero);
- EMACS_INT i;
-
- for (i = f; i < t; i++)
- set_bit_vector_bit (XBIT_VECTOR (result), i - f,
- bit_vector_bit (XBIT_VECTOR (seq), i));
- return result;
- }
+ for (i = s; i < e; i++)
+ set_bit_vector_bit (XBIT_VECTOR (result), i - s,
+ bit_vector_bit (XBIT_VECTOR (sequence), i));
+ return result;
+ }
+ else
+ abort (); /* unreachable, since Flength (sequence) did not get an error */
}
\f
DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
Given a plist, return non-nil if its format is correct.
If it returns nil, `check-valid-plist' will signal an error when given
-the plist; that means it's a malformed or circular plist or has non-symbols
-as keywords.
+the plist; that means it's a malformed or circular plist.
*/
(plist))
{
(lax_plist, prop, default_))
{
Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
- if (UNBOUNDP (val))
- return default_;
- return val;
+ return UNBOUNDP (val) ? default_ : val;
}
DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
return head;
}
-/* Symbol plists are directly accessible, so we need to protect against
- invalid property list structure */
-
-static Lisp_Object
-symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
-{
- Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
- 0, ERROR_ME);
- return UNBOUNDP (val) ? default_ : val;
-}
-
-static void
-symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
-{
- external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
-}
-
-static int
-symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
-{
- return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
-}
-
-/* We store the string's extent info as the first element of the string's
- property list; and the string's MODIFF as the first or second element
- of the string's property list (depending on whether the extent info
- is present), but only if the string has been modified. This is ugly
- but it reduces the memory allocated for the string in the vast
- majority of cases, where the string is never modified and has no
- extent info. */
-
-
-static Lisp_Object *
-string_plist_ptr (struct Lisp_String *s)
-{
- Lisp_Object *ptr = &s->plist;
-
- if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
- ptr = &XCDR (*ptr);
- if (CONSP (*ptr) && INTP (XCAR (*ptr)))
- ptr = &XCDR (*ptr);
- return ptr;
-}
-
-static Lisp_Object
-string_getprop (struct Lisp_String *s, Lisp_Object property,
- Lisp_Object default_)
-{
- Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
- ERROR_ME);
- return UNBOUNDP (val) ? default_ : val;
-}
-
-static void
-string_putprop (struct Lisp_String *s, Lisp_Object property,
- Lisp_Object value)
-{
- external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
-}
-
-static int
-string_remprop (struct Lisp_String *s, Lisp_Object property)
-{
- return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
-}
-
-static Lisp_Object
-string_plist (struct Lisp_String *s)
-{
- return *string_plist_ptr (s);
-}
-
DEFUN ("get", Fget, 2, 3, 0, /*
-Return the value of OBJECT's PROPNAME property.
-This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
+Return the value of OBJECT's PROPERTY property.
+This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
If there is no such property, return optional third arg DEFAULT
-\(which defaults to `nil'). OBJECT can be a symbol, face, extent,
-or string. See also `put', `remprop', and `object-plist'.
+\(which defaults to `nil'). OBJECT can be a symbol, string, extent,
+face, or glyph. See also `put', `remprop', and `object-plist'.
*/
- (object, propname, default_))
+ (object, property, default_))
{
/* Various places in emacs call Fget() and expect it not to quit,
so don't quit. */
+ Lisp_Object val;
- /* It's easiest to treat symbols specially because they may not
- be an lrecord */
- if (SYMBOLP (object))
- return symbol_getprop (object, propname, default_);
- else if (STRINGP (object))
- return string_getprop (XSTRING (object), propname, default_);
- else if (LRECORDP (object))
- {
- CONST struct lrecord_implementation *imp
- = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (!imp->getprop)
- goto noprops;
-
- {
- Lisp_Object val = (imp->getprop) (object, propname);
- if (UNBOUNDP (val))
- val = default_;
- return val;
- }
- }
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
+ val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
else
- {
- noprops:
- signal_simple_error ("Object type has no properties", object);
- return Qnil; /* Not reached */
- }
+ signal_simple_error ("Object type has no properties", object);
+
+ return UNBOUNDP (val) ? default_ : val;
}
DEFUN ("put", Fput, 3, 3, 0, /*
-Store OBJECT's PROPNAME property with value VALUE.
-It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
-symbol, face, extent, or string.
-
+Set OBJECT's PROPERTY to VALUE.
+It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
+OBJECT can be a symbol, face, extent, or string.
For a string, no properties currently have predefined meanings.
For the predefined properties for extents, see `set-extent-property'.
For the predefined properties for faces, see `set-face-property'.
-
See also `get', `remprop', and `object-plist'.
*/
- (object, propname, value))
+ (object, property, value))
{
- CHECK_SYMBOL (propname);
CHECK_LISP_WRITEABLE (object);
- if (SYMBOLP (object))
- symbol_putprop (object, propname, value);
- else if (STRINGP (object))
- string_putprop (XSTRING (object), propname, value);
- else if (LRECORDP (object))
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
{
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->putprop)
- {
- if (! (imp->putprop) (object, propname, value))
- signal_simple_error ("Can't set property on object", propname);
- }
- else
- goto noprops;
+ if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
+ (object, property, value))
+ signal_simple_error ("Can't set property on object", property);
}
else
- {
- noprops:
- signal_simple_error ("Object type has no settable properties", object);
- }
+ signal_simple_error ("Object type has no settable properties", object);
return value;
}
DEFUN ("remprop", Fremprop, 2, 2, 0, /*
-Remove from OBJECT's property list the property PROPNAME and its
-value. OBJECT can be a symbol, face, extent, or string. Returns
-non-nil if the property list was actually changed (i.e. if PROPNAME
-was present in the property list). See also `get', `put', and
-`object-plist'.
+Remove, from OBJECT's property list, PROPERTY and its corresponding value.
+OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
+if the property list was actually modified (i.e. if PROPERTY was present
+in the property list). See also `get', `put', and `object-plist'.
*/
- (object, propname))
+ (object, property))
{
- int retval = 0;
+ int ret = 0;
- CHECK_SYMBOL (propname);
CHECK_LISP_WRITEABLE (object);
- if (SYMBOLP (object))
- retval = symbol_remprop (object, propname);
- else if (STRINGP (object))
- retval = string_remprop (XSTRING (object), propname);
- else if (LRECORDP (object))
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
{
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->remprop)
- {
- retval = (imp->remprop) (object, propname);
- if (retval == -1)
- signal_simple_error ("Can't remove property from object",
- propname);
- }
- else
- goto noprops;
+ ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
+ if (ret == -1)
+ signal_simple_error ("Can't remove property from object", property);
}
else
- {
- noprops:
- signal_simple_error ("Object type has no removable properties", object);
- }
+ signal_simple_error ("Object type has no removable properties", object);
- return retval ? Qt : Qnil;
+ return ret ? Qt : Qnil;
}
DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
-Return a property list of OBJECT's props.
-For a symbol this is equivalent to `symbol-plist'.
-Do not modify the property list directly; this may or may not have
-the desired effects. (In particular, for a property with a special
-interpretation, this will probably have no effect at all.)
+Return a property list of OBJECT's properties.
+For a symbol, this is equivalent to `symbol-plist'.
+OBJECT can be a symbol, string, extent, face, or glyph.
+Do not modify the returned property list directly;
+this may or may not have the desired effects. Use `put' instead.
*/
(object))
{
- if (SYMBOLP (object))
- return Fsymbol_plist (object);
- else if (STRINGP (object))
- return string_plist (XSTRING (object));
- else if (LRECORDP (object))
- {
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->plist)
- return (imp->plist) (object);
- else
- signal_simple_error ("Object type has no properties", object);
- }
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
+ return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
else
signal_simple_error ("Object type has no properties", object);
return 0;
if (LRECORDP (obj1))
{
- CONST struct lrecord_implementation
+ const struct lrecord_implementation
*imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
*imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
retry:
if (STRINGP (array))
{
- struct Lisp_String *s = XSTRING (array);
+ Lisp_String *s = XSTRING (array);
Bytecount old_bytecount = string_length (s);
Bytecount new_bytecount;
Bytecount item_bytecount;
}
else if (BIT_VECTORP (array))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (array);
int len = bit_vector_length (v);
int bit;
CHECK_BIT (item);
}
else if (BIT_VECTORP (sequence))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
for (i = 0; i < leni; i++)
{
args[1] = make_int (bit_vector_bit (v, i));
}
}
else
- abort(); /* cannot get here since Flength(sequence) did not get an error */
+ abort (); /* unreachable, since Flength (sequence) did not get an error */
if (vals)
UNGCPRO;
size_t len = XINT (Flength (sequence));
Lisp_Object *args;
int i;
- struct gcpro gcpro1;
int nargs = len + len - 1;
- if (nargs < 0) return build_string ("");
+ if (len == 0) return build_string ("");
args = alloca_array (Lisp_Object, nargs);
- GCPRO1 (separator);
mapcar1 (len, args, function, sequence);
- UNGCPRO;
for (i = len - 1; i >= 0; i--)
args[i + i] = args[i];
}
\f
+
+
+DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
+Destructively replace the list OLD with NEW.
+This is like (copy-sequence NEW) except that it reuses the
+conses in OLD as much as possible. If OLD and NEW are the same
+length, no consing will take place.
+*/
+ (old, new))
+{
+ Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
+
+ EXTERNAL_LIST_LOOP (tail, new)
+ {
+ if (!NILP (oldtail))
+ {
+ CHECK_CONS (oldtail);
+ XCAR (oldtail) = XCAR (tail);
+ }
+ else if (!NILP (prevoldtail))
+ {
+ XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
+ prevoldtail = XCDR (prevoldtail);
+ }
+ else
+ old = oldtail = Fcons (XCAR (tail), Qnil);
+
+ if (!NILP (oldtail))
+ {
+ prevoldtail = oldtail;
+ oldtail = XCDR (oldtail);
+ }
+ }
+
+ if (!NILP (prevoldtail))
+ XCDR (prevoldtail) = Qnil;
+ else
+ old = Qnil;
+
+ return old;
+}
+
+\f
/* #### this function doesn't belong in this file! */
DEFUN ("load-average", Fload_average, 0, 1, 0, /*
void
syms_of_fns (void)
{
+ INIT_LRECORD_IMPLEMENTATION (bit_vector);
+
defsymbol (&Qstring_lessp, "string-lessp");
defsymbol (&Qidentity, "identity");
defsymbol (&Qyes_or_no_p, "yes-or-no-p");
DEFSUBR (Fmapvector);
DEFSUBR (Fmapc_internal);
DEFSUBR (Fmapconcat);
+ DEFSUBR (Freplace_list);
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);