/* Random utility Lisp functions.
Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
Copyright (C) 1995, 1996 Ben Wing.
+ Copyright (C) 2002, 2003, 2004, 2008 MORIOKA Tomohiko
This file is part of XEmacs.
#include "lisp.h"
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-#include <errno.h>
+#include "sysfile.h"
#include "buffer.h"
#include "bytecode.h"
#include "lstream.h"
#include "opaque.h"
+
+\f
+static Lisp_Object free_malloced_ptr(Lisp_Object unwind_obj)
+{
+ void *ptr = (void *)get_opaque_ptr(unwind_obj);
+ xfree(ptr);
+ free_opaque_ptr(unwind_obj);
+ return Qnil;
+}
+
+/* Don't use alloca for regions larger than this, lest we overflow
+ the stack. */
+#define MAX_ALLOCA 65536
+
+/* We need to setup proper unwinding, because there is a number of
+ ways these functions can blow up, and we don't want to have memory
+ leaks in those cases. */
+#define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
+ size_t XOA_len = (len); \
+ if (XOA_len > MAX_ALLOCA ) { \
+ ptr = xnew_array (type, XOA_len); \
+ record_unwind_protect (free_malloced_ptr, \
+ make_opaque_ptr ((void *)ptr)); \
+ } \
+ else \
+ ptr = alloca_array (type, XOA_len); \
+} while (0)
+
+#define XMALLOC_UNBIND(ptr, len, speccount) do { \
+ if ((len) > MAX_ALLOCA) \
+ unbind_to (speccount, Qnil); \
+} while (0)
+
+\f
+
+
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
Lisp_Object Qidentity;
static int internal_old_equal (Lisp_Object, Lisp_Object, int);
+Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
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));
+ last = min ((EMACS_INT) len, XINT (Vprint_length));
write_c_string ("#*", printcharfun);
for (i = 0; i < last; i++)
{
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,
- 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, unsigned long, 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.
DEFUN ("random", Frandom, 0, 1, 0, /*
Return a pseudo-random number.
All integers representable in Lisp are equally likely.
- On most systems, this is 28 bits' worth.
+ On most systems, this is 31 bits' worth.
With positive integer argument N, return random number in interval [0,N).
With argument t, set the random number seed from the current time and pid.
*/
it's possible to get a quotient larger than limit; discarding
these values eliminates the bias that would otherwise appear
when using a large limit. */
- denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
+ denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit);
do
val = get_random () / denominator;
while (val >= XINT (limit));
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);
`equal' is the same as in XEmacs, in that respect.)
Symbols are also allowed; their print names are used instead.
*/
- (s1, s2))
+ (string1, string2))
{
Bytecount len;
- struct Lisp_String *p1, *p2;
+ Lisp_String *p1, *p2;
- if (SYMBOLP (s1))
- p1 = XSYMBOL (s1)->name;
+ if (SYMBOLP (string1))
+ p1 = XSYMBOL (string1)->name;
else
{
- CHECK_STRING (s1);
- p1 = XSTRING (s1);
+ CHECK_STRING (string1);
+ p1 = XSTRING (string1);
}
- if (SYMBOLP (s2))
- p2 = XSYMBOL (s2)->name;
+ if (SYMBOLP (string2))
+ p2 = XSYMBOL (string2)->name;
else
{
- CHECK_STRING (s2);
- p2 = XSTRING (s2);
+ CHECK_STRING (string2);
+ p2 = XSTRING (string2);
}
return (((len = string_length (p1)) == string_length (p2)) &&
Unicode. When Unicode support is added to XEmacs/Mule, this problem
may be solved.
*/
- (s1, s2))
+ (string1, string2))
{
- struct Lisp_String *p1, *p2;
+ Lisp_String *p1, *p2;
Charcount end, len2;
int i;
- if (SYMBOLP (s1))
- p1 = XSYMBOL (s1)->name;
+ if (SYMBOLP (string1))
+ p1 = XSYMBOL (string1)->name;
else
{
- CHECK_STRING (s1);
- p1 = XSTRING (s1);
+ CHECK_STRING (string1);
+ p1 = XSTRING (string1);
}
- if (SYMBOLP (s2))
- p2 = XSYMBOL (s2)->name;
+ if (SYMBOLP (string2))
+ p2 = XSYMBOL (string2)->name;
else
{
- CHECK_STRING (s2);
- p2 = XSTRING (s2);
+ CHECK_STRING (string2);
+ p2 = XSTRING (string2);
}
end = string_char_length (p1);
properly, it would still not work because strcoll() does not
handle multiple locales. This is the fundamental flaw in the
locale model. */
- Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
- /* Compare strings using collation order of locale. */
- /* Need to be tricky to handle embedded nulls. */
+ {
+ Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
+ /* Compare strings using collation order of locale. */
+ /* Need to be tricky to handle embedded nulls. */
- for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
- {
- int val = strcoll ((char *) string_data (p1) + i,
- (char *) string_data (p2) + i);
- if (val < 0)
- return Qt;
- if (val > 0)
- return Qnil;
- }
+ for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
+ {
+ int val = strcoll ((char *) string_data (p1) + i,
+ (char *) string_data (p2) + i);
+ if (val < 0)
+ return Qt;
+ if (val > 0)
+ return Qnil;
+ }
+ }
#else /* not I18N2, or MULE */
- /* #### It is not really necessary to do this: We could compare
- byte-by-byte and still get a reasonable comparison, since this
- would compare characters with a charset in the same way.
- With a little rearrangement of the leading bytes, we could
- make most inter-charset comparisons work out the same, too;
- even if some don't, this is not a big deal because inter-charset
- comparisons aren't really well-defined anyway. */
- for (i = 0; i < end; i++)
- {
- if (string_char (p1, i) != string_char (p2, i))
- return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil;
- }
+ {
+ Bufbyte *ptr1 = string_data (p1);
+ Bufbyte *ptr2 = string_data (p2);
+
+ /* #### It is not really necessary to do this: We could compare
+ byte-by-byte and still get a reasonable comparison, since this
+ would compare characters with a charset in the same way. With
+ a little rearrangement of the leading bytes, we could make most
+ inter-charset comparisons work out the same, too; even if some
+ don't, this is not a big deal because inter-charset comparisons
+ aren't really well-defined anyway. */
+ for (i = 0; i < end; i++)
+ {
+ if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
+ return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
+ INC_CHARPTR (ptr1);
+ INC_CHARPTR (ptr2);
+ }
+ }
#endif /* not I18N2, or MULE */
/* Can't do i < len2 because then comparison between "foo" and "foo^@"
won't work right in I18N2 case */
*/
(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
int last_special);
Lisp_Object
-concat2 (Lisp_Object s1, Lisp_Object s2)
+concat2 (Lisp_Object string1, Lisp_Object string2)
{
Lisp_Object args[2];
- args[0] = s1;
- args[1] = s2;
+ args[0] = string1;
+ args[1] = string2;
return concat (2, args, c_string, 0);
}
Lisp_Object
-concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
+concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
{
Lisp_Object args[3];
- args[0] = s1;
- args[1] = s2;
- args[2] = s3;
+ args[0] = string1;
+ args[1] = string2;
+ args[2] = string3;
return concat (3, args, c_string, 0);
}
Lisp_Object
-vconcat2 (Lisp_Object s1, Lisp_Object s2)
+vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
{
Lisp_Object args[2];
- args[0] = s1;
- args[1] = s2;
+ args[0] = vec1;
+ args[1] = vec2;
return concat (2, args, c_vector, 0);
}
Lisp_Object
-vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
+vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
{
Lisp_Object args[3];
- args[0] = s1;
- args[1] = s2;
- args[2] = s3;
+ args[0] = vec1;
+ args[1] = vec2;
+ args[2] = vec3;
return concat (3, args, c_vector, 0);
}
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);
Bufbyte *string_result = 0;
Bufbyte *string_result_ptr = 0;
struct gcpro gcpro1;
+ int speccount = specpdl_depth();
+ Charcount total_length;
/* The modus operandi in Emacs is "caller gc-protects args".
However, concat is called many times in Emacs on freshly
the result in the returned string's `string-translatable' property. */
#endif
if (target_type == c_string)
- args_mse = alloca_array (struct merge_string_extents_struct, nargs);
+ XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);
/* In append, the last arg isn't treated like the others */
if (last_special && nargs > 0)
/* Charcount is a misnomer here as we might be dealing with the
length of a vector or list, but emphasizes that we're not dealing
with Bytecounts in strings */
- Charcount total_length;
+ /* Charcount total_length; */
for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
{
{
case c_cons:
if (total_length == 0)
+ {
/* In append, if all but last arg are nil, return last arg */
+ XMALLOC_UNBIND(args_mse, nargs, speccount);
RETURN_UNGCPRO (last_tail);
+ }
val = Fmake_list (make_int (total_length), Qnil);
break;
case c_vector:
realloc()ing in order to make the char fit properly.
O(N^2) yuckage. */
val = Qnil;
- string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
+ XMALLOC_OR_ALLOCA( string_result,
+ total_length * MAX_EMCHAR_LEN,
+ Bufbyte );
string_result_ptr = string_result;
break;
default:
- abort ();
+ val = Qnil;
+ ABORT ();
}
}
args_mse[argnum].entry_offset, 0,
args_mse[argnum].entry_length);
}
+ XMALLOC_UNBIND(string_result, total_length * MAX_EMCHAR_LEN, speccount);
+ XMALLOC_UNBIND(args_mse, nargs, speccount);
}
if (!NILP (prev))
*/
(arg, vecp))
{
+ return safe_copy_tree (arg, vecp, 0);
+}
+
+Lisp_Object
+safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
+{
+ if (depth > 200)
+ signal_simple_error ("Stack overflow in copy-tree", arg);
+
if (CONSP (arg))
{
Lisp_Object rest;
Lisp_Object elt = XCAR (rest);
QUIT;
if (CONSP (elt) || VECTORP (elt))
- XCAR (rest) = Fcopy_tree (elt, vecp);
+ XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
- XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
+ XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
rest = XCDR (rest);
}
}
Lisp_Object elt = XVECTOR_DATA (arg) [j];
QUIT;
if (CONSP (elt) || VECTORP (elt))
- XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
+ XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
}
}
return arg;
}
DEFUN ("substring", Fsubstring, 2, 3, 0, /*
-Return a substring of STRING, starting at index FROM and ending before TO.
-TO may be nil or omitted; then the substring runs to the end of STRING.
-If FROM or TO is negative, it counts from the end.
-Relevant parts of the string-extent-data are copied in the new string.
+Return the substring of STRING starting at START and ending before END.
+END may be nil or omitted; then the substring runs to the end of STRING.
+If START or END is negative, it counts from the end.
+Relevant parts of the string-extent-data are copied to the new string.
*/
- (string, from, to))
+ (string, start, end))
{
- Charcount ccfr, ccto;
- Bytecount bfr, bto;
+ Charcount ccstart, ccend;
+ Bytecount bstart, blen;
Lisp_Object val;
CHECK_STRING (string);
- CHECK_INT (from);
- get_string_range_char (string, from, to, &ccfr, &ccto,
+ CHECK_INT (start);
+ get_string_range_char (string, start, end, &ccstart, &ccend,
GB_HISTORICAL_STRING_BEHAVIOR);
- bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
- bto = charcount_to_bytecount (XSTRING_DATA (string), ccto);
- val = make_string (XSTRING_DATA (string) + bfr, bto - bfr);
- /* Copy any applicable extent information into the new string: */
- copy_string_extents (val, string, 0, bfr, bto - bfr);
+ bstart = charcount_to_bytecount (XSTRING_DATA (string), ccstart);
+ blen = charcount_to_bytecount (XSTRING_DATA (string) + bstart, ccend - ccstart);
+ val = make_string (XSTRING_DATA (string) + bstart, blen);
+ /* Copy any applicable extent information into the new string. */
+ copy_string_extents (val, string, 0, bstart, blen);
return val;
}
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 */
+ return Qnil;
+ }
}
\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);
*/
(list, n))
{
- int int_n;
+ EMACS_INT int_n;
CHECK_LIST (list);
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
if (internal_equal (elt, list_elt, 0))
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
if (internal_old_equal (elt, list_elt, 0))
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
if (HACKEQ_UNSAFE (elt, list_elt))
Lisp_Object
memq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- Lisp_Object list_elt, tail;
LIST_LOOP_3 (list_elt, list, tail)
{
if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
}
DEFUN ("assoc", Fassoc, 2, 2, 0, /*
-Return non-nil if KEY is `equal' to the car of an element of LIST.
-The value is actually the element of LIST whose car equals KEY.
+Return non-nil if KEY is `equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
*/
- (key, list))
+ (key, alist))
{
/* This function can GC. */
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
if (internal_equal (key, elt_car, 0))
return elt;
}
DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
-Return non-nil if KEY is `old-equal' to the car of an element of LIST.
-The value is actually the element of LIST whose car equals KEY.
+Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car equals KEY.
*/
- (key, list))
+ (key, alist))
{
/* This function can GC. */
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
if (internal_old_equal (key, elt_car, 0))
return elt;
}
Lisp_Object
-assoc_no_quit (Lisp_Object key, Lisp_Object list)
+assoc_no_quit (Lisp_Object key, Lisp_Object alist)
{
int speccount = specpdl_depth ();
specbind (Qinhibit_quit, Qt);
- return unbind_to (speccount, Fassoc (key, list));
+ return unbind_to (speccount, Fassoc (key, alist));
}
DEFUN ("assq", Fassq, 2, 2, 0, /*
-Return non-nil if KEY is `eq' to the car of an element of LIST.
-The value is actually the element of LIST whose car is KEY.
-Elements of LIST that are not conses are ignored.
+Return non-nil if KEY is `eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
*/
- (key, list))
+ (key, alist))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
return elt;
}
DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
-Return non-nil if KEY is `old-eq' to the car of an element of LIST.
-The value is actually the element of LIST whose car is KEY.
-Elements of LIST that are not conses are ignored.
+Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
+The value is actually the element of ALIST whose car is KEY.
+Elements of ALIST that are not conses are ignored.
This function is provided only for byte-code compatibility with v19.
Do not use it.
*/
- (key, list))
+ (key, alist))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
if (HACKEQ_UNSAFE (key, elt_car))
return elt;
Use only on lists known never to be circular. */
Lisp_Object
-assq_no_quit (Lisp_Object key, Lisp_Object list)
+assq_no_quit (Lisp_Object key, Lisp_Object alist)
{
/* This cannot GC. */
- Lisp_Object elt;
- LIST_LOOP_2 (elt, list)
+ LIST_LOOP_2 (elt, alist)
{
Lisp_Object elt_car = XCAR (elt);
if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
}
DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
-Return non-nil if KEY is `equal' to the cdr of an element of LIST.
-The value is actually the element of LIST whose cdr equals KEY.
+Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
*/
- (key, list))
+ (value, alist))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
- if (internal_equal (key, elt_cdr, 0))
+ if (internal_equal (value, elt_cdr, 0))
return elt;
}
return Qnil;
}
DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
-Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
-The value is actually the element of LIST whose cdr equals KEY.
+Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr equals VALUE.
*/
- (key, list))
+ (value, alist))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
- if (internal_old_equal (key, elt_cdr, 0))
+ if (internal_old_equal (value, elt_cdr, 0))
return elt;
}
return Qnil;
}
DEFUN ("rassq", Frassq, 2, 2, 0, /*
-Return non-nil if KEY is `eq' to the cdr of an element of LIST.
-The value is actually the element of LIST whose cdr is KEY.
+Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr is VALUE.
*/
- (key, list))
+ (value, alist))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
- if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
+ if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
return elt;
}
return Qnil;
}
DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
-Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
-The value is actually the element of LIST whose cdr is KEY.
+Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
+The value is actually the element of ALIST whose cdr is VALUE.
*/
- (key, list))
+ (value, alist))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
{
- if (HACKEQ_UNSAFE (key, elt_cdr))
+ if (HACKEQ_UNSAFE (value, elt_cdr))
return elt;
}
return Qnil;
}
-/* Like Frassq, but caller must ensure that LIST is properly
+/* Like Frassq, but caller must ensure that ALIST is properly
nil-terminated and ebola-free. */
Lisp_Object
-rassq_no_quit (Lisp_Object key, Lisp_Object list)
+rassq_no_quit (Lisp_Object value, Lisp_Object alist)
{
- Lisp_Object elt;
- LIST_LOOP_2 (elt, list)
+ LIST_LOOP_2 (elt, alist)
{
Lisp_Object elt_cdr = XCDR (elt);
- if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
+ if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
return elt;
}
return Qnil;
*/
(elt, list))
{
- Lisp_Object list_elt;
EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
(internal_equal (elt, list_elt, 0)));
return list;
*/
(elt, list))
{
- Lisp_Object list_elt;
EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
(internal_old_equal (elt, list_elt, 0)));
return list;
*/
(elt, list))
{
- Lisp_Object list_elt;
EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
(EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
return list;
*/
(elt, list))
{
- Lisp_Object list_elt;
EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
(HACKEQ_UNSAFE (elt, list_elt)));
return list;
Lisp_Object
delq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- Lisp_Object list_elt;
LIST_LOOP_DELETE_IF (list_elt, list,
(EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
return list;
}
DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
-Delete by side effect any elements of LIST whose car is `equal' to KEY.
-The modified LIST is returned. If the first member of LIST has a car
+Delete by side effect any elements of ALIST whose car is `equal' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
that is `equal' to KEY, there is no way to remove it by side effect;
therefore, write `(setq foo (remassoc key foo))' to be sure of changing
the value of `foo'.
*/
- (key, list))
+ (key, alist))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
(CONSP (elt) &&
internal_equal (key, XCAR (elt), 0)));
- return list;
+ return alist;
}
Lisp_Object
-remassoc_no_quit (Lisp_Object key, Lisp_Object list)
+remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
{
int speccount = specpdl_depth ();
specbind (Qinhibit_quit, Qt);
- return unbind_to (speccount, Fremassoc (key, list));
+ return unbind_to (speccount, Fremassoc (key, alist));
}
DEFUN ("remassq", Fremassq, 2, 2, 0, /*
-Delete by side effect any elements of LIST whose car is `eq' to KEY.
-The modified LIST is returned. If the first member of LIST has a car
+Delete by side effect any elements of ALIST whose car is `eq' to KEY.
+The modified ALIST is returned. If the first member of ALIST has a car
that is `eq' to KEY, there is no way to remove it by side effect;
therefore, write `(setq foo (remassq key foo))' to be sure of changing
the value of `foo'.
*/
- (key, list))
+ (key, alist))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
(CONSP (elt) &&
EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return list;
+ return alist;
}
/* no quit, no errors; be careful */
Lisp_Object
-remassq_no_quit (Lisp_Object key, Lisp_Object list)
+remassq_no_quit (Lisp_Object key, Lisp_Object alist)
{
- Lisp_Object elt;
- LIST_LOOP_DELETE_IF (elt, list,
+ LIST_LOOP_DELETE_IF (elt, alist,
(CONSP (elt) &&
EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return list;
+ return alist;
}
DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
-Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
-The modified LIST is returned. If the first member of LIST has a car
+Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
that is `equal' to VALUE, there is no way to remove it by side effect;
therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
the value of `foo'.
*/
- (value, list))
+ (value, alist))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
(CONSP (elt) &&
internal_equal (value, XCDR (elt), 0)));
- return list;
+ return alist;
}
DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
-Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
-The modified LIST is returned. If the first member of LIST has a car
+Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
+The modified ALIST is returned. If the first member of ALIST has a car
that is `eq' to VALUE, there is no way to remove it by side effect;
therefore, write `(setq foo (remrassq value foo))' to be sure of changing
the value of `foo'.
*/
- (value, list))
+ (value, alist))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
(CONSP (elt) &&
EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
- return list;
+ return alist;
}
/* Like Fremrassq, fast and unsafe; be careful */
Lisp_Object
-remrassq_no_quit (Lisp_Object value, Lisp_Object list)
+remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
{
- Lisp_Object elt;
- LIST_LOOP_DELETE_IF (elt, list,
+ LIST_LOOP_DELETE_IF (elt, alist,
(CONSP (elt) &&
EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
- return list;
+ return alist;
}
DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
(list))
{
Lisp_Object reversed_list = Qnil;
- Lisp_Object elt;
EXTERNAL_LIST_LOOP_2 (elt, list)
{
reversed_list = Fcons (elt, reversed_list);
Lisp_Object back, tem;
Lisp_Object front = list;
Lisp_Object len = Flength (list);
- int length = XINT (len);
- if (length < 2)
+ if (XINT (len) < 2)
return list;
- XSETINT (len, (length / 2) - 1);
+ len = make_int (XINT (len) / 2 - 1);
tem = Fnthcdr (len, list);
back = Fcdr (tem);
Fsetcdr (tem, Qnil);
PREDICATE is called with two elements of LIST, and should return T
if the first element is "less" than the second.
*/
- (list, pred))
+ (list, predicate))
{
- return list_sort (list, pred, merge_pred_function);
+ return list_sort (list, predicate, merge_pred_function);
}
Lisp_Object
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;
Lisp_Object rest;
+ int speccount = specpdl_depth();
if (NILP (a) && NILP (b))
return 0;
lb = XINT (Flength (b));
m = (la > lb ? la : lb);
fill = 0;
- keys = alloca_array (Lisp_Object, m);
- vals = alloca_array (Lisp_Object, m);
- flags = alloca_array (char, m);
+ XMALLOC_OR_ALLOCA(keys, m, Lisp_Object);
+ XMALLOC_OR_ALLOCA(vals, m, Lisp_Object);
+ XMALLOC_OR_ALLOCA(flags, m, char);
/* First extract the pairs from A. */
for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
{
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;
if (flags [i] == 0)
goto MISMATCH;
+
+ XMALLOC_UNBIND(flags, m, speccount);
+ XMALLOC_UNBIND(vals, m, speccount);
+ XMALLOC_UNBIND(keys, m, speccount);
/* Ok. */
return 0;
MISMATCH:
+ XMALLOC_UNBIND(flags, m, speccount);
+ XMALLOC_UNBIND(vals, m, speccount);
+ XMALLOC_UNBIND(keys, m, speccount);
return 1;
}
bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
{
if (ERRB_EQ (errb, ERROR_ME))
- /* #### Eek, this will probably result in another error
- when PLIST is printed out */
return Fsignal (Qcircular_property_list, list1 (*plist));
else
{
DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
Extract a value from a property list.
PLIST is a property list, which is a list of the form
-\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
-corresponding to the given PROP, or DEFAULT if PROP is not
-one of the properties on the list.
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
+PROPERTY is usually a symbol.
+This function returns the value corresponding to the PROPERTY,
+or DEFAULT if PROPERTY is not one of the properties on the list.
*/
- (plist, prop, default_))
+ (plist, property, default_))
{
- Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
- return UNBOUNDP (val) ? default_ : val;
+ Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
+ return UNBOUNDP (value) ? default_ : value;
}
DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
-Change value in PLIST of PROP to VAL.
-PLIST is a property list, which is a list of the form \(PROP1 VALUE1
-PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
-If PROP is already a property on the list, its value is set to VAL,
-otherwise the new PROP VAL pair is added. The new plist is returned;
-use `(setq x (plist-put x prop val))' to be sure to use the new value.
-The PLIST is modified by side effects.
+Change value in PLIST of PROPERTY to VALUE.
+PLIST is a property list, which is a list of the form
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
+PROPERTY is usually a symbol and VALUE is any object.
+If PROPERTY is already a property on the list, its value is set to VALUE,
+otherwise the new PROPERTY VALUE pair is added.
+The new plist is returned; use `(setq x (plist-put x property value))'
+to be sure to use the new value. PLIST is modified by side effect.
*/
- (plist, prop, val))
+ (plist, property, value))
{
- external_plist_put (&plist, prop, val, 0, ERROR_ME);
+ external_plist_put (&plist, property, value, 0, ERROR_ME);
return plist;
}
DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
-Remove from PLIST the property PROP and its value.
-PLIST is a property list, which is a list of the form \(PROP1 VALUE1
-PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
-returned; use `(setq x (plist-remprop x prop val))' to be sure to use
-the new value. The PLIST is modified by side effects.
+Remove from PLIST the property PROPERTY and its value.
+PLIST is a property list, which is a list of the form
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
+PROPERTY is usually a symbol.
+The new plist is returned; use `(setq x (plist-remprop x property))'
+to be sure to use the new value. PLIST is modified by side effect.
*/
- (plist, prop))
+ (plist, property))
{
- external_remprop (&plist, prop, 0, ERROR_ME);
+ external_remprop (&plist, property, 0, ERROR_ME);
return plist;
}
DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
-Return t if PROP has a value specified in PLIST.
+Return t if PROPERTY has a value specified in PLIST.
*/
- (plist, prop))
+ (plist, property))
{
- Lisp_Object val = Fplist_get (plist, prop, Qunbound);
- return UNBOUNDP (val) ? Qnil : Qt;
+ Lisp_Object value = Fplist_get (plist, property, Qunbound);
+ return UNBOUNDP (value) ? Qnil : Qt;
}
DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
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))
{
DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
Extract a value from a lax property list.
-
-LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparisons between properties is done
-using `equal' instead of `eq'. This function returns the value
-corresponding to the given PROP, or DEFAULT if PROP is not one of the
-properties on the list.
+LAX-PLIST is a lax property list, which is a list of the form
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
+properties is done using `equal' instead of `eq'.
+PROPERTY is usually a symbol.
+This function returns the value corresponding to PROPERTY,
+or DEFAULT if PROPERTY is not one of the properties on the list.
*/
- (lax_plist, prop, default_))
+ (lax_plist, property, default_))
{
- Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
- if (UNBOUNDP (val))
- return default_;
- return val;
+ Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME);
+ return UNBOUNDP (value) ? default_ : value;
}
DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
-Change value in LAX-PLIST of PROP to VAL.
-LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparisons between properties is done
-using `equal' instead of `eq'. PROP is usually a symbol and VAL is
-any object. If PROP is already a property on the list, its value is
-set to VAL, otherwise the new PROP VAL pair is added. The new plist
-is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
-use the new value. The LAX-PLIST is modified by side effects.
-*/
- (lax_plist, prop, val))
-{
- external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
+Change value in LAX-PLIST of PROPERTY to VALUE.
+LAX-PLIST is a lax property list, which is a list of the form
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
+properties is done using `equal' instead of `eq'.
+PROPERTY is usually a symbol and VALUE is any object.
+If PROPERTY is already a property on the list, its value is set to
+VALUE, otherwise the new PROPERTY VALUE pair is added.
+The new plist is returned; use `(setq x (lax-plist-put x property value))'
+to be sure to use the new value. LAX-PLIST is modified by side effect.
+*/
+ (lax_plist, property, value))
+{
+ external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
return lax_plist;
}
DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
-Remove from LAX-PLIST the property PROP and its value.
-LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparisons between properties is done
-using `equal' instead of `eq'. PROP is usually a symbol. The new
-plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
-sure to use the new value. The LAX-PLIST is modified by side effects.
+Remove from LAX-PLIST the property PROPERTY and its value.
+LAX-PLIST is a lax property list, which is a list of the form
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
+properties is done using `equal' instead of `eq'.
+PROPERTY is usually a symbol.
+The new plist is returned; use `(setq x (lax-plist-remprop x property))'
+to be sure to use the new value. LAX-PLIST is modified by side effect.
*/
- (lax_plist, prop))
+ (lax_plist, property))
{
- external_remprop (&lax_plist, prop, 1, ERROR_ME);
+ external_remprop (&lax_plist, property, 1, ERROR_ME);
return lax_plist;
}
DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
-Return t if PROP has a value specified in LAX-PLIST.
-LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparisons between properties is done
-using `equal' instead of `eq'.
+Return t if PROPERTY has a value specified in LAX-PLIST.
+LAX-PLIST is a lax property list, which is a list of the form
+\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
+properties is done using `equal' instead of `eq'.
*/
- (lax_plist, prop))
+ (lax_plist, property))
{
- return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
+ return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
}
DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 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_IMPURE (object);
+ 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_IMPURE (object);
+ 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);
{
if (depth > 200)
error ("Stack overflow in equal");
-#ifndef LRECORD_CONS
- do_cdr:
-#endif
QUIT;
if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
return 1;
/* Note that (equal 20 20.0) should be nil */
if (XTYPE (obj1) != XTYPE (obj2))
return 0;
-#ifndef LRECORD_CONS
- if (CONSP (obj1))
- {
- if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1))
- return 0;
- obj1 = XCDR (obj1);
- obj2 = XCDR (obj2);
- goto do_cdr;
- }
-#endif
-#ifndef LRECORD_VECTOR
- if (VECTORP (obj1))
- {
- Lisp_Object *v1 = XVECTOR_DATA (obj1);
- Lisp_Object *v2 = XVECTOR_DATA (obj2);
- int len = XVECTOR_LENGTH (obj1);
- if (len != XVECTOR_LENGTH (obj2))
- return 0;
- while (len--)
- if (!internal_equal (*v1++, *v2++, depth + 1))
- return 0;
- return 1;
- }
-#endif
-#ifndef LRECORD_STRING
- if (STRINGP (obj1))
- {
- Bytecount len;
- return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
- !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
- }
-#endif
if (LRECORDP (obj1))
{
- CONST struct lrecord_implementation
+ const struct lrecord_implementation
*imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
*imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
{
if (depth > 200)
error ("Stack overflow in equal");
-#ifndef LRECORD_CONS
- do_cdr:
-#endif
QUIT;
if (HACKEQ_UNSAFE (obj1, obj2))
return 1;
/* Note that (equal 20 20.0) should be nil */
if (XTYPE (obj1) != XTYPE (obj2))
return 0;
-#ifndef LRECORD_CONS
- if (CONSP (obj1))
- {
- if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1))
- return 0;
- obj1 = XCDR (obj1);
- obj2 = XCDR (obj2);
- goto do_cdr;
- }
-#endif
-#ifndef LRECORD_VECTOR
- if (VECTORP (obj1))
- {
- Lisp_Object *v1 = XVECTOR_DATA (obj1);
- Lisp_Object *v2 = XVECTOR_DATA (obj2);
- int len = XVECTOR_LENGTH (obj1);
- if (len != XVECTOR_LENGTH (obj2))
- return 0;
- while (len--)
- if (!internal_old_equal (*v1++, *v2++, depth + 1))
- return 0;
- return 1;
- }
-#endif
return internal_equal (obj1, obj2, depth);
}
Vectors and strings are compared element by element.
Numbers are compared by value. Symbols must match exactly.
*/
- (obj1, obj2))
+ (object1, object2))
{
- return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
+ return internal_equal (object1, object2, 0) ? Qt : Qnil;
}
DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
This function is provided only for byte-code compatibility with v19.
Do not use it.
*/
- (obj1, obj2))
+ (object1, object2))
{
- return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
+ return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
}
\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_IMPURE (array);
- charval = XCHAR (item);
- for (i = 0; i < len; i++)
- set_string_char (s, i, charval);
+ CHECK_LISP_WRITEABLE (array);
+
+ 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))
{
Lisp_Object *p = XVECTOR_DATA (array);
- int len = XVECTOR_LENGTH (array);
- CHECK_IMPURE (array);
+ size_t len = XVECTOR_LENGTH (array);
+ CHECK_LISP_WRITEABLE (array);
while (len--)
*p++ = item;
}
else if (BIT_VECTORP (array))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
- int len = bit_vector_length (v);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (array);
+ size_t len = bit_vector_length (v);
int bit;
CHECK_BIT (item);
- CHECK_IMPURE (array);
bit = XINT (item);
+ CHECK_LISP_WRITEABLE (array);
while (len--)
set_bit_vector_bit (v, len, bit);
}
{
/* (setcdr (last args[0]) args[1]) */
Lisp_Object tortoise, hare;
- int count;
+ size_t count;
for (hare = tortoise = args[0], count = 0;
CONSP (XCDR (hare));
if (CONSP (next) || argnum == nargs -1)
{
/* (setcdr (last val) next) */
- int count;
+ size_t count;
for (count = 0;
CONSP (XCDR (last_cons));
}
\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];
- int i;
struct gcpro gcpro1;
if (vals)
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_NO_DECLARE 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;
+ size_t i;
+
+ 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;
+ EMACS_INT len_unused;
+ struct gcpro ngcpro1;
+
+ NGCPRO1 (tail);
+
+ {
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
+ {
+ 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);
+ size_t i;
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 = NULL;
+ Bufbyte *end = NULL;
+ int speccount = specpdl_depth();
+
+ XMALLOC_OR_ALLOCA(p, slen, Bufbyte);
+ end = p + slen;
+
+ memcpy (p, XSTRING_DATA (sequence), slen);
+
+ while (p < end)
{
args[1] = make_char (charptr_emchar (p));
INC_CHARPTR (p);
result = Ffuncall (2, args);
if (vals) vals[gcpro1.nvars++] = result;
}
+ XMALLOC_UNBIND(p, slen, speccount);
}
- 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);
+ size_t i;
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 to a string.
+Between each pair of results, insert SEPARATOR.
+
+Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
+results in spaces between the values returned by FUNCTION. SEQUENCE itself
+may be a list, a vector, a bit vector, or a string.
*/
- (fn, seq, sep))
+ (function, sequence, separator))
{
- size_t len = XINT (Flength (seq));
+ EMACS_INT len = XINT (Flength (sequence));
Lisp_Object *args;
- int i;
- struct gcpro gcpro1;
- int nargs = len + len - 1;
+ Lisp_Object result;
+ EMACS_INT i;
+ EMACS_INT nargs = len + len - 1;
+ int speccount = specpdl_depth();
- if (nargs < 0) return build_string ("");
+ if (len == 0) return build_string ("");
- args = alloca_array (Lisp_Object, nargs);
+ XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
- 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);
+ result = Fconcat(nargs, args);
+ XMALLOC_UNBIND(args, nargs, speccount);
+ return result;
}
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));
- Lisp_Object *args = alloca_array (Lisp_Object, len);
+ size_t len = XINT (Flength (sequence));
+ Lisp_Object *args = NULL;
+ Lisp_Object result;
+ int speccount = specpdl_depth();
+
+ XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
- mapcar1 (len, args, fn, seq);
+ mapcar1 (len, args, function, sequence);
- return Flist (len, args);
+ result = Flist(len, args);
+ XMALLOC_UNBIND(args, len, speccount);
+ return result;
}
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
/* #### this function doesn't belong in this file! */
+#ifdef HAVE_GETLOADAVG
+#ifdef HAVE_SYS_LOADAVG_H
+#include <sys/loadavg.h>
+#endif
+#else
+int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
+#endif
+
DEFUN ("load-average", Fload_average, 0, 1, 0, /*
Return list of 1 minute, 5 minute and 15 minute load averages.
Each of the three load averages is multiplied by 100,
(featurep '(or (and xemacs 19.15) (and emacs 19.34)))
=> ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
+ (featurep '(and xemacs 21.02))
+ => ; Non-nil on XEmacs 21.2 and later.
+
NOTE: The advanced arguments of this function (anything other than a
symbol) are not yet supported by FSF Emacs. If you feel they are useful
for supporting multiple Emacs variants, lobby Richard Stallman at
-<bug-gnu-emacs@prep.ai.mit.edu>.
+<bug-gnu-emacs@gnu.org>.
*/
(fexp))
{
is not loaded; so load the file FILENAME.
If FILENAME is omitted, the printname of FEATURE is used as the file name.
*/
- (feature, file_name))
+ (feature, filename))
{
Lisp_Object tem;
CHECK_SYMBOL (feature);
record_unwind_protect (un_autoload, Vautoload_queue);
Vautoload_queue = Qt;
- call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
+ call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename,
Qnil, Qt, Qnil);
tem = Fmemq (feature, Vfeatures);
}
\f
/* base64 encode/decode functions.
- Based on code from GNU recode. */
-#define MIME_LINE_LENGTH 76
+ Originally based on code from GNU recode. Ported to FSF Emacs by
+ Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
+ subsequently heavily hacked by Hrvoje Niksic. */
+
+#define MIME_LINE_LENGTH 72
#define IS_ASCII(Character) \
((Character) < 128)
base64 characters. */
#define ADVANCE_INPUT(c, stream) \
- (ec = Lstream_get_emchar (stream), \
- ec == -1 ? 0 : \
+ ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
((ec > 255) ? \
- (error ("Non-ascii character detected in base64 input"), 0) \
- : (c = (Bufbyte)ec, 1)))
+ (signal_simple_error ("Non-ascii character in base64 input", \
+ make_char (ec)), 0) \
+ : (c = (Bufbyte)ec), 1))
static Bytind
base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
}
#undef ADVANCE_INPUT
-#define ADVANCE_INPUT(c, stream) \
- (ec = Lstream_get_emchar (stream), \
- ec == -1 ? 0 : (c = (Bufbyte)ec, 1))
-
-#define INPUT_EOF_P(stream) \
- (ADVANCE_INPUT (c2, stream) \
- ? (Lstream_unget_emchar (stream, (Emchar)c2), 0) \
- : 1)
-
-#define STORE_BYTE(pos, val) do { \
+/* Get next character from the stream, except that non-base64
+ characters are ignored. This is in accordance with rfc2045. EC
+ should be an Emchar, so that it can hold -1 as the value for EOF. */
+#define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
+ ec = Lstream_get_emchar (stream); \
+ ++streampos; \
+ /* IS_BASE64 may not be called with negative arguments so check for \
+ EOF first. */ \
+ if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
+ break; \
+} while (1)
+
+#define STORE_BYTE(pos, val, ccnt) do { \
pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
- ++*ccptr; \
+ ++ccnt; \
} while (0)
static Bytind
base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
{
- EMACS_INT counter = 0;
- Emchar ec;
+ Charcount ccnt = 0;
Bufbyte *e = to;
- unsigned long value;
+ EMACS_INT streampos = 0;
- *ccptr = 0;
while (1)
{
- Bufbyte c, c2;
-
- if (!ADVANCE_INPUT (c, istream))
- break;
-
- /* Accept wrapping lines, reversibly if at each 76 characters. */
- if (c == '\n')
- {
- if (!ADVANCE_INPUT (c, istream))
- break;
- if (INPUT_EOF_P (istream))
- break;
- /* FSF Emacs has this check, apparently inherited from
- recode. However, I see no reason to be this picky about
- line length -- why reject base64 with say 72-byte lines?
- (yes, there are programs that generate them.) */
- /*if (counter != MIME_LINE_LENGTH / 4) return -1;*/
- counter = 1;
- }
- else
- counter++;
+ Emchar ec;
+ unsigned long value;
/* Process first byte of a quadruplet. */
- if (!IS_BASE64 (c))
- return -1;
- value = base64_char_to_value[c] << 18;
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ break;
+ if (ec == '=')
+ signal_simple_error ("Illegal `=' character while decoding base64",
+ make_int (streampos));
+ value = base64_char_to_value[ec] << 18;
/* Process second byte of a quadruplet. */
- if (!ADVANCE_INPUT (c, istream))
- return -1;
-
- if (!IS_BASE64 (c))
- return -1;
- value |= base64_char_to_value[c] << 12;
-
- STORE_BYTE (e, value >> 16);
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
+ if (ec == '=')
+ signal_simple_error ("Illegal `=' character while decoding base64",
+ make_int (streampos));
+ value |= base64_char_to_value[ec] << 12;
+ STORE_BYTE (e, value >> 16, ccnt);
/* Process third byte of a quadruplet. */
- if (!ADVANCE_INPUT (c, istream))
- return -1;
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
- if (c == '=')
+ if (ec == '=')
{
- if (!ADVANCE_INPUT (c, istream))
- return -1;
- if (c != '=')
- return -1;
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
+ if (ec != '=')
+ signal_simple_error ("Padding `=' expected but not found while decoding base64",
+ make_int (streampos));
continue;
}
- if (!IS_BASE64 (c))
- return -1;
- value |= base64_char_to_value[c] << 6;
-
- STORE_BYTE (e, 0xff & value >> 8);
+ value |= base64_char_to_value[ec] << 6;
+ STORE_BYTE (e, 0xff & value >> 8, ccnt);
/* Process fourth byte of a quadruplet. */
- if (!ADVANCE_INPUT (c, istream))
- return -1;
-
- if (c == '=')
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
+ if (ec == '=')
continue;
- if (!IS_BASE64 (c))
- return -1;
- value |= base64_char_to_value[c];
-
- STORE_BYTE (e, 0xff & value);
+ value |= base64_char_to_value[ec];
+ STORE_BYTE (e, 0xff & value, ccnt);
}
+ *ccptr = ccnt;
return e - to;
}
#undef ADVANCE_INPUT
-#undef INPUT_EOF_P
+#undef ADVANCE_INPUT_IGNORE_NONBASE64
+#undef STORE_BYTE
-static Lisp_Object
-free_malloced_ptr (Lisp_Object unwind_obj)
-{
- void *ptr = (void *)get_opaque_ptr (unwind_obj);
- xfree (ptr);
- free_opaque_ptr (unwind_obj);
- return Qnil;
-}
-
-/* Don't use alloca for regions larger than this, lest we overflow
- the stack. */
-#define MAX_ALLOCA 65536
-
-/* We need to setup proper unwinding, because there is a number of
- ways these functions can blow up, and we don't want to have memory
- leaks in those cases. */
-#define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
- size_t XOA_len = (len); \
- if (XOA_len > MAX_ALLOCA) \
- { \
- ptr = xnew_array (type, XOA_len); \
- record_unwind_protect (free_malloced_ptr, \
- make_opaque_ptr ((void *)ptr)); \
- } \
- else \
- ptr = alloca_array (type, XOA_len); \
-} while (0)
-
-#define XMALLOC_UNBIND(ptr, len, speccount) do { \
- if ((len) > MAX_ALLOCA) \
- unbind_to (speccount, Qnil); \
-} while (0)
DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
-Base64-encode the region between BEG and END.
+Base64-encode the region between START and END.
Return the length of the encoded text.
Optional third argument NO-LINE-BREAK means do not break long lines
into shorter lines.
*/
- (beg, end, no_line_break))
+ (start, end, no_line_break))
{
Bufbyte *encoded;
Bytind encoded_length;
Lisp_Object input;
int speccount = specpdl_depth();
- get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
+ get_buffer_range_char (buf, start, end, &begv, &zv, 0);
barf_if_buffer_read_only (buf, begv, zv);
/* We need to allocate enough room for encoding the text.
encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
NILP (no_line_break));
if (encoded_length > allength)
- abort ();
+ ABORT ();
Lstream_delete (XLSTREAM (input));
/* Now we have encoded the region, so we insert the new contents
XMALLOC_UNBIND (encoded, allength, speccount);
buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
- /* Simulate FSF Emacs: if point was in the region, place it at the
- beginning. */
+ /* Simulate FSF Emacs implementation of this function: if point was
+ in the region, place it at the beginning. */
if (old_pt >= begv && old_pt < zv)
BUF_SET_PT (buf, begv);
DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
Base64 encode STRING and return the result.
+Optional argument NO-LINE-BREAK means do not break long lines
+into shorter lines.
*/
(string, no_line_break))
{
encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
NILP (no_line_break));
if (encoded_length > allength)
- abort ();
+ ABORT ();
Lstream_delete (XLSTREAM (input));
result = make_string (encoded, encoded_length);
XMALLOC_UNBIND (encoded, allength, speccount);
}
DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
-Base64-decode the region between BEG and END.
+Base64-decode the region between START and END.
Return the length of the decoded text.
If the region can't be decoded, return nil and don't modify the buffer.
+Characters out of the base64 alphabet are ignored.
*/
- (beg, end))
+ (start, end))
{
struct buffer *buf = current_buffer;
Bufpos begv, zv, old_pt = BUF_PT (buf);
Lisp_Object input;
int speccount = specpdl_depth();
- get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
+ get_buffer_range_char (buf, start, end, &begv, &zv, 0);
barf_if_buffer_read_only (buf, begv, zv);
length = zv - begv;
XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
if (decoded_length > length * MAX_EMCHAR_LEN)
- abort ();
+ ABORT ();
Lstream_delete (XLSTREAM (input));
- if (decoded_length < 0)
- {
- /* The decoding wasn't possible. */
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
- return Qnil;
- }
-
/* Now we have decoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
BUF_SET_PT (buf, begv);
buffer_delete_range (buf, begv + cc_decoded_length,
zv + cc_decoded_length, 0);
- /* Simulate FSF Emacs: if point was in the region, place it at the
- beginning. */
+ /* Simulate FSF Emacs implementation of this function: if point was
+ in the region, place it at the beginning. */
if (old_pt >= begv && old_pt < zv)
BUF_SET_PT (buf, begv);
DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
Base64-decode STRING and return the result.
+Characters out of the base64 alphabet are ignored.
*/
(string))
{
decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
&cc_decoded_length);
if (decoded_length > length * MAX_EMCHAR_LEN)
- abort ();
+ ABORT ();
Lstream_delete (XLSTREAM (input));
- if (decoded_length < 0)
- {
- /* The decoding wasn't possible. */
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
- return Qnil;
- }
-
result = make_string (decoded, decoded_length);
XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
return result;
}
\f
+Lisp_Object Qideographic_structure;
+Lisp_Object Qkeyword_char;
+
+EXFUN (Fideographic_structure_to_ids, 1);
+
+Lisp_Object ids_format_unit (Lisp_Object ids_char);
+Lisp_Object
+ids_format_unit (Lisp_Object ids_char)
+{
+ if (CHARP (ids_char))
+ return Fchar_to_string (ids_char);
+ else if (INTP (ids_char))
+ return Fchar_to_string (Fdecode_char (Qrep_ucs, ids_char, Qnil, Qnil));
+ else
+ {
+ Lisp_Object ret = Ffind_char (ids_char);
+
+ if (CHARP (ret))
+ return Fchar_to_string (ret);
+ else
+ {
+ ret = Fassq (Qideographic_structure, ids_char);
+
+ if (CONSP (ret))
+ return Fideographic_structure_to_ids (XCDR (ret));
+ }
+ }
+ return Qnil;
+}
+
+DEFUN ("ideographic-structure-to-ids",
+ Fideographic_structure_to_ids, 1, 1, 0, /*
+Format ideographic-structure IDS-LIST as an IDS-string.
+*/
+ (ids_list))
+{
+ Lisp_Object dest = Qnil;
+
+ while (CONSP (ids_list))
+ {
+ Lisp_Object cell = XCAR (ids_list);
+
+ if (!NILP (Fchar_ref_p (cell)))
+ cell = Fplist_get (cell, Qkeyword_char, Qnil);
+ dest = concat2 (dest, ids_format_unit (cell));
+ ids_list = XCDR (ids_list);
+ }
+ return dest;
+}
+
+Lisp_Object simplify_char_spec (Lisp_Object char_spec);
+Lisp_Object
+simplify_char_spec (Lisp_Object char_spec)
+{
+ if (CHARP (char_spec))
+ {
+ Lisp_Object ccs;
+ int code_point = ENCODE_CHAR (XCHAR (char_spec), ccs);
+
+ if (code_point >= 0)
+ {
+ int cid = decode_defined_char (ccs, code_point, Qnil);
+
+ if (cid >= 0)
+ return make_char (cid);
+ }
+ return char_spec;
+ }
+ else if (INTP (char_spec))
+ return Fdecode_char (Qrep_ucs, char_spec, Qnil, Qnil);
+ else
+ {
+#if 0
+ Lisp_Object ret = Ffind_char (char_spec);
+#else
+ Lisp_Object ret;
+ Lisp_Object rest = char_spec;
+ int have_ccs = 0;
+
+ while (CONSP (rest))
+ {
+ Lisp_Object cell = Fcar (rest);
+ Lisp_Object ccs;
+
+#if 0
+ if (!LISTP (cell))
+ signal_simple_error ("Invalid argument", char_spec);
+#endif
+ if (!NILP (ccs = Ffind_charset (Fcar (cell))))
+ {
+ cell = Fcdr (cell);
+ if (CONSP (cell))
+ ret = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
+ else
+ ret = Fdecode_char (ccs, cell, Qt, Qt);
+ have_ccs = 1;
+ if (CHARP (ret))
+ return ret;
+ }
+ rest = Fcdr (rest);
+ }
+ if (have_ccs)
+ ret = Fdefine_char (char_spec);
+ else
+ ret = Qnil;
+#endif
+
+ if (CHARP (ret))
+ return ret;
+ else
+ return char_spec;
+ }
+}
+
+Lisp_Object char_ref_simplify_spec (Lisp_Object char_ref);
+Lisp_Object
+char_ref_simplify_spec (Lisp_Object char_ref)
+{
+ if (!NILP (Fchar_ref_p (char_ref)))
+ {
+ Lisp_Object ret = Fplist_get (char_ref, Qkeyword_char, Qnil);
+
+ if (NILP (ret))
+ return char_ref;
+ else
+ return Fplist_put (Fcopy_sequence (char_ref), Qkeyword_char,
+ simplify_char_spec (ret));
+ }
+ else
+ return simplify_char_spec (char_ref);
+}
+
+DEFUN ("char-refs-simplify-char-specs",
+ Fchar_refs_simplify_char_specs, 1, 1, 0, /*
+Simplify char-specs in CHAR-REFS.
+*/
+ (char_refs))
+{
+ Lisp_Object rest = char_refs;
+
+ while (CONSP (rest))
+ {
+ Fsetcar (rest, char_ref_simplify_spec (XCAR (rest)));
+ rest = XCDR (rest);
+ }
+ return char_refs;
+}
+\f
Lisp_Object Qyes_or_no_p;
void
syms_of_fns (void)
{
+ INIT_LRECORD_IMPLEMENTATION (bit_vector);
+
defsymbol (&Qstring_lessp, "string-lessp");
defsymbol (&Qidentity, "identity");
+ defsymbol (&Qideographic_structure, "ideographic-structure");
+ defsymbol (&Qkeyword_char, ":char");
defsymbol (&Qyes_or_no_p, "yes-or-no-p");
DEFSUBR (Fidentity);
DEFSUBR (Fnconc);
DEFSUBR (Fmapcar);
DEFSUBR (Fmapvector);
- DEFSUBR (Fmapc);
+ DEFSUBR (Fmapc_internal);
DEFSUBR (Fmapconcat);
+ DEFSUBR (Freplace_list);
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);
DEFSUBR (Fbase64_encode_string);
DEFSUBR (Fbase64_decode_region);
DEFSUBR (Fbase64_decode_string);
+ DEFSUBR (Fideographic_structure_to_ids);
+ DEFSUBR (Fchar_refs_simplify_char_specs);
}
void
Used by `featurep' and `require', and altered by `provide'.
*/ );
Vfeatures = Qnil;
+
+ Fprovide (intern ("base64"));
}
projects / chise / xemacs-chise.git.1 / blobdiff