static int internal_old_equal (Lisp_Object, Lisp_Object, int);
static Lisp_Object
-mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_bit_vector (Lisp_Object obj)
{
return Qnil;
}
static void
print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
- int i;
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
- int len = bit_vector_length (v);
- int last = len;
+ size_t i;
+ Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ size_t len = bit_vector_length (v);
+ size_t last = len;
if (INTP (Vprint_length))
last = min (len, XINT (Vprint_length));
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)));
}
-DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
- mark_bit_vector, print_bit_vector, 0,
- bit_vector_equal, bit_vector_hash, 0,
- struct Lisp_Bit_Vector);
+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) },
+ { XD_END }
+};
+
+
+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
return make_int (XSTRING_CHAR_LENGTH (sequence));
else if (CONSP (sequence))
{
- int len;
+ size_t len;
GET_EXTERNAL_LIST_LENGTH (sequence, len);
return make_int (len);
}
(list))
{
Lisp_Object hare, tortoise;
- int len;
+ size_t len;
for (hare = tortoise = list, len = 0;
CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
(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
Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
Lisp_Object last = list_copy;
Lisp_Object hare, tortoise;
- int len;
+ size_t len;
for (tortoise = hare = XCDR (list), len = 1;
CONSP (hare);
}
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))
{
- int len, f, t;
-
- if (STRINGP (seq))
- return Fsubstring (seq, from, to);
+ EMACS_INT len, s, e;
- if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
- {
- check_losing_bytecode ("subseq", seq);
- seq = wrong_type_argument (Qsequencep, seq);
- }
+ if (STRINGP (sequence))
+ return Fsubstring (sequence, start, end);
- len = XINT (Flength (seq));
+ len = XINT (Flength (sequence));
- CHECK_INT (from);
- f = XINT (from);
- if (f < 0)
- f = len + f;
+ CHECK_INT (start);
+ s = XINT (start);
+ if (s < 0)
+ s = len + s;
- 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);
- int i;
- Lisp_Object *in_elts = XVECTOR_DATA (seq);
+ Lisp_Object result = make_vector (e - s, Qnil);
+ EMACS_INT i;
+ 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;
- int i;
+ 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);
- 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
*/
(n, list))
{
- REGISTER int i;
+ REGISTER size_t i;
REGISTER Lisp_Object tail = list;
CHECK_NATNUM (n);
for (i = XINT (n); i; i--)
#ifdef LOSING_BYTECODE
else if (COMPILED_FUNCTIONP (sequence))
{
- int idx = XINT (n);
+ EMACS_INT idx = XINT (n);
if (idx < 0)
{
lose:
*/
(list, n))
{
- int int_n, count;
+ EMACS_INT int_n, count;
Lisp_Object retval, tortoise, hare;
CHECK_LIST (list);
*/
(list, n))
{
- int int_n;
+ EMACS_INT int_n;
CHECK_LIST (list);
plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
int laxp, int depth)
{
- int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
+ int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
int la, lb, m, i, fill;
Lisp_Object *keys, *vals;
char *flags;
{
if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
{
- if ((eqp
- /* We narrowly escaped being Ebolified here. */
- ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
- : !internal_equal (v, vals [i], depth)))
+ if (eqp
+ /* We narrowly escaped being Ebolified here. */
+ ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
+ : !internal_equal (v, vals [i], depth))
/* a property in B has a different value than in A */
goto MISMATCH;
flags [i] = 1;
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;
}
-void
-pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
-{
- Fput (sym, prop, Fpurecopy (val));
-}
-
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);
\f
DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
-Store each element of ARRAY with ITEM.
+Destructively modify ARRAY by replacing each element with ITEM.
ARRAY is a vector, bit vector, or string.
*/
(array, item))
retry:
if (STRINGP (array))
{
- Emchar charval;
- struct Lisp_String *s = XSTRING (array);
- Charcount len = string_char_length (s);
- Charcount i;
+ Lisp_String *s = XSTRING (array);
+ Bytecount old_bytecount = string_length (s);
+ Bytecount new_bytecount;
+ Bytecount item_bytecount;
+ Bufbyte item_buf[MAX_EMCHAR_LEN];
+ Bufbyte *p;
+ Bufbyte *end;
+
CHECK_CHAR_COERCE_INT (item);
CHECK_LISP_WRITEABLE (array);
- charval = XCHAR (item);
- for (i = 0; i < len; i++)
- set_string_char (s, i, charval);
+
+ item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
+ new_bytecount = item_bytecount * string_char_length (s);
+
+ resize_string (s, -1, new_bytecount - old_bytecount);
+
+ for (p = string_data (s), end = p + new_bytecount;
+ p < end;
+ p += item_bytecount)
+ memcpy (p, item_buf, item_bytecount);
+ *p = '\0';
+
bump_string_modiff (array);
}
else if (VECTORP (array))
}
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);
}
\f
-/* This is the guts of all mapping functions.
- Apply fn to each element of seq, one by one,
- storing the results into elements of vals, a C vector of Lisp_Objects.
- leni is the length of vals, which should also be the length of seq.
+/* This is the guts of several mapping functions.
+ Apply FUNCTION to each element of SEQUENCE, one by one,
+ storing the results into elements of VALS, a C vector of Lisp_Objects.
+ LENI is the length of VALS, which should also be the length of SEQUENCE.
If VALS is a null pointer, do not accumulate the results. */
static void
-mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
+mapcar1 (size_t leni, Lisp_Object *vals,
+ Lisp_Object function, Lisp_Object sequence)
{
Lisp_Object result;
Lisp_Object args[2];
gcpro1.nvars = 0;
}
- args[0] = fn;
+ args[0] = function;
- if (LISTP (seq))
+ if (LISTP (sequence))
{
- for (i = 0; i < leni; i++)
+ /* A devious `function' could either:
+ - insert garbage into the list in front of us, causing XCDR to crash
+ - amputate the list behind us using (setcdr), causing the remaining
+ elts to lose their GCPRO status.
+
+ if (vals != 0) we avoid this by copying the elts into the
+ `vals' array. By a stroke of luck, `vals' is exactly large
+ enough to hold the elts left to be traversed as well as the
+ results computed so far.
+
+ if (vals == 0) we don't have any free space available and
+ don't want to eat up any more stack with alloca().
+ So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
+
+ if (vals)
{
- args[1] = XCAR (seq);
- seq = XCDR (seq);
- result = Ffuncall (2, args);
- if (vals) vals[gcpro1.nvars++] = result;
+ Lisp_Object *val = vals;
+ Lisp_Object elt;
+
+ LIST_LOOP_2 (elt, sequence)
+ *val++ = elt;
+
+ gcpro1.nvars = leni;
+
+ for (i = 0; i < leni; i++)
+ {
+ args[1] = vals[i];
+ vals[i] = Ffuncall (2, args);
+ }
+ }
+ else
+ {
+ Lisp_Object elt, tail;
+ struct gcpro ngcpro1;
+
+ NGCPRO1 (tail);
+
+ {
+ EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
+ {
+ args[1] = elt;
+ Ffuncall (2, args);
+ }
+ }
+
+ NUNGCPRO;
}
}
- else if (VECTORP (seq))
+ else if (VECTORP (sequence))
{
- Lisp_Object *objs = XVECTOR_DATA (seq);
+ Lisp_Object *objs = XVECTOR_DATA (sequence);
for (i = 0; i < leni; i++)
{
args[1] = *objs++;
if (vals) vals[gcpro1.nvars++] = result;
}
}
- else if (STRINGP (seq))
+ else if (STRINGP (sequence))
{
- Bufbyte *p = XSTRING_DATA (seq);
- for (i = 0; i < leni; i++)
+ /* The string data of `sequence' might be relocated during GC. */
+ Bytecount slen = XSTRING_LENGTH (sequence);
+ Bufbyte *p = alloca_array (Bufbyte, slen);
+ Bufbyte *end = p + slen;
+
+ memcpy (p, XSTRING_DATA (sequence), slen);
+
+ while (p < end)
{
args[1] = make_char (charptr_emchar (p));
INC_CHARPTR (p);
if (vals) vals[gcpro1.nvars++] = result;
}
}
- else if (BIT_VECTORP (seq))
+ else if (BIT_VECTORP (sequence))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
+ 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(seq) did not get an error */
+ abort (); /* unreachable, since Flength (sequence) did not get an error */
if (vals)
UNGCPRO;
}
DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
-Apply FN to each element of SEQ, and concat the results as strings.
-In between each pair of results, stick in SEP.
-Thus, " " as SEP results in spaces between the values returned by FN.
+Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
+In between each pair of results, insert SEPARATOR. Thus, using " " as
+SEPARATOR results in spaces between the values returned by FUNCTION.
+SEQUENCE may be a list, a vector, a bit vector, or a string.
*/
- (fn, seq, sep))
+ (function, sequence, separator))
{
- size_t len = XINT (Flength (seq));
+ 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 (sep);
- mapcar1 (len, args, fn, seq);
- UNGCPRO;
+ mapcar1 (len, args, function, sequence);
for (i = len - 1; i >= 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
- args[i] = sep;
+ args[i] = separator;
return Fconcat (nargs, args);
}
DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
-Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
-The result is a list just as long as SEQUENCE.
+Apply FUNCTION to each element of SEQUENCE; return a list of the results.
+The result is a list of the same length as SEQUENCE.
SEQUENCE may be a list, a vector, a bit vector, or a string.
*/
- (fn, seq))
+ (function, sequence))
{
- size_t len = XINT (Flength (seq));
+ size_t len = XINT (Flength (sequence));
Lisp_Object *args = alloca_array (Lisp_Object, len);
- mapcar1 (len, args, fn, seq);
+ mapcar1 (len, args, function, sequence);
return Flist (len, args);
}
DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
-Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
+Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
The result is a vector of the same length as SEQUENCE.
-SEQUENCE may be a list, a vector or a string.
+SEQUENCE may be a list, a vector, a bit vector, or a string.
*/
- (fn, seq))
+ (function, sequence))
{
- size_t len = XINT (Flength (seq));
+ size_t len = XINT (Flength (sequence));
Lisp_Object result = make_vector (len, Qnil);
struct gcpro gcpro1;
GCPRO1 (result);
- mapcar1 (len, XVECTOR_DATA (result), fn, seq);
+ mapcar1 (len, XVECTOR_DATA (result), function, sequence);
UNGCPRO;
return result;
}
-DEFUN ("mapc", Fmapc, 2, 2, 0, /*
+DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
Apply FUNCTION to each element of SEQUENCE.
SEQUENCE may be a list, a vector, a bit vector, or a string.
This function is like `mapcar' but does not accumulate the results,
which is more efficient if you do not use the results.
+
+The difference between this and `mapc' is that `mapc' supports all
+the spiffy Common Lisp arguments. You should normally use `mapc'.
*/
- (fn, seq))
+ (function, sequence))
{
- mapcar1 (XINT (Flength (seq)), 0, fn, seq);
+ mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
- return seq;
+ return sequence;
+}
+
+\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
\f
Lisp_Object Vfeatures;
-DEFUN ("featurep", Ffeaturep, 1, 2, 0, /*
+DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
Return non-nil if feature FEXP is present in this Emacs.
Use this to conditionalize execution of lisp code based on the
presence or absence of emacs or environment extensions.
for supporting multiple Emacs variants, lobby Richard Stallman at
<bug-gnu-emacs@prep.ai.mit.edu>.
*/
- (fexp, console))
+ (fexp))
{
#ifndef FEATUREP_SYNTAX
CHECK_SYMBOL (fexp);
if (SYMBOLP (fexp))
{
/* Original definition */
- return (NILP (Fmemq (fexp, Vfeatures))
- &&
- NILP (Fmemq (fexp,
- CONSOLE_FEATURES (decode_console (console)))))
- ? Qnil : Qt;
+ return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
}
else if (INTP (fexp) || FLOATP (fexp))
{
CHECK_SYMBOL (feature);
if (!NILP (Vautoload_queue))
Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
-
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
Vfeatures = Fcons (feature, Vfeatures);
return feature;
}
-DEFUN ("provide-on-console", Fprovide_on_console, 2, 2, 0, /*
-Announce that FEATURE is a feature of the current Emacs.
-This function updates the value of `console-features' for the provided CONSOLE.
-*/
- (feature, console))
-{
- Lisp_Object tem;
- CHECK_SYMBOL (feature);
-
- if (SYMBOLP (console))
- {
- struct console_methods* meths = decode_console_type (console, ERROR_ME);
-
- tem = Fmemq (feature, CONMETH_FEATURES (meths));
- if (NILP (tem))
- CONMETH_FEATURES (meths) =
- Fcons (feature, CONMETH_FEATURES (meths));
- }
- else
- {
- struct console* pconsole;
- CHECK_CONSOLE (console);
-
- pconsole = decode_console (console);
- tem = Fmemq (feature, CONSOLE_FEATURES (pconsole));
- if (NILP (tem))
- CONSOLE_FEATURES (pconsole) =
- Fcons (feature, CONSOLE_FEATURES (pconsole));
- }
- return feature;
-}
-
DEFUN ("require", Frequire, 1, 2, 0, /*
If feature FEATURE is not loaded, load it from FILENAME.
If FEATURE is not a member of the list `features', then the feature
CHECK_SYMBOL (feature);
tem = Fmemq (feature, Vfeatures);
LOADHIST_ATTACH (Fcons (Qrequire, feature));
- if (!NILP (tem)
- ||
- !NILP (Fmemq (feature, CONSOLE_FEATURES
- (XCONSOLE (Fselected_console ())))))
+ if (!NILP (tem))
return feature;
else
{
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 (Fnconc);
DEFSUBR (Fmapcar);
DEFSUBR (Fmapvector);
- DEFSUBR (Fmapc);
+ DEFSUBR (Fmapc_internal);
DEFSUBR (Fmapconcat);
+ DEFSUBR (Freplace_list);
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);
DEFSUBR (Fprovide);
- DEFSUBR (Fprovide_on_console);
DEFSUBR (Fbase64_encode_region);
DEFSUBR (Fbase64_encode_string);
DEFSUBR (Fbase64_decode_region);