/* 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)
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++)
{
sizeof (long)));
}
+static size_t
+size_bit_vector (const void *lheader)
+{
+ Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
+ return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, 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_IMPLEMENTATION ("bit-vector", bit_vector,
- mark_bit_vector, print_bit_vector, 0,
- bit_vector_equal, bit_vector_hash,
- bit_vector_description,
- Lisp_Bit_Vector);
+DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
+ mark_bit_vector, print_bit_vector, 0,
+ bit_vector_equal, bit_vector_hash,
+ bit_vector_description, size_bit_vector,
+ Lisp_Bit_Vector);
\f
DEFUN ("identity", Fidentity, 1, 1, 0, /*
Return the argument unchanged.
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));
#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
`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;
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))
{
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);
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);
}
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, blen;
+ 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);
- blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
- val = make_string (XSTRING_DATA (string) + bfr, blen);
- /* Copy any applicable extent information into the new string: */
- copy_string_extents (val, string, 0, bfr, blen);
+ 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))
{
- EMACS_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);
+ Lisp_Object result = make_vector (e - s, Qnil);
EMACS_INT i;
- Lisp_Object *in_elts = XVECTOR_DATA (seq);
+ Lisp_Object *in_elts = XVECTOR_DATA (sequence);
Lisp_Object *out_elts = XVECTOR_DATA (result);
- for (i = f; i < t; i++)
- out_elts[i - f] = in_elts[i];
+ for (i = s; i < e; i++)
+ out_elts[i - s] = in_elts[i];
return result;
}
-
- if (LISTP (seq))
+ else if (LISTP (sequence))
{
Lisp_Object result = Qnil;
EMACS_INT i;
- seq = Fnthcdr (make_int (f), seq);
+ sequence = Fnthcdr (make_int (s), sequence);
- for (i = f; i < t; i++)
+ for (i = s; i < e; i++)
{
- result = Fcons (Fcar (seq), result);
- seq = Fcdr (seq);
+ result = Fcons (Fcar (sequence), result);
+ sequence = Fcdr (sequence);
}
return Fnreverse (result);
}
+ else if (BIT_VECTORP (sequence))
+ {
+ Lisp_Object result = make_bit_vector (e - s, Qzero);
+ EMACS_INT i;
- /* bit vector */
- {
- Lisp_Object result = make_bit_vector (t - f, Qzero);
- EMACS_INT i;
-
- for (i = f; i < t; i++)
- set_bit_vector_bit (XBIT_VECTOR (result), i - f,
- bit_vector_bit (XBIT_VECTOR (seq), i));
- return result;
- }
+ for (i = s; i < e; i++)
+ set_bit_vector_bit (XBIT_VECTOR (result), i - s,
+ bit_vector_bit (XBIT_VECTOR (sequence), i));
+ return result;
+ }
+ else
+ {
+ ABORT (); /* unreachable, since Flength (sequence) did not get
+ an error */
+ return Qnil;
+ }
}
\f
*/
(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
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 (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 (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 (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 (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 (Lisp_String *s, Lisp_Object property)
-{
- return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
-}
-
-static Lisp_Object
-string_plist (Lisp_String *s)
-{
- return *string_plist_ptr (s);
-}
-
DEFUN ("get", Fget, 2, 3, 0, /*
-Return the value of OBJECT's PROPNAME property.
-This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
+Return the value of OBJECT's PROPERTY property.
+This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
If there is no such property, return optional third arg DEFAULT
-\(which defaults to `nil'). OBJECT can be a symbol, face, extent,
-or string. See also `put', `remprop', and `object-plist'.
+\(which defaults to `nil'). OBJECT can be a symbol, string, extent,
+face, or glyph. See also `put', `remprop', and `object-plist'.
*/
- (object, propname, default_))
+ (object, property, default_))
{
/* Various places in emacs call Fget() and expect it not to quit,
so don't quit. */
+ Lisp_Object val;
- /* It's easiest to treat symbols specially because they may not
- be an lrecord */
- if (SYMBOLP (object))
- return symbol_getprop (object, propname, default_);
- else if (STRINGP (object))
- return string_getprop (XSTRING (object), propname, default_);
- else if (LRECORDP (object))
- {
- CONST struct lrecord_implementation *imp
- = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (!imp->getprop)
- goto noprops;
-
- {
- Lisp_Object val = (imp->getprop) (object, propname);
- if (UNBOUNDP (val))
- val = default_;
- return val;
- }
- }
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
+ val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
else
- {
- noprops:
- signal_simple_error ("Object type has no properties", object);
- return Qnil; /* Not reached */
- }
+ signal_simple_error ("Object type has no properties", object);
+
+ return UNBOUNDP (val) ? default_ : val;
}
DEFUN ("put", Fput, 3, 3, 0, /*
-Store OBJECT's PROPNAME property with value VALUE.
-It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
-symbol, face, extent, or string.
-
+Set OBJECT's PROPERTY to VALUE.
+It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
+OBJECT can be a symbol, face, extent, or string.
For a string, no properties currently have predefined meanings.
For the predefined properties for extents, see `set-extent-property'.
For the predefined properties for faces, see `set-face-property'.
-
See also `get', `remprop', and `object-plist'.
*/
- (object, propname, value))
+ (object, property, value))
{
- CHECK_SYMBOL (propname);
CHECK_LISP_WRITEABLE (object);
- if (SYMBOLP (object))
- symbol_putprop (object, propname, value);
- else if (STRINGP (object))
- string_putprop (XSTRING (object), propname, value);
- else if (LRECORDP (object))
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
{
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->putprop)
- {
- if (! (imp->putprop) (object, propname, value))
- signal_simple_error ("Can't set property on object", propname);
- }
- else
- goto noprops;
+ if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
+ (object, property, value))
+ signal_simple_error ("Can't set property on object", property);
}
else
- {
- noprops:
- signal_simple_error ("Object type has no settable properties", object);
- }
+ signal_simple_error ("Object type has no settable properties", object);
return value;
}
DEFUN ("remprop", Fremprop, 2, 2, 0, /*
-Remove from OBJECT's property list the property PROPNAME and its
-value. OBJECT can be a symbol, face, extent, or string. Returns
-non-nil if the property list was actually changed (i.e. if PROPNAME
-was present in the property list). See also `get', `put', and
-`object-plist'.
+Remove, from OBJECT's property list, PROPERTY and its corresponding value.
+OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
+if the property list was actually modified (i.e. if PROPERTY was present
+in the property list). See also `get', `put', and `object-plist'.
*/
- (object, propname))
+ (object, property))
{
- int retval = 0;
+ int ret = 0;
- CHECK_SYMBOL (propname);
CHECK_LISP_WRITEABLE (object);
- if (SYMBOLP (object))
- retval = symbol_remprop (object, propname);
- else if (STRINGP (object))
- retval = string_remprop (XSTRING (object), propname);
- else if (LRECORDP (object))
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
{
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->remprop)
- {
- retval = (imp->remprop) (object, propname);
- if (retval == -1)
- signal_simple_error ("Can't remove property from object",
- propname);
- }
- else
- goto noprops;
+ ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
+ if (ret == -1)
+ signal_simple_error ("Can't remove property from object", property);
}
else
- {
- noprops:
- signal_simple_error ("Object type has no removable properties", object);
- }
+ signal_simple_error ("Object type has no removable properties", object);
- return retval ? Qt : Qnil;
+ return ret ? Qt : Qnil;
}
DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
-Return a property list of OBJECT's props.
-For a symbol this is equivalent to `symbol-plist'.
-Do not modify the property list directly; this may or may not have
-the desired effects. (In particular, for a property with a special
-interpretation, this will probably have no effect at all.)
+Return a property list of OBJECT's properties.
+For a symbol, this is equivalent to `symbol-plist'.
+OBJECT can be a symbol, string, extent, face, or glyph.
+Do not modify the returned property list directly;
+this may or may not have the desired effects. Use `put' instead.
*/
(object))
{
- if (SYMBOLP (object))
- return Fsymbol_plist (object);
- else if (STRINGP (object))
- return string_plist (XSTRING (object));
- else if (LRECORDP (object))
- {
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->plist)
- return (imp->plist) (object);
- else
- signal_simple_error ("Object type has no properties", object);
- }
+ if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
+ return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
else
signal_simple_error ("Object type has no properties", object);
return 0;
if (LRECORDP (obj1))
{
- CONST struct lrecord_implementation
+ const struct lrecord_implementation
*imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
*imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
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
else if (VECTORP (array))
{
Lisp_Object *p = XVECTOR_DATA (array);
- int len = XVECTOR_LENGTH (array);
+ size_t len = XVECTOR_LENGTH (array);
CHECK_LISP_WRITEABLE (array);
while (len--)
*p++ = item;
else if (BIT_VECTORP (array))
{
Lisp_Bit_Vector *v = XBIT_VECTOR (array);
- int len = bit_vector_length (v);
+ size_t len = bit_vector_length (v);
int bit;
CHECK_BIT (item);
- CHECK_LISP_WRITEABLE (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));
{
Lisp_Object result;
Lisp_Object args[2];
- int i;
struct gcpro gcpro1;
if (vals)
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. */
+ So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
if (vals)
{
Lisp_Object *val = vals;
- Lisp_Object elt;
+ size_t i;
LIST_LOOP_2 (elt, sequence)
*val++ = elt;
else
{
Lisp_Object elt, tail;
+ EMACS_INT len_unused;
struct gcpro ngcpro1;
NGCPRO1 (tail);
{
- EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
+ EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
{
args[1] = elt;
Ffuncall (2, args);
else if (VECTORP (sequence))
{
Lisp_Object *objs = XVECTOR_DATA (sequence);
+ size_t i;
for (i = 0; i < leni; i++)
{
args[1] = *objs++;
{
/* 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;
+ 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);
result = Ffuncall (2, args);
if (vals) vals[gcpro1.nvars++] = result;
}
+ XMALLOC_UNBIND(p, slen, speccount);
}
else if (BIT_VECTORP (sequence))
{
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(sequence) 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 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.
+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.
*/
(function, sequence, separator))
{
- size_t len = XINT (Flength (sequence));
+ 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 (separator);
mapcar1 (len, args, function, sequence);
- UNGCPRO;
for (i = len - 1; i >= 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
args[i] = separator;
- return Fconcat (nargs, args);
+ result = Fconcat(nargs, args);
+ XMALLOC_UNBIND(args, nargs, speccount);
+ return result;
}
DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
(function, sequence))
{
size_t len = XINT (Flength (sequence));
- Lisp_Object *args = alloca_array (Lisp_Object, len);
+ Lisp_Object *args = NULL;
+ Lisp_Object result;
+ int speccount = specpdl_depth();
+
+ XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
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, /*
}
\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);
#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
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));
/* Now we have decoded the region, so we insert the new contents
decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
&cc_decoded_length);
if (decoded_length > length * MAX_EMCHAR_LEN)
- abort ();
+ ABORT ();
Lstream_delete (XLSTREAM (input));
result = make_string (decoded, decoded_length);
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 (Fmapvector);
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
projects / chise / xemacs-chise.git.1 / blobdiff