#include "lisp.h"
-#include "sysfile.h"
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <errno.h>
#include "buffer.h"
#include "bytecode.h"
+#include "commands.h"
#include "device.h"
#include "events.h"
#include "extents.h"
#include "frame.h"
#include "systime.h"
-#include "insdel.h"
-#include "lstream.h"
-#include "opaque.h"
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
static int internal_old_equal (Lisp_Object, Lisp_Object, int);
static Lisp_Object
-mark_bit_vector (Lisp_Object obj)
+mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
return Qnil;
}
static void
print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
- size_t i;
- Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
- size_t len = bit_vector_length (v);
- size_t last = len;
+ int i;
+ struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ int len = bit_vector_length (v);
+ int last = len;
if (INTP (Vprint_length))
last = min (len, XINT (Vprint_length));
}
static int
-bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
- Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
- Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
+ struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1);
+ struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2);
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)
{
- Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
return HASH2 (bit_vector_length (v),
memory_hash (v->bits,
BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
sizeof (long)));
}
-static size_t
-size_bit_vector (const void *lheader)
-{
- Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
- return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
- BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
-}
-
-static const struct lrecord_description bit_vector_description[] = {
- { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
- { 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);
+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);
\f
DEFUN ("identity", Fidentity, 1, 1, 0, /*
Return the argument unchanged.
return XINT (Flength (seq));
else
{
- Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
+ struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq);
- return (f->flags.interactivep ? COMPILED_INTERACTIVE :
- f->flags.domainp ? COMPILED_DOMAIN :
+ return (b->flags.interactivep ? COMPILED_INTERACTIVE :
+ b->flags.domainp ? COMPILED_DOMAIN :
COMPILED_DOC_STRING)
+ 1;
}
#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))
{
- size_t len;
- GET_EXTERNAL_LIST_LENGTH (sequence, len);
- return make_int (len);
+ Lisp_Object tail;
+ int i = 0;
+
+ EXTERNAL_LIST_LOOP (tail, sequence)
+ {
+ QUIT;
+ i++;
+ }
+
+ return make_int (i);
}
else if (VECTORP (sequence))
return make_int (XVECTOR_LENGTH (sequence));
}
}
+/* This does not check for quits. That is safe
+ since it must terminate. */
+
DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
Return the length of a list, but avoid error or infinite loop.
This function never gets an error. If LIST is not really a list,
*/
(list))
{
- Lisp_Object hare, tortoise;
- size_t len;
+ Lisp_Object halftail = list; /* Used to detect circular lists. */
+ Lisp_Object tail;
+ int len = 0;
- for (hare = tortoise = list, len = 0;
- CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
- hare = XCDR (hare), len++)
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (len & 1)
- tortoise = XCDR (tortoise);
+ if (EQ (tail, halftail) && len != 0)
+ break;
+ len++;
+ if ((len & 1) == 0)
+ halftail = XCDR (halftail);
}
return make_int (len);
(s1, s2))
{
Bytecount len;
- Lisp_String *p1, *p2;
+ struct Lisp_String *p1, *p2;
if (SYMBOLP (s1))
p1 = XSYMBOL (s1)->name;
*/
(s1, s2))
{
- Lisp_String *p1, *p2;
+ struct Lisp_String *p1, *p2;
Charcount end, len2;
int i;
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 */
- {
- 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);
- }
- }
+ /* #### 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;
+ }
#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))
{
- Lisp_String *s;
+ struct Lisp_String *s;
CHECK_STRING (string);
s = XSTRING (string);
void
bump_string_modiff (Lisp_Object str)
{
- Lisp_String *s = XSTRING (str);
+ struct Lisp_String *s = XSTRING (str);
Lisp_Object *ptr = &s->plist;
#ifdef I18N3
return concat (nargs, args, c_bit_vector, 0);
}
-/* Copy a (possibly dotted) list. LIST must be a cons.
- Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
-static Lisp_Object
-copy_list (Lisp_Object list)
-{
- Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
- Lisp_Object last = list_copy;
- Lisp_Object hare, tortoise;
- size_t len;
-
- for (tortoise = hare = XCDR (list), len = 1;
- CONSP (hare);
- hare = XCDR (hare), len++)
- {
- XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
- last = XCDR (last);
-
- if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
- continue;
- if (len & 1)
- tortoise = XCDR (tortoise);
- if (EQ (tortoise, hare))
- signal_circular_list_error (list);
- }
-
- return list_copy;
-}
-
-DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
-Return a copy of list LIST, which may be a dotted list.
-The elements of LIST are not copied; they are shared
+DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
+Return a copy of a list, vector, bit vector or string.
+The elements of a list or vector are not copied; they are shared
with the original.
*/
- (list))
+ (arg))
{
again:
- if (NILP (list)) return list;
- if (CONSP (list)) return copy_list (list);
+ if (NILP (arg)) return arg;
+ /* We handle conses separately because concat() is big and hairy and
+ doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this
+ than to fix concat() without worrying about breaking other things.
+ */
+ if (CONSP (arg))
+ {
+ Lisp_Object head = Fcons (XCAR (arg), XCDR (arg));
+ Lisp_Object tail = head;
- list = wrong_type_argument (Qlistp, list);
- goto again;
-}
+ for (arg = XCDR (arg); CONSP (arg); arg = XCDR (arg))
+ {
+ XCDR (tail) = Fcons (XCAR (arg), XCDR (arg));
+ tail = XCDR (tail);
+ QUIT;
+ }
+ return head;
+ }
+ if (STRINGP (arg)) return concat (1, &arg, c_string, 0);
+ if (VECTORP (arg)) return concat (1, &arg, c_vector, 0);
+ if (BIT_VECTORP (arg)) return concat (1, &arg, c_bit_vector, 0);
-DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
-Return a copy of list, vector, bit vector or string SEQUENCE.
-The elements of a list or vector are not copied; they are shared
-with the original. SEQUENCE may be a dotted list.
-*/
- (sequence))
-{
- again:
- if (NILP (sequence)) return sequence;
- if (CONSP (sequence)) return copy_list (sequence);
- if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
- if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
- if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
-
- check_losing_bytecode ("copy-sequence", sequence);
- sequence = wrong_type_argument (Qsequencep, sequence);
+ check_losing_bytecode ("copy-sequence", arg);
+ arg = wrong_type_argument (Qsequencep, arg);
goto again;
}
(string, from, to))
{
Charcount ccfr, ccto;
- Bytecount bfr, blen;
+ Bytecount bfr, bto;
Lisp_Object val;
CHECK_STRING (string);
+ /* Historically, FROM could not be omitted. Whatever ... */
CHECK_INT (from);
get_string_range_char (string, from, to, &ccfr, &ccto,
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);
+ 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, blen);
+ copy_string_extents (val, string, 0, bfr, bto - bfr);
return val;
}
DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
-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.
+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.
*/
- (sequence, start, end))
+ (seq, from, to))
{
- EMACS_INT len, s, e;
+ int len, f, t;
- if (STRINGP (sequence))
- return Fsubstring (sequence, start, end);
+ if (STRINGP (seq))
+ return Fsubstring (seq, from, to);
- len = XINT (Flength (sequence));
+ if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
+ {
+ check_losing_bytecode ("subseq", seq);
+ seq = wrong_type_argument (Qsequencep, seq);
+ }
- CHECK_INT (start);
- s = XINT (start);
- if (s < 0)
- s = len + s;
+ len = XINT (Flength (seq));
+
+ CHECK_INT (from);
+ f = XINT (from);
+ if (f < 0)
+ f = len + f;
- if (NILP (end))
- e = len;
+ if (NILP (to))
+ t = len;
else
{
- CHECK_INT (end);
- e = XINT (end);
- if (e < 0)
- e = len + e;
+ CHECK_INT (to);
+ t = XINT (to);
+ if (t < 0)
+ t = len + t;
}
- if (!(0 <= s && s <= e && e <= len))
- args_out_of_range_3 (sequence, make_int (s), make_int (e));
+ if (!(0 <= f && f <= t && t <= len))
+ args_out_of_range_3 (seq, make_int (f), make_int (t));
- if (VECTORP (sequence))
+ if (VECTORP (seq))
{
- Lisp_Object result = make_vector (e - s, Qnil);
- EMACS_INT i;
- Lisp_Object *in_elts = XVECTOR_DATA (sequence);
+ Lisp_Object result = make_vector (t - f, Qnil);
+ int i;
+ Lisp_Object *in_elts = XVECTOR_DATA (seq);
Lisp_Object *out_elts = XVECTOR_DATA (result);
- for (i = s; i < e; i++)
- out_elts[i - s] = in_elts[i];
+ for (i = f; i < t; i++)
+ out_elts[i - f] = in_elts[i];
return result;
}
- else if (LISTP (sequence))
+
+ if (LISTP (seq))
{
Lisp_Object result = Qnil;
- EMACS_INT i;
+ int i;
- sequence = Fnthcdr (make_int (s), sequence);
+ seq = Fnthcdr (make_int (f), seq);
- for (i = s; i < e; i++)
+ for (i = f; i < t; i++)
{
- result = Fcons (Fcar (sequence), result);
- sequence = Fcdr (sequence);
+ result = Fcons (Fcar (seq), result);
+ seq = Fcdr (seq);
}
return Fnreverse (result);
}
- else if (BIT_VECTORP (sequence))
- {
- Lisp_Object result = make_bit_vector (e - s, Qzero);
- EMACS_INT i;
- 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;
- }
+ /* 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;
+ }
}
\f
*/
(n, list))
{
- REGISTER size_t i;
+ REGISTER int i;
REGISTER Lisp_Object tail = list;
CHECK_NATNUM (n);
for (i = XINT (n); i; i--)
args_out_of_range (sequence, n);
#endif
}
- else if (STRINGP (sequence) ||
- VECTORP (sequence) ||
- BIT_VECTORP (sequence))
+ else if (STRINGP (sequence)
+ || VECTORP (sequence)
+ || BIT_VECTORP (sequence))
return Faref (sequence, n);
#ifdef LOSING_BYTECODE
else if (COMPILED_FUNCTIONP (sequence))
{
- EMACS_INT idx = XINT (n);
+ int idx = XINT (n);
if (idx < 0)
{
lose:
}
/* Utter perversity */
{
- Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
+ struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence);
switch (idx)
{
case COMPILED_ARGLIST:
- return compiled_function_arglist (f);
- case COMPILED_INSTRUCTIONS:
- return compiled_function_instructions (f);
+ return b->arglist;
+ case COMPILED_BYTECODE:
+ return b->bytecodes;
case COMPILED_CONSTANTS:
- return compiled_function_constants (f);
+ return b->constants;
case COMPILED_STACK_DEPTH:
- return compiled_function_stack_depth (f);
+ return make_int (b->maxdepth);
case COMPILED_DOC_STRING:
- return compiled_function_documentation (f);
+ return compiled_function_documentation (b);
case COMPILED_DOMAIN:
- return compiled_function_domain (f);
+ return compiled_function_domain (b);
case COMPILED_INTERACTIVE:
- if (f->flags.interactivep)
- return compiled_function_interactive (f);
+ if (b->flags.interactivep)
+ return compiled_function_interactive (b);
/* if we return nil, can't tell interactive with no args
from noninteractive. */
goto lose;
}
}
-DEFUN ("last", Flast, 1, 2, 0, /*
-Return the tail of list LIST, of length N (default 1).
-LIST may be a dotted list, but not a circular list.
-Optional argument N must be a non-negative integer.
-If N is zero, then the atom that terminates the list is returned.
-If N is greater than the length of LIST, then LIST itself is returned.
-*/
- (list, n))
-{
- EMACS_INT int_n, count;
- Lisp_Object retval, tortoise, hare;
-
- CHECK_LIST (list);
-
- if (NILP (n))
- int_n = 1;
- else
- {
- CHECK_NATNUM (n);
- int_n = XINT (n);
- }
-
- for (retval = tortoise = hare = list, count = 0;
- CONSP (hare);
- hare = XCDR (hare),
- (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
- count++)
- {
- if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
-
- if (count & 1)
- tortoise = XCDR (tortoise);
- if (EQ (hare, tortoise))
- signal_circular_list_error (list);
- }
-
- return retval;
-}
-
-DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
-Modify LIST to remove the last N (default 1) elements.
-If LIST has N or fewer elements, nil is returned and LIST is unmodified.
-*/
- (list, n))
-{
- EMACS_INT int_n;
-
- CHECK_LIST (list);
-
- if (NILP (n))
- int_n = 1;
- else
- {
- CHECK_NATNUM (n);
- int_n = XINT (n);
- }
-
- {
- Lisp_Object last_cons = list;
-
- EXTERNAL_LIST_LOOP_1 (list)
- {
- if (int_n-- < 0)
- last_cons = XCDR (last_cons);
- }
-
- if (int_n >= 0)
- return Qnil;
-
- XCDR (last_cons) = Qnil;
- return list;
- }
-}
-
-DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
-Return a copy of LIST with the last N (default 1) elements removed.
-If LIST has N or fewer elements, nil is returned.
-*/
- (list, n))
-{
- int int_n;
-
- CHECK_LIST (list);
-
- if (NILP (n))
- int_n = 1;
- else
- {
- CHECK_NATNUM (n);
- int_n = XINT (n);
- }
-
- {
- Lisp_Object retval = Qnil;
- Lisp_Object tail = list;
-
- EXTERNAL_LIST_LOOP_1 (list)
- {
- if (--int_n < 0)
- {
- retval = Fcons (XCAR (tail), retval);
- tail = XCDR (tail);
- }
- }
-
- return Fnreverse (retval);
- }
-}
-
DEFUN ("member", Fmember, 2, 2, 0, /*
Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
The value is actually the tail of LIST whose car is ELT.
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
- EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (internal_equal (elt, list_elt, 0))
+ CONCHECK_CONS (tail);
+ if (internal_equal (elt, XCAR (tail), 0))
return tail;
+ QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
- EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (internal_old_equal (elt, list_elt, 0))
+ CONCHECK_CONS (tail);
+ if (internal_old_equal (elt, XCAR (tail), 0))
return tail;
+ QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
- EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
+ REGISTER Lisp_Object tem;
+ CONCHECK_CONS (tail);
+ if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
return tail;
+ QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- Lisp_Object list_elt, tail;
- EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (HACKEQ_UNSAFE (elt, list_elt))
+ REGISTER Lisp_Object tem;
+ CONCHECK_CONS (tail);
+ if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
return tail;
+ QUIT;
}
return Qnil;
}
Lisp_Object
memq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- Lisp_Object list_elt, tail;
- LIST_LOOP_3 (list_elt, list, tail)
+ REGISTER Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
+ REGISTER Lisp_Object tem;
+ if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
return tail;
}
return Qnil;
(key, list))
{
/* This function can GC. */
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (internal_equal (key, elt_car, 0))
+ REGISTER Lisp_Object elt;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && internal_equal (XCAR (elt), key, 0))
return elt;
+ QUIT;
}
return Qnil;
}
(key, list))
{
/* This function can GC. */
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (internal_old_equal (key, elt_car, 0))
+ REGISTER Lisp_Object elt;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0))
return elt;
+ QUIT;
}
return Qnil;
}
*/
(key, list))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ REGISTER Lisp_Object elt, tem;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
return elt;
+ QUIT;
}
return Qnil;
}
*/
(key, list))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (HACKEQ_UNSAFE (key, elt_car))
+ REGISTER Lisp_Object elt, tem;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem)))
return elt;
+ QUIT;
}
return Qnil;
}
assq_no_quit (Lisp_Object key, Lisp_Object list)
{
/* This cannot GC. */
- Lisp_Object elt;
- LIST_LOOP_2 (elt, list)
+ REGISTER Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- Lisp_Object elt_car = XCAR (elt);
- if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
- return elt;
+ REGISTER Lisp_Object tem, elt;
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ return elt;
}
return Qnil;
}
*/
(key, list))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (internal_equal (key, elt_cdr, 0))
+ REGISTER Lisp_Object elt;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && internal_equal (XCDR (elt), key, 0))
return elt;
+ QUIT;
}
return Qnil;
}
*/
(key, list))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (internal_old_equal (key, elt_cdr, 0))
+ REGISTER Lisp_Object elt;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0))
return elt;
+ QUIT;
}
return Qnil;
}
*/
(key, list))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
+ REGISTER Lisp_Object elt, tem;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
return elt;
+ QUIT;
}
return Qnil;
}
*/
(key, list))
{
- Lisp_Object elt, elt_car, elt_cdr;
- EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
+ REGISTER Lisp_Object tail;
+ LIST_LOOP (tail, list)
{
- if (HACKEQ_UNSAFE (key, elt_cdr))
+ REGISTER Lisp_Object elt, tem;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem)))
return elt;
+ QUIT;
}
return Qnil;
}
-/* Like Frassq, but caller must ensure that LIST is properly
- nil-terminated and ebola-free. */
Lisp_Object
rassq_no_quit (Lisp_Object key, Lisp_Object list)
{
- Lisp_Object elt;
- LIST_LOOP_2 (elt, list)
+ REGISTER Lisp_Object tail;
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- Lisp_Object elt_cdr = XCDR (elt);
- if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
+ REGISTER Lisp_Object elt, tem;
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
return elt;
}
return Qnil;
*/
(elt, list))
{
- Lisp_Object list_elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_equal (elt, list_elt, 0)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ CONCHECK_CONS (tail);
+ if (internal_equal (elt, XCAR (tail), 0))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
*/
(elt, list))
{
- Lisp_Object list_elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (internal_old_equal (elt, list_elt, 0)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ CONCHECK_CONS (tail);
+ if (internal_old_equal (elt, XCAR (tail), 0))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
*/
(elt, list))
{
- Lisp_Object list_elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object tem;
+ CONCHECK_CONS (tail);
+ if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
*/
(elt, list))
{
- Lisp_Object list_elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
- (HACKEQ_UNSAFE (elt, list_elt)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object tem;
+ CONCHECK_CONS (tail);
+ if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
-/* Like Fdelq, but caller must ensure that LIST is properly
- nil-terminated and ebola-free. */
+/* no quit, no errors; be careful */
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)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (CONSP (tail))
+ {
+ REGISTER Lisp_Object tem;
+ if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ }
return list;
}
{
REGISTER Lisp_Object tail = list;
REGISTER Lisp_Object prev = Qnil;
+ struct Lisp_Cons *cons_to_free = NULL;
- while (!NILP (tail))
+ while (CONSP (tail))
{
- REGISTER Lisp_Object tem = XCAR (tail);
- if (EQ (elt, tem))
+ REGISTER Lisp_Object tem;
+ if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
{
- Lisp_Object cons_to_free = tail;
if (NILP (prev))
list = XCDR (tail);
else
XCDR (prev) = XCDR (tail);
- tail = XCDR (tail);
- free_cons (XCONS (cons_to_free));
+ cons_to_free = XCONS (tail);
}
else
+ prev = tail;
+ tail = XCDR (tail);
+ if (cons_to_free)
{
- prev = tail;
- tail = XCDR (tail);
+ free_cons (cons_to_free);
+ cons_to_free = NULL;
}
}
return list;
*/
(key, list))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
- (CONSP (elt) &&
- internal_equal (key, XCAR (elt), 0)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object elt;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && internal_equal (key, XCAR (elt), 0))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
*/
(key, list))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object elt, tem;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
Lisp_Object
remassq_no_quit (Lisp_Object key, Lisp_Object list)
{
- Lisp_Object elt;
- LIST_LOOP_DELETE_IF (elt, list,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
- return list;
-}
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
-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
-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))
+ while (CONSP (tail))
+ {
+ REGISTER Lisp_Object elt, tem;
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ }
+ return list;
+}
+
+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
+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))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
- (CONSP (elt) &&
- internal_equal (value, XCDR (elt), 0)));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object elt;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && internal_equal (value, XCDR (elt), 0))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
*/
(value, list))
{
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object elt, tem;
+ CONCHECK_CONS (tail);
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ QUIT;
+ }
return list;
}
-/* Like Fremrassq, fast and unsafe; be careful */
+/* no quit, no errors; be careful */
+
Lisp_Object
remrassq_no_quit (Lisp_Object value, Lisp_Object list)
{
- Lisp_Object elt;
- LIST_LOOP_DELETE_IF (elt, list,
- (CONSP (elt) &&
- EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
+ REGISTER Lisp_Object tail = list;
+ REGISTER Lisp_Object prev = Qnil;
+
+ while (CONSP (tail))
+ {
+ REGISTER Lisp_Object elt, tem;
+ elt = XCAR (tail);
+ if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
+ {
+ if (NILP (prev))
+ list = XCDR (tail);
+ else
+ XCDR (prev) = XCDR (tail);
+ }
+ else
+ prev = tail;
+ tail = XCDR (tail);
+ }
return list;
}
while (!NILP (tail))
{
REGISTER Lisp_Object next;
+ QUIT;
CONCHECK_CONS (tail);
next = XCDR (tail);
XCDR (tail) = prev;
*/
(list))
{
- Lisp_Object reversed_list = Qnil;
- Lisp_Object elt;
- EXTERNAL_LIST_LOOP_2 (elt, list)
+ REGISTER Lisp_Object tail;
+ Lisp_Object new = Qnil;
+
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
- reversed_list = Fcons (elt, reversed_list);
+ new = Fcons (XCAR (tail), new);
+ QUIT;
}
- return reversed_list;
+ if (!NILP (tail))
+ dead_wrong_type_argument (Qlistp, tail);
+ return new;
}
\f
static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
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 use eq, not equal. */
+ int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
int la, lb, m, i, fill;
Lisp_Object *keys, *vals;
char *flags;
{
if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
{
- if (eqp
- /* We narrowly escaped being Ebolified here. */
- ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
- : !internal_equal (v, vals [i], depth))
+ if ((eqp
+ /* We narrowly escaped being Ebolified here. */
+ ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
+ : !internal_equal (v, vals [i], depth)))
/* a property in B has a different value than in A */
goto MISMATCH;
flags [i] = 1;
Lisp_Object
internal_plist_get (Lisp_Object plist, Lisp_Object property)
{
- Lisp_Object tail;
+ Lisp_Object tail = plist;
- for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
+ for (; !NILP (tail); tail = XCDR (XCDR (tail)))
{
- if (EQ (XCAR (tail), property))
- return XCAR (XCDR (tail));
+ struct Lisp_Cons *c = XCONS (tail);
+ if (EQ (c->car, property))
+ return XCAR (c->cdr);
}
return Qunbound;
int
internal_remprop (Lisp_Object *plist, Lisp_Object property)
{
- Lisp_Object tail, prev;
+ Lisp_Object tail = *plist;
- for (tail = *plist, prev = Qnil;
- !NILP (tail);
+ if (NILP (tail))
+ return 0;
+
+ if (EQ (XCAR (tail), property))
+ {
+ *plist = XCDR (XCDR (tail));
+ return 1;
+ }
+
+ for (tail = XCDR (tail); !NILP (XCDR (tail));
tail = XCDR (XCDR (tail)))
{
- if (EQ (XCAR (tail), property))
+ struct Lisp_Cons *c = XCONS (tail);
+ if (EQ (XCAR (c->cdr), property))
{
- if (NILP (prev))
- *plist = XCDR (XCDR (tail));
- else
- XCDR (XCDR (prev)) = XCDR (XCDR (tail));
+ c->cdr = XCDR (XCDR (c->cdr));
return 1;
}
- else
- prev = tail;
}
return 0;
Lisp_Object *tortsave = *tortoise;
/* Note that our "fixing" may be more brutal than necessary,
- but it's the user's own problem, not ours, if they went in and
+ but it's the user's own problem, not ours. if they went in and
manually fucked up a plist. */
for (i = 0; i < 2; i++)
(plist, prop, default_))
{
Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
- return UNBOUNDP (val) ? default_ : val;
+ if (UNBOUNDP (val))
+ return default_;
+ return val;
}
DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
*/
(plist, prop))
{
- Lisp_Object val = Fplist_get (plist, prop, Qunbound);
- return UNBOUNDP (val) ? Qnil : Qt;
+ return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? 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.
+the plist; that means it's a malformed or circular plist or has non-symbols
+as keywords.
*/
(plist))
{
/* external_remprop returns 1 if it removed any property.
We have to loop till it didn't remove anything, in case
the property occurs many times. */
- while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
- DO_NOTHING;
+ while (external_remprop (&XCDR (next), prop, 0, ERROR_ME));
plist = Fcdr (next);
}
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
+VALUE1 PROP2 VALUE2...), where comparions 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, prop, default_))
{
Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
- return UNBOUNDP (val) ? default_ : val;
+ if (UNBOUNDP (val))
+ return default_;
+ return val;
}
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
+VALUE1 PROP2 VALUE2...), where comparions 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
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
+VALUE1 PROP2 VALUE2...), where comparions 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.
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
+VALUE1 PROP2 VALUE2...), where comparions between properties is done
using `equal' instead of `eq'.
*/
(lax_plist, prop))
/* external_remprop returns 1 if it removed any property.
We have to loop till it didn't remove anything, in case
the property occurs many times. */
- while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
- DO_NOTHING;
+ while (external_remprop (&XCDR (next), prop, 1, ERROR_ME));
lax_plist = Fcdr (next);
}
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 PROPERTY property.
-This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
+Return the value of OBJECT's PROPNAME property.
+This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
If there is no such property, return optional third arg DEFAULT
-\(which defaults to `nil'). OBJECT can be a symbol, string, extent,
-face, or glyph. See also `put', `remprop', and `object-plist'.
+\(which defaults to `nil'). OBJECT can be a symbol, face, extent,
+or string. See also `put', `remprop', and `object-plist'.
*/
- (object, property, default_))
+ (object, propname, default_))
{
+ Lisp_Object val;
+
/* Various places in emacs call Fget() and expect it not to quit,
so don't quit. */
- Lisp_Object val;
- if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
- val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
+ /* It's easiest to treat symbols specially because they may not
+ be an lrecord */
+ if (SYMBOLP (object))
+ val = symbol_getprop (object, propname, default_);
+ else if (STRINGP (object))
+ val = string_getprop (XSTRING (object), propname, default_);
+ else if (LRECORDP (object))
+ {
+ CONST struct lrecord_implementation
+ *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
+ if (imp->getprop)
+ {
+ val = (imp->getprop) (object, propname);
+ if (UNBOUNDP (val))
+ val = default_;
+ }
+ else
+ goto noprops;
+ }
else
- signal_simple_error ("Object type has no properties", object);
+ {
+ noprops:
+ signal_simple_error ("Object type has no properties", object);
+ }
- return UNBOUNDP (val) ? default_ : val;
+ return val;
}
DEFUN ("put", Fput, 3, 3, 0, /*
-Set OBJECT's PROPERTY to VALUE.
-It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
-OBJECT can be a symbol, face, extent, or string.
+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.
+
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, property, value))
+ (object, propname, value))
{
- CHECK_LISP_WRITEABLE (object);
+ CHECK_SYMBOL (propname);
+ CHECK_IMPURE (object);
- if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
+ if (SYMBOLP (object))
+ symbol_putprop (object, propname, value);
+ else if (STRINGP (object))
+ string_putprop (XSTRING (object), propname, value);
+ else if (LRECORDP (object))
{
- if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
- (object, property, value))
- signal_simple_error ("Can't set property on object", property);
+ 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;
}
else
- signal_simple_error ("Object type has no settable properties", object);
+ {
+ noprops:
+ 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, 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'.
+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'.
*/
- (object, property))
+ (object, propname))
{
- int ret = 0;
+ int retval = 0;
- CHECK_LISP_WRITEABLE (object);
+ CHECK_SYMBOL (propname);
+ CHECK_IMPURE (object);
- if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
+ if (SYMBOLP (object))
+ retval = symbol_remprop (object, propname);
+ else if (STRINGP (object))
+ retval = string_remprop (XSTRING (object), propname);
+ else if (LRECORDP (object))
{
- ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
- if (ret == -1)
- signal_simple_error ("Can't remove property from object", property);
+ 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;
}
else
- signal_simple_error ("Object type has no removable properties", object);
+ {
+ noprops:
+ signal_simple_error ("Object type has no removable properties", object);
+ }
- return ret ? Qt : Qnil;
+ return retval ? Qt : Qnil;
}
DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
-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.
+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.)
*/
(object))
{
- if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
- return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (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);
+ }
else
signal_simple_error ("Object type has no properties", object);
\f
int
-internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+internal_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
+#ifndef LRECORD_CONS
+ do_cdr:
+#endif
QUIT;
- if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
+ if (EQ_WITH_EBOLA_NOTICE (o1, o2))
return 1;
/* Note that (equal 20 20.0) should be nil */
- if (XTYPE (obj1) != XTYPE (obj2))
+ else if (XTYPE (o1) != XTYPE (o2))
return 0;
- if (LRECORDP (obj1))
+#ifndef LRECORD_CONS
+ else if (CONSP (o1))
{
- const struct lrecord_implementation
- *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
- *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
-
- return (imp1 == imp2) &&
+ if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
+ return 0;
+ o1 = XCDR (o1);
+ o2 = XCDR (o2);
+ goto do_cdr;
+ }
+#endif
+#ifndef LRECORD_VECTOR
+ else if (VECTORP (o1))
+ {
+ Lisp_Object *v1 = XVECTOR_DATA (o1);
+ Lisp_Object *v2 = XVECTOR_DATA (o2);
+ int len = XVECTOR_LENGTH (o1);
+ if (len != XVECTOR_LENGTH (o2))
+ return 0;
+ while (len--)
+ if (!internal_equal (*v1++, *v2++, depth + 1))
+ return 0;
+ return 1;
+ }
+#endif
+#ifndef LRECORD_STRING
+ else if (STRINGP (o1))
+ {
+ Bytecount len;
+ return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
+ !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
+ }
+#endif
+ else if (LRECORDP (o1))
+ {
+ CONST struct lrecord_implementation
+ *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
+ *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
+ if (imp1 != imp2)
+ return 0;
+ else if (imp1->equal == 0)
/* EQ-ness of the objects was noticed above */
- (imp1->equal && (imp1->equal) (obj1, obj2, depth));
+ return 0;
+ else
+ return (imp1->equal) (o1, o2, depth);
}
return 0;
but that seems unlikely. */
static int
-internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
+#ifndef LRECORD_CONS
+ do_cdr:
+#endif
QUIT;
- if (HACKEQ_UNSAFE (obj1, obj2))
+ if (HACKEQ_UNSAFE (o1, o2))
return 1;
/* Note that (equal 20 20.0) should be nil */
- if (XTYPE (obj1) != XTYPE (obj2))
+ else if (XTYPE (o1) != XTYPE (o2))
return 0;
+#ifndef LRECORD_CONS
+ else if (CONSP (o1))
+ {
+ if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1))
+ return 0;
+ o1 = XCDR (o1);
+ o2 = XCDR (o2);
+ goto do_cdr;
+ }
+#endif
+#ifndef LRECORD_VECTOR
+ else if (VECTORP (o1))
+ {
+ int indice;
+ int len = XVECTOR_LENGTH (o1);
+ if (len != XVECTOR_LENGTH (o2))
+ return 0;
+ for (indice = 0; indice < len; indice++)
+ {
+ if (!internal_old_equal (XVECTOR_DATA (o1) [indice],
+ XVECTOR_DATA (o2) [indice],
+ depth + 1))
+ return 0;
+ }
+ return 1;
+ }
+#endif
+#ifndef LRECORD_STRING
+ else if (STRINGP (o1))
+ {
+ Bytecount len = XSTRING_LENGTH (o1);
+ if (len != XSTRING_LENGTH (o2))
+ return 0;
+ if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
+ return 0;
+ return 1;
+ }
+#endif
+ else if (LRECORDP (o1))
+ {
+ CONST struct lrecord_implementation
+ *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
+ *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
+ if (imp1 != imp2)
+ return 0;
+ else if (imp1->equal == 0)
+ /* EQ-ness of the objects was noticed above */
+ return 0;
+ else
+ return (imp1->equal) (o1, o2, depth);
+ }
- return internal_equal (obj1, obj2, depth);
+ return 0;
}
DEFUN ("equal", Fequal, 2, 2, 0, /*
Vectors and strings are compared element by element.
Numbers are compared by value. Symbols must match exactly.
*/
- (obj1, obj2))
+ (o1, o2))
{
- return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
+ return internal_equal (o1, o2, 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))
+ (o1, o2))
{
- return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
+ return internal_old_equal (o1, o2, 0) ? Qt : Qnil;
}
\f
DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
-Destructively modify ARRAY by replacing each element with ITEM.
+Store each element of ARRAY with ITEM.
ARRAY is a vector, bit vector, or string.
*/
(array, item))
retry:
if (STRINGP (array))
{
- 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;
-
+ Emchar charval;
+ struct Lisp_String *s = XSTRING (array);
+ Charcount len = string_char_length (s);
+ Charcount i;
CHECK_CHAR_COERCE_INT (item);
- 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';
-
+ CHECK_IMPURE (array);
+ charval = XCHAR (item);
+ for (i = 0; i < len; i++)
+ set_string_char (s, i, charval);
bump_string_modiff (array);
}
else if (VECTORP (array))
{
Lisp_Object *p = XVECTOR_DATA (array);
int len = XVECTOR_LENGTH (array);
- CHECK_LISP_WRITEABLE (array);
+ CHECK_IMPURE (array);
while (len--)
*p++ = item;
}
else if (BIT_VECTORP (array))
{
- Lisp_Bit_Vector *v = XBIT_VECTOR (array);
+ struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
int len = bit_vector_length (v);
int bit;
CHECK_BIT (item);
- CHECK_LISP_WRITEABLE (array);
+ CHECK_IMPURE (array);
bit = XINT (item);
while (len--)
set_bit_vector_bit (v, len, bit);
}
Lisp_Object
-nconc2 (Lisp_Object arg1, Lisp_Object arg2)
+nconc2 (Lisp_Object s1, Lisp_Object s2)
{
Lisp_Object args[2];
- struct gcpro gcpro1;
- args[0] = arg1;
- args[1] = arg2;
-
- GCPRO1 (args[0]);
- gcpro1.nvars = 2;
-
- RETURN_UNGCPRO (bytecode_nconc2 (args));
-}
-
-Lisp_Object
-bytecode_nconc2 (Lisp_Object *args)
-{
- retry:
-
- if (CONSP (args[0]))
- {
- /* (setcdr (last args[0]) args[1]) */
- Lisp_Object tortoise, hare;
- int count;
-
- for (hare = tortoise = args[0], count = 0;
- CONSP (XCDR (hare));
- hare = XCDR (hare), count++)
- {
- if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
-
- if (count & 1)
- tortoise = XCDR (tortoise);
- if (EQ (hare, tortoise))
- signal_circular_list_error (args[0]);
- }
- XCDR (hare) = args[1];
- return args[0];
- }
- else if (NILP (args[0]))
- {
- return args[1];
- }
- else
- {
- args[0] = wrong_type_argument (args[0], Qlistp);
- goto retry;
- }
+ args[0] = s1;
+ args[1] = s2;
+ return Fnconc (2, args);
}
DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
while (argnum < nargs)
{
- Lisp_Object val;
- retry:
- val = args[argnum];
+ Lisp_Object val = args[argnum];
if (CONSP (val))
{
- /* `val' is the first cons, which will be our return value. */
- /* `last_cons' will be the cons cell to mutate. */
- Lisp_Object last_cons = val;
- Lisp_Object tortoise = val;
+ /* Found the first cons, which will be our return value. */
+ Lisp_Object last = val;
for (argnum++; argnum < nargs; argnum++)
{
Lisp_Object next = args[argnum];
- retry_next:
+ redo:
if (CONSP (next) || argnum == nargs -1)
{
/* (setcdr (last val) next) */
- int count;
-
- for (count = 0;
- CONSP (XCDR (last_cons));
- last_cons = XCDR (last_cons), count++)
+ while (CONSP (XCDR (last)))
{
- if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
-
- if (count & 1)
- tortoise = XCDR (tortoise);
- if (EQ (last_cons, tortoise))
- signal_circular_list_error (args[argnum-1]);
+ last = XCDR (last);
+ QUIT;
}
- XCDR (last_cons) = next;
+ XCDR (last) = next;
}
else if (NILP (next))
{
}
else
{
- next = wrong_type_argument (Qlistp, next);
- goto retry_next;
+ next = wrong_type_argument (next, Qlistp);
+ goto redo;
}
}
RETURN_UNGCPRO (val);
else if (argnum == nargs - 1) /* last arg? */
RETURN_UNGCPRO (val);
else
- {
- args[argnum] = wrong_type_argument (Qlistp, val);
- goto retry;
- }
+ args[argnum] = wrong_type_argument (val, Qlistp);
}
RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
}
\f
-/* 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.
+/* 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.
- If VALS is a null pointer, do not accumulate the results. */
+ If VALS is a null pointer, do not accumulate the results. */
static void
-mapcar1 (size_t leni, Lisp_Object *vals,
- Lisp_Object function, Lisp_Object sequence)
+mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
{
- Lisp_Object result;
- Lisp_Object args[2];
+ Lisp_Object tail;
+ Lisp_Object dummy = Qnil;
int i;
- struct gcpro gcpro1;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+ Lisp_Object result;
+
+ GCPRO3 (dummy, fn, seq);
if (vals)
{
- GCPRO1 (vals[0]);
- gcpro1.nvars = 0;
+ /* Don't let vals contain any garbage when GC happens. */
+ for (i = 0; i < leni; i++)
+ vals[i] = Qnil;
+ gcpro1.var = vals;
+ gcpro1.nvars = leni;
}
- args[0] = function;
+ /* We need not explicitly protect `tail' because it is used only on
+ lists, and 1) lists are not relocated and 2) the list is marked
+ via `seq' so will not be freed */
- if (LISTP (sequence))
+ if (VECTORP (seq))
{
- /* A devious `function' could either:
- - insert garbage into the list in front of us, causing XCDR to crash
- - amputate the list behind us using (setcdr), causing the remaining
- elts to lose their GCPRO status.
-
- if (vals != 0) we avoid this by copying the elts into the
- `vals' array. By a stroke of luck, `vals' is exactly large
- enough to hold the elts left to be traversed as well as the
- results computed so far.
-
- if (vals == 0) we don't have any free space available and
- don't want to eat up any more stack with alloca().
- So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
-
- if (vals)
- {
- Lisp_Object *val = vals;
- Lisp_Object elt;
-
- LIST_LOOP_2 (elt, sequence)
- *val++ = elt;
-
- gcpro1.nvars = leni;
-
- for (i = 0; i < leni; i++)
- {
- args[1] = vals[i];
- vals[i] = Ffuncall (2, args);
- }
- }
- else
+ for (i = 0; i < leni; i++)
{
- Lisp_Object elt, tail;
- struct gcpro ngcpro1;
-
- NGCPRO1 (tail);
-
- {
- EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
- {
- args[1] = elt;
- Ffuncall (2, args);
- }
- }
-
- NUNGCPRO;
+ dummy = XVECTOR_DATA (seq)[i];
+ result = call1 (fn, dummy);
+ if (vals)
+ vals[i] = result;
}
}
- else if (VECTORP (sequence))
+ else if (BIT_VECTORP (seq))
{
- Lisp_Object *objs = XVECTOR_DATA (sequence);
+ struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
for (i = 0; i < leni; i++)
{
- args[1] = *objs++;
- result = Ffuncall (2, args);
- if (vals) vals[gcpro1.nvars++] = result;
+ XSETINT (dummy, bit_vector_bit (v, i));
+ result = call1 (fn, dummy);
+ if (vals)
+ vals[i] = result;
}
}
- else if (STRINGP (sequence))
+ else if (STRINGP (seq))
{
- /* The string data of `sequence' might be relocated during GC. */
- Bytecount slen = XSTRING_LENGTH (sequence);
- Bufbyte *p = alloca_array (Bufbyte, slen);
- Bufbyte *end = p + slen;
-
- memcpy (p, XSTRING_DATA (sequence), slen);
-
- while (p < end)
+ for (i = 0; i < leni; i++)
{
- args[1] = make_char (charptr_emchar (p));
- INC_CHARPTR (p);
- result = Ffuncall (2, args);
- if (vals) vals[gcpro1.nvars++] = result;
+ result = call1 (fn, make_char (string_char (XSTRING (seq), i)));
+ if (vals)
+ vals[i] = result;
}
}
- else if (BIT_VECTORP (sequence))
+ else /* Must be a list, since Flength did not get an error */
{
- Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
+ tail = seq;
for (i = 0; i < leni; i++)
{
- args[1] = make_int (bit_vector_bit (v, i));
- result = Ffuncall (2, args);
- if (vals) vals[gcpro1.nvars++] = result;
+ result = call1 (fn, Fcar (tail));
+ if (vals)
+ vals[i] = result;
+ tail = Fcdr (tail);
}
}
- else
- abort (); /* unreachable, since Flength (sequence) did not get an error */
- if (vals)
- UNGCPRO;
+ 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 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.
*/
- (function, sequence, separator))
+ (fn, seq, sep))
{
- size_t len = XINT (Flength (sequence));
+ int len = XINT (Flength (seq));
Lisp_Object *args;
int i;
+ struct gcpro gcpro1;
int nargs = len + len - 1;
- if (len == 0) return build_string ("");
+ if (nargs < 0) return build_string ("");
args = alloca_array (Lisp_Object, nargs);
- mapcar1 (len, args, function, sequence);
+ GCPRO1 (sep);
+ mapcar1 (len, args, fn, seq);
+ UNGCPRO;
for (i = len - 1; i >= 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
- args[i] = separator;
+ args[i] = sep;
return Fconcat (nargs, args);
}
DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
-Apply FUNCTION to each element of SEQUENCE; return a list of the results.
-The result is a list of the same length as SEQUENCE.
+Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
+The result is a list just as long as SEQUENCE.
SEQUENCE may be a list, a vector, a bit vector, or a string.
*/
- (function, sequence))
+ (fn, seq))
{
- size_t len = XINT (Flength (sequence));
+ int len = XINT (Flength (seq));
Lisp_Object *args = alloca_array (Lisp_Object, len);
- mapcar1 (len, args, function, sequence);
+ mapcar1 (len, args, fn, seq);
return Flist (len, args);
}
DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
-Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
+Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
The result is a vector of the same length as SEQUENCE.
-SEQUENCE may be a list, a vector, a bit vector, or a string.
+SEQUENCE may be a list, a vector or a string.
*/
- (function, sequence))
+ (fn, seq))
{
- size_t len = XINT (Flength (sequence));
+ int len = XINT (Flength (seq));
+ /* Ideally, this should call make_vector_internal, because we don't
+ need initialization. */
Lisp_Object result = make_vector (len, Qnil);
struct gcpro gcpro1;
GCPRO1 (result);
- mapcar1 (len, XVECTOR_DATA (result), function, sequence);
+ mapcar1 (len, XVECTOR_DATA (result), fn, seq);
UNGCPRO;
return result;
}
-DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
+DEFUN ("mapc", Fmapc, 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'.
*/
- (function, sequence))
+ (fn, seq))
{
- mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
-
- 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;
+ mapcar1 (XINT (Flength (seq)), 0, fn, seq);
- return old;
+ return seq;
}
\f
(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@gnu.org>.
+<bug-gnu-emacs@prep.ai.mit.edu>.
*/
(fexp))
{
return unbind_to (speccount, feature);
}
}
-\f
-/* base64 encode/decode functions.
-
- 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)
-#define IS_BASE64(Character) \
- (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
-
-/* Table of characters coding the 64 values. */
-static char base64_value_to_char[64] =
-{
- 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
- 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
- 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
- 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
- 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
- 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
- '8', '9', '+', '/' /* 60-63 */
-};
-
-/* Table of base64 values for first 128 characters. */
-static short base64_char_to_value[128] =
-{
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
- -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
- 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
- -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
- 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
- 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
- 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
- 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
- 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
- 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
-};
-
-/* The following diagram shows the logical steps by which three octets
- get transformed into four base64 characters.
-
- .--------. .--------. .--------.
- |aaaaaabb| |bbbbcccc| |ccdddddd|
- `--------' `--------' `--------'
- 6 2 4 4 2 6
- .--------+--------+--------+--------.
- |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
- `--------+--------+--------+--------'
-
- .--------+--------+--------+--------.
- |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
- `--------+--------+--------+--------'
-
- The octets are divided into 6 bit chunks, which are then encoded into
- base64 characters. */
-
-#define ADVANCE_INPUT(c, stream) \
- ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
- ((ec > 255) ? \
- (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)
-{
- EMACS_INT counter = 0;
- Bufbyte *e = to;
- Emchar ec;
- unsigned int value;
-
- while (1)
- {
- Bufbyte c;
- if (!ADVANCE_INPUT (c, istream))
- break;
-
- /* Wrap line every 76 characters. */
- if (line_break)
- {
- if (counter < MIME_LINE_LENGTH / 4)
- counter++;
- else
- {
- *e++ = '\n';
- counter = 1;
- }
- }
-
- /* Process first byte of a triplet. */
- *e++ = base64_value_to_char[0x3f & c >> 2];
- value = (0x03 & c) << 4;
-
- /* Process second byte of a triplet. */
- if (!ADVANCE_INPUT (c, istream))
- {
- *e++ = base64_value_to_char[value];
- *e++ = '=';
- *e++ = '=';
- break;
- }
-
- *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
- value = (0x0f & c) << 2;
-
- /* Process third byte of a triplet. */
- if (!ADVANCE_INPUT (c, istream))
- {
- *e++ = base64_value_to_char[value];
- *e++ = '=';
- break;
- }
-
- *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
- *e++ = base64_value_to_char[0x3f & c];
- }
-
- return e - to;
-}
-#undef ADVANCE_INPUT
-
-/* 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))); \
- ++ccnt; \
-} while (0)
-
-static Bytind
-base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
-{
- Charcount ccnt = 0;
- Bufbyte *e = to;
- EMACS_INT streampos = 0;
-
- while (1)
- {
- Emchar ec;
- unsigned long value;
-
- /* Process first byte of a quadruplet. */
- 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. */
- 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. */
- ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
- if (ec < 0)
- error ("Premature EOF while decoding base64");
-
- if (ec == '=')
- {
- 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;
- }
-
- value |= base64_char_to_value[ec] << 6;
- STORE_BYTE (e, 0xff & value >> 8, ccnt);
-
- /* Process fourth byte of a quadruplet. */
- ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
- if (ec < 0)
- error ("Premature EOF while decoding base64");
- if (ec == '=')
- continue;
-
- value |= base64_char_to_value[ec];
- STORE_BYTE (e, 0xff & value, ccnt);
- }
-
- *ccptr = ccnt;
- return e - to;
-}
-#undef ADVANCE_INPUT
-#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.
-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))
-{
- Bufbyte *encoded;
- Bytind encoded_length;
- Charcount allength, length;
- 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);
- barf_if_buffer_read_only (buf, begv, zv);
-
- /* We need to allocate enough room for encoding the text.
- We need 33 1/3% more space, plus a newline every 76
- characters, and then we round up. */
- length = zv - begv;
- allength = length + length/3 + 1;
- allength += allength / MIME_LINE_LENGTH + 1 + 6;
-
- input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
- /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
- base64 characters will be single-byte. */
- XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
- encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
- NILP (no_line_break));
- if (encoded_length > allength)
- abort ();
- Lstream_delete (XLSTREAM (input));
-
- /* Now we have encoded the region, so we insert the new contents
- and delete the old. (Insert first in order to preserve markers.) */
- buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
- XMALLOC_UNBIND (encoded, allength, speccount);
- buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
-
- /* 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);
-
- /* We return the length of the encoded text. */
- return make_int (encoded_length);
-}
-
-DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
-Base64 encode STRING and return the result.
-*/
- (string, no_line_break))
-{
- Charcount allength, length;
- Bytind encoded_length;
- Bufbyte *encoded;
- Lisp_Object input, result;
- int speccount = specpdl_depth();
-
- CHECK_STRING (string);
- length = XSTRING_CHAR_LENGTH (string);
- allength = length + length/3 + 1;
- allength += allength / MIME_LINE_LENGTH + 1 + 6;
-
- input = make_lisp_string_input_stream (string, 0, -1);
- XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
- encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
- NILP (no_line_break));
- if (encoded_length > allength)
- abort ();
- Lstream_delete (XLSTREAM (input));
- result = make_string (encoded, encoded_length);
- XMALLOC_UNBIND (encoded, allength, speccount);
- return result;
-}
-
-DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
-Base64-decode the region between BEG 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))
-{
- struct buffer *buf = current_buffer;
- Bufpos begv, zv, old_pt = BUF_PT (buf);
- Bufbyte *decoded;
- Bytind decoded_length;
- Charcount length, cc_decoded_length;
- Lisp_Object input;
- int speccount = specpdl_depth();
-
- get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
- barf_if_buffer_read_only (buf, begv, zv);
-
- length = zv - begv;
-
- input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
- /* We need to allocate enough room for decoding the text. */
- 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 ();
- Lstream_delete (XLSTREAM (input));
-
- /* 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_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
- buffer_delete_range (buf, begv + cc_decoded_length,
- zv + cc_decoded_length, 0);
-
- /* 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);
-
- return make_int (cc_decoded_length);
-}
-
-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))
-{
- Bufbyte *decoded;
- Bytind decoded_length;
- Charcount length, cc_decoded_length;
- Lisp_Object input, result;
- int speccount = specpdl_depth();
-
- CHECK_STRING (string);
-
- length = XSTRING_CHAR_LENGTH (string);
- /* We need to allocate enough room for decoding the text. */
- XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
-
- input = make_lisp_string_input_stream (string, 0, -1);
- decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
- &cc_decoded_length);
- if (decoded_length > length * MAX_EMCHAR_LEN)
- abort ();
- Lstream_delete (XLSTREAM (input));
-
- result = make_string (decoded, decoded_length);
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
- return result;
-}
\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 (&Qyes_or_no_p, "yes-or-no-p");
DEFSUBR (Fconcat);
DEFSUBR (Fvconcat);
DEFSUBR (Fbvconcat);
- DEFSUBR (Fcopy_list);
DEFSUBR (Fcopy_sequence);
DEFSUBR (Fcopy_alist);
DEFSUBR (Fcopy_tree);
DEFSUBR (Fnthcdr);
DEFSUBR (Fnth);
DEFSUBR (Felt);
- DEFSUBR (Flast);
- DEFSUBR (Fbutlast);
- DEFSUBR (Fnbutlast);
DEFSUBR (Fmember);
DEFSUBR (Fold_member);
DEFSUBR (Fmemq);
DEFSUBR (Fnconc);
DEFSUBR (Fmapcar);
DEFSUBR (Fmapvector);
- DEFSUBR (Fmapc_internal);
+ DEFSUBR (Fmapc);
DEFSUBR (Fmapconcat);
- DEFSUBR (Freplace_list);
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);
DEFSUBR (Fprovide);
- DEFSUBR (Fbase64_encode_region);
- DEFSUBR (Fbase64_encode_string);
- DEFSUBR (Fbase64_decode_region);
- DEFSUBR (Fbase64_decode_string);
}
void
Used by `featurep' and `require', and altered by `provide'.
*/ );
Vfeatures = Qnil;
-
- Fprovide (intern ("base64"));
}