#include "buffer.h"
#include "bytecode.h"
-#include "commands.h"
#include "device.h"
#include "events.h"
#include "extents.h"
}
static int
-bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1);
- struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2);
+ struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
+ struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
!memcmp (v1->bits, v2->bits,
DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
mark_bit_vector, print_bit_vector, 0,
- bit_vector_equal, bit_vector_hash,
+ bit_vector_equal, bit_vector_hash, 0,
struct Lisp_Bit_Vector);
\f
DEFUN ("identity", Fidentity, 1, 1, 0, /*
return XINT (Flength (seq));
else
{
- struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq);
+ struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
- return (b->flags.interactivep ? COMPILED_INTERACTIVE :
- b->flags.domainp ? COMPILED_DOMAIN :
+ return (f->flags.interactivep ? COMPILED_INTERACTIVE :
+ f->flags.domainp ? COMPILED_DOMAIN :
COMPILED_DOC_STRING)
+ 1;
}
return make_int (XSTRING_CHAR_LENGTH (sequence));
else if (CONSP (sequence))
{
- Lisp_Object tail;
- int i = 0;
-
- EXTERNAL_LIST_LOOP (tail, sequence)
- {
- QUIT;
- i++;
- }
-
- return make_int (i);
+ int len;
+ GET_EXTERNAL_LIST_LENGTH (sequence, len);
+ return make_int (len);
}
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 halftail = list; /* Used to detect circular lists. */
- Lisp_Object tail;
- int len = 0;
+ Lisp_Object hare, tortoise;
+ int len;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (hare = tortoise = list, len = 0;
+ CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
+ hare = XCDR (hare), len++)
{
- if (EQ (tail, halftail) && len != 0)
- break;
- len++;
- if ((len & 1) == 0)
- halftail = XCDR (halftail);
+ if (len & 1)
+ tortoise = XCDR (tortoise);
}
return make_int (len);
properly, it would still not work because strcoll() does not
handle multiple locales. This is the fundamental flaw in the
locale model. */
- Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
- /* Compare strings using collation order of locale. */
- /* Need to be tricky to handle embedded nulls. */
+ {
+ Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
+ /* Compare strings using collation order of locale. */
+ /* Need to be tricky to handle embedded nulls. */
- for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
- {
- int val = strcoll ((char *) string_data (p1) + i,
- (char *) string_data (p2) + i);
- if (val < 0)
- return Qt;
- if (val > 0)
- return Qnil;
- }
+ for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
+ {
+ int val = strcoll ((char *) string_data (p1) + i,
+ (char *) string_data (p2) + i);
+ if (val < 0)
+ return Qt;
+ if (val > 0)
+ return Qnil;
+ }
+ }
#else /* not I18N2, or MULE */
- /* #### It is not really necessary to do this: We could compare
- byte-by-byte and still get a reasonable comparison, since this
- would compare characters with a charset in the same way.
- With a little rearrangement of the leading bytes, we could
- make most inter-charset comparisons work out the same, too;
- even if some don't, this is not a big deal because inter-charset
- comparisons aren't really well-defined anyway. */
- for (i = 0; i < end; i++)
- {
- if (string_char (p1, i) != string_char (p2, i))
- return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil;
- }
+ {
+ Bufbyte *ptr1 = string_data (p1);
+ Bufbyte *ptr2 = string_data (p2);
+
+ /* #### It is not really necessary to do this: We could compare
+ byte-by-byte and still get a reasonable comparison, since this
+ would compare characters with a charset in the same way. With
+ a little rearrangement of the leading bytes, we could make most
+ inter-charset comparisons work out the same, too; even if some
+ don't, this is not a big deal because inter-charset comparisons
+ aren't really well-defined anyway. */
+ for (i = 0; i < end; i++)
+ {
+ if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
+ return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
+ INC_CHARPTR (ptr1);
+ INC_CHARPTR (ptr2);
+ }
+ }
#endif /* not I18N2, or MULE */
/* Can't do i < len2 because then comparison between "foo" and "foo^@"
won't work right in I18N2 case */
return concat (nargs, args, c_bit_vector, 0);
}
-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
+/* 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;
+ int 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
with the original.
*/
- (arg))
+ (list))
{
again:
- 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;
+ if (NILP (list)) return list;
+ if (CONSP (list)) return copy_list (list);
- 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);
+ list = wrong_type_argument (Qlistp, list);
+ goto again;
+}
- check_losing_bytecode ("copy-sequence", arg);
- arg = wrong_type_argument (Qsequencep, arg);
+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);
goto again;
}
(string, from, to))
{
Charcount ccfr, ccto;
- Bytecount bfr, bto;
+ Bytecount bfr, blen;
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);
- bto = charcount_to_bytecount (XSTRING_DATA (string), ccto);
- val = make_string (XSTRING_DATA (string) + bfr, bto - bfr);
+ 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, bto - bfr);
+ copy_string_extents (val, string, 0, bfr, blen);
return val;
}
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))
}
/* Utter perversity */
{
- struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence);
+ Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
switch (idx)
{
case COMPILED_ARGLIST:
- return b->arglist;
- case COMPILED_BYTECODE:
- return b->bytecodes;
+ return compiled_function_arglist (f);
+ case COMPILED_INSTRUCTIONS:
+ return compiled_function_instructions (f);
case COMPILED_CONSTANTS:
- return b->constants;
+ return compiled_function_constants (f);
case COMPILED_STACK_DEPTH:
- return make_int (b->maxdepth);
+ return compiled_function_stack_depth (f);
case COMPILED_DOC_STRING:
- return compiled_function_documentation (b);
+ return compiled_function_documentation (f);
case COMPILED_DOMAIN:
- return compiled_function_domain (b);
+ return compiled_function_domain (f);
case COMPILED_INTERACTIVE:
- if (b->flags.interactivep)
- return compiled_function_interactive (b);
+ if (f->flags.interactivep)
+ return compiled_function_interactive (f);
/* 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))
+{
+ 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))
+{
+ 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))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- CONCHECK_CONS (tail);
- if (internal_equal (elt, XCAR (tail), 0))
+ if (internal_equal (elt, list_elt, 0))
return tail;
- QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- CONCHECK_CONS (tail);
- if (internal_old_equal (elt, XCAR (tail), 0))
+ if (internal_old_equal (elt, list_elt, 0))
return tail;
- QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- REGISTER Lisp_Object tem;
- CONCHECK_CONS (tail);
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
return tail;
- QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- REGISTER Lisp_Object tem;
- CONCHECK_CONS (tail);
- if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
+ if (HACKEQ_UNSAFE (elt, list_elt))
return tail;
- QUIT;
}
return Qnil;
}
Lisp_Object
memq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- REGISTER Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object list_elt, tail;
+ LIST_LOOP_3 (list_elt, list, tail)
{
- REGISTER Lisp_Object tem;
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
return tail;
}
return Qnil;
(key, list))
{
/* This function can GC. */
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_equal (XCAR (elt), key, 0))
+ if (internal_equal (key, elt_car, 0))
return elt;
- QUIT;
}
return Qnil;
}
(key, list))
{
/* This function can GC. */
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0))
+ if (internal_old_equal (key, elt_car, 0))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem)))
+ if (HACKEQ_UNSAFE (key, elt_car))
return elt;
- QUIT;
}
return Qnil;
}
assq_no_quit (Lisp_Object key, Lisp_Object list)
{
/* This cannot GC. */
- REGISTER Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object elt;
+ LIST_LOOP_2 (elt, list)
{
- REGISTER Lisp_Object tem, elt;
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
- return elt;
+ Lisp_Object elt_car = XCAR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ return elt;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_equal (XCDR (elt), key, 0))
+ if (internal_equal (key, elt_cdr, 0))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0))
+ if (internal_old_equal (key, elt_cdr, 0))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem)))
+ if (HACKEQ_UNSAFE (key, elt_cdr))
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)
{
- REGISTER Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object elt;
+ LIST_LOOP_2 (elt, list)
{
- REGISTER Lisp_Object elt, tem;
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ Lisp_Object elt_cdr = XCDR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
return elt;
}
return Qnil;
*/
(elt, list))
{
- 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;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_equal (elt, list_elt, 0)));
return list;
}
*/
(elt, list))
{
- 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;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_old_equal (elt, list_elt, 0)));
return list;
}
*/
(elt, list))
{
- 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;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
return list;
}
*/
(elt, list))
{
- 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;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (HACKEQ_UNSAFE (elt, list_elt)));
return list;
}
-/* no quit, no errors; be careful */
+/* Like Fdelq, but caller must ensure that LIST is properly
+ nil-terminated and ebola-free. */
Lisp_Object
delq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- 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);
- }
+ Lisp_Object list_elt;
+ LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
return list;
}
{
REGISTER Lisp_Object tail = list;
REGISTER Lisp_Object prev = Qnil;
- struct Lisp_Cons *cons_to_free = NULL;
- while (CONSP (tail))
+ while (!NILP (tail))
{
- REGISTER Lisp_Object tem;
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ REGISTER Lisp_Object tem = XCAR (tail);
+ if (EQ (elt, tem))
{
+ Lisp_Object cons_to_free = tail;
if (NILP (prev))
list = XCDR (tail);
else
XCDR (prev) = XCDR (tail);
- cons_to_free = XCONS (tail);
+ tail = XCDR (tail);
+ free_cons (XCONS (cons_to_free));
}
else
- prev = tail;
- tail = XCDR (tail);
- if (cons_to_free)
{
- free_cons (cons_to_free);
- cons_to_free = NULL;
+ prev = tail;
+ tail = XCDR (tail);
}
}
return list;
*/
(key, list))
{
- 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;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ internal_equal (key, XCAR (elt), 0)));
return list;
}
*/
(key, list))
{
- 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;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
return list;
}
Lisp_Object
remassq_no_quit (Lisp_Object key, Lisp_Object list)
{
- 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 (key, tem)))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- }
+ Lisp_Object elt;
+ LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
return list;
}
*/
(value, list))
{
- 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;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ internal_equal (value, XCDR (elt), 0)));
return list;
}
*/
(value, list))
{
- 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 = XCDR (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;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
return list;
}
-/* no quit, no errors; be careful */
-
+/* Like Fremrassq, fast and unsafe; be careful */
Lisp_Object
remrassq_no_quit (Lisp_Object value, Lisp_Object list)
{
- 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 = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- }
+ Lisp_Object elt;
+ LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
return list;
}
while (!NILP (tail))
{
REGISTER Lisp_Object next;
- QUIT;
CONCHECK_CONS (tail);
next = XCDR (tail);
XCDR (tail) = prev;
*/
(list))
{
- REGISTER Lisp_Object tail;
- Lisp_Object new = Qnil;
-
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object reversed_list = Qnil;
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_2 (elt, list)
{
- new = Fcons (XCAR (tail), new);
- QUIT;
+ reversed_list = Fcons (elt, reversed_list);
}
- if (!NILP (tail))
- dead_wrong_type_argument (Qlistp, tail);
- return new;
+ return reversed_list;
}
\f
static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
Lisp_Object
internal_plist_get (Lisp_Object plist, Lisp_Object property)
{
- Lisp_Object tail = plist;
+ Lisp_Object tail;
- for (; !NILP (tail); tail = XCDR (XCDR (tail)))
+ for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
{
- struct Lisp_Cons *c = XCONS (tail);
- if (EQ (c->car, property))
- return XCAR (c->cdr);
+ if (EQ (XCAR (tail), property))
+ return XCAR (XCDR (tail));
}
return Qunbound;
int
internal_remprop (Lisp_Object *plist, Lisp_Object property)
{
- Lisp_Object tail = *plist;
+ Lisp_Object tail, prev;
- if (NILP (tail))
- return 0;
-
- if (EQ (XCAR (tail), property))
- {
- *plist = XCDR (XCDR (tail));
- return 1;
- }
-
- for (tail = XCDR (tail); !NILP (XCDR (tail));
+ for (tail = *plist, prev = Qnil;
+ !NILP (tail);
tail = XCDR (XCDR (tail)))
{
- struct Lisp_Cons *c = XCONS (tail);
- if (EQ (XCAR (c->cdr), property))
+ if (EQ (XCAR (tail), property))
{
- c->cdr = XCDR (XCDR (c->cdr));
+ if (NILP (prev))
+ *plist = XCDR (XCDR (tail));
+ else
+ XCDR (XCDR (prev)) = XCDR (XCDR (tail));
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);
- if (UNBOUNDP (val))
- return default_;
- return val;
+ return UNBOUNDP (val) ? default_ : val;
}
DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
*/
(plist, prop))
{
- return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? Qnil : Qt;
+ Lisp_Object val = Fplist_get (plist, prop, Qunbound);
+ return UNBOUNDP (val) ? Qnil : Qt;
}
DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
/* 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));
+ while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
+ DO_NOTHING;
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 comparions between properties is done
+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.
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 comparions between properties is done
+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
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 comparions between properties is done
+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.
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 comparions between properties is done
+VALUE1 PROP2 VALUE2...), where comparisons 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));
+ while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
+ DO_NOTHING;
lax_plist = Fcdr (next);
}
*/
(object, propname, default_))
{
- Lisp_Object val;
-
/* Various places in emacs call Fget() and expect it not to quit,
so don't quit. */
/* It's easiest to treat symbols specially because they may not
be an lrecord */
if (SYMBOLP (object))
- val = symbol_getprop (object, propname, default_);
+ return symbol_getprop (object, propname, default_);
else if (STRINGP (object))
- val = string_getprop (XSTRING (object), propname, default_);
+ return 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
+ 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;
+ }
}
else
{
noprops:
signal_simple_error ("Object type has no properties", object);
+ return Qnil; /* Not reached */
}
-
- return val;
}
DEFUN ("put", Fput, 3, 3, 0, /*
(object, propname, value))
{
CHECK_SYMBOL (propname);
- CHECK_IMPURE (object);
+ CHECK_LISP_WRITEABLE (object);
if (SYMBOLP (object))
symbol_putprop (object, propname, value);
int retval = 0;
CHECK_SYMBOL (propname);
- CHECK_IMPURE (object);
+ CHECK_LISP_WRITEABLE (object);
if (SYMBOLP (object))
retval = symbol_remprop (object, propname);
\f
int
-internal_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
-#ifndef LRECORD_CONS
- do_cdr:
-#endif
QUIT;
- if (EQ_WITH_EBOLA_NOTICE (o1, o2))
+ if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
return 1;
/* Note that (equal 20 20.0) should be nil */
- else if (XTYPE (o1) != XTYPE (o2))
+ if (XTYPE (obj1) != XTYPE (obj2))
return 0;
-#ifndef LRECORD_CONS
- else if (CONSP (o1))
- {
- 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))
+ if (LRECORDP (obj1))
{
CONST struct lrecord_implementation
- *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
- *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
- if (imp1 != imp2)
- return 0;
- else if (imp1->equal == 0)
+ *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
+ *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
+
+ return (imp1 == imp2) &&
/* EQ-ness of the objects was noticed above */
- return 0;
- else
- return (imp1->equal) (o1, o2, depth);
+ (imp1->equal && (imp1->equal) (obj1, obj2, depth));
}
return 0;
but that seems unlikely. */
static int
-internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
-#ifndef LRECORD_CONS
- do_cdr:
-#endif
QUIT;
- if (HACKEQ_UNSAFE (o1, o2))
+ if (HACKEQ_UNSAFE (obj1, obj2))
return 1;
/* Note that (equal 20 20.0) should be nil */
- else if (XTYPE (o1) != XTYPE (o2))
+ if (XTYPE (obj1) != XTYPE (obj2))
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 0;
+ return internal_equal (obj1, obj2, depth);
}
DEFUN ("equal", Fequal, 2, 2, 0, /*
Vectors and strings are compared element by element.
Numbers are compared by value. Symbols must match exactly.
*/
- (o1, o2))
+ (obj1, obj2))
{
- return internal_equal (o1, o2, 0) ? Qt : Qnil;
+ return internal_equal (obj1, obj2, 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.
*/
- (o1, o2))
+ (obj1, obj2))
{
- return internal_old_equal (o1, o2, 0) ? Qt : Qnil;
+ return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
}
\f
Charcount len = string_char_length (s);
Charcount i;
CHECK_CHAR_COERCE_INT (item);
- CHECK_IMPURE (array);
+ CHECK_LISP_WRITEABLE (array);
charval = XCHAR (item);
for (i = 0; i < len; i++)
set_string_char (s, i, charval);
{
Lisp_Object *p = XVECTOR_DATA (array);
int len = XVECTOR_LENGTH (array);
- CHECK_IMPURE (array);
+ CHECK_LISP_WRITEABLE (array);
while (len--)
*p++ = item;
}
int len = bit_vector_length (v);
int bit;
CHECK_BIT (item);
- CHECK_IMPURE (array);
+ CHECK_LISP_WRITEABLE (array);
bit = XINT (item);
while (len--)
set_bit_vector_bit (v, len, bit);
}
Lisp_Object
-nconc2 (Lisp_Object s1, Lisp_Object s2)
+nconc2 (Lisp_Object arg1, Lisp_Object arg2)
{
Lisp_Object args[2];
- args[0] = s1;
- args[1] = s2;
- return Fnconc (2, args);
+ 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;
+ }
}
DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
while (argnum < nargs)
{
- Lisp_Object val = args[argnum];
+ Lisp_Object val;
+ retry:
+ val = args[argnum];
if (CONSP (val))
{
- /* Found the first cons, which will be our return value. */
- Lisp_Object last = 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;
for (argnum++; argnum < nargs; argnum++)
{
Lisp_Object next = args[argnum];
- redo:
+ retry_next:
if (CONSP (next) || argnum == nargs -1)
{
/* (setcdr (last val) next) */
- while (CONSP (XCDR (last)))
+ int count;
+
+ for (count = 0;
+ CONSP (XCDR (last_cons));
+ last_cons = XCDR (last_cons), count++)
{
- last = XCDR (last);
- QUIT;
+ 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]);
}
- XCDR (last) = next;
+ XCDR (last_cons) = next;
}
else if (NILP (next))
{
}
else
{
- next = wrong_type_argument (next, Qlistp);
- goto redo;
+ next = wrong_type_argument (Qlistp, next);
+ goto retry_next;
}
}
RETURN_UNGCPRO (val);
else if (argnum == nargs - 1) /* last arg? */
RETURN_UNGCPRO (val);
else
- args[argnum] = wrong_type_argument (val, Qlistp);
+ {
+ args[argnum] = wrong_type_argument (Qlistp, val);
+ goto retry;
+ }
}
RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
}
\f
/* This is the guts of all mapping functions.
- Apply fn to each element of seq, one by one,
- storing the results into elements of vals, a C vector of Lisp_Objects.
- leni is the length of vals, which should also be the length of seq.
+ 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 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
+mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
{
- Lisp_Object tail;
- Lisp_Object dummy = Qnil;
- int i;
- struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object result;
-
- GCPRO3 (dummy, fn, seq);
+ Lisp_Object args[2];
+ int i;
+ struct gcpro gcpro1;
if (vals)
{
- /* 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;
+ GCPRO1 (vals[0]);
+ gcpro1.nvars = 0;
}
- /* 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 */
+ args[0] = fn;
- if (VECTORP (seq))
+ if (LISTP (seq))
{
for (i = 0; i < leni; i++)
{
- dummy = XVECTOR_DATA (seq)[i];
- result = call1 (fn, dummy);
- if (vals)
- vals[i] = result;
+ args[1] = XCAR (seq);
+ seq = XCDR (seq);
+ result = Ffuncall (2, args);
+ if (vals) vals[gcpro1.nvars++] = result;
}
}
- else if (BIT_VECTORP (seq))
+ else if (VECTORP (seq))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
+ Lisp_Object *objs = XVECTOR_DATA (seq);
for (i = 0; i < leni; i++)
{
- XSETINT (dummy, bit_vector_bit (v, i));
- result = call1 (fn, dummy);
- if (vals)
- vals[i] = result;
+ args[1] = *objs++;
+ result = Ffuncall (2, args);
+ if (vals) vals[gcpro1.nvars++] = result;
}
}
else if (STRINGP (seq))
{
+ Bufbyte *p = XSTRING_DATA (seq);
for (i = 0; i < leni; i++)
{
- result = call1 (fn, make_char (string_char (XSTRING (seq), i)));
- if (vals)
- vals[i] = result;
+ args[1] = make_char (charptr_emchar (p));
+ INC_CHARPTR (p);
+ result = Ffuncall (2, args);
+ if (vals) vals[gcpro1.nvars++] = result;
}
}
- else /* Must be a list, since Flength did not get an error */
+ else if (BIT_VECTORP (seq))
{
- tail = seq;
+ struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
for (i = 0; i < leni; i++)
{
- result = call1 (fn, Fcar (tail));
- if (vals)
- vals[i] = result;
- tail = Fcdr (tail);
+ args[1] = make_int (bit_vector_bit (v, i));
+ result = Ffuncall (2, args);
+ if (vals) vals[gcpro1.nvars++] = result;
}
}
+ else
+ abort(); /* cannot get here since Flength(seq) did not get an error */
- UNGCPRO;
+ if (vals)
+ UNGCPRO;
}
DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
*/
(fn, seq, sep))
{
- int len = XINT (Flength (seq));
+ size_t len = XINT (Flength (seq));
Lisp_Object *args;
int i;
struct gcpro gcpro1;
*/
(fn, seq))
{
- int len = XINT (Flength (seq));
+ size_t len = XINT (Flength (seq));
Lisp_Object *args = alloca_array (Lisp_Object, len);
mapcar1 (len, args, fn, seq);
*/
(fn, seq))
{
- int len = XINT (Flength (seq));
- /* Ideally, this should call make_vector_internal, because we don't
- need initialization. */
+ size_t len = XINT (Flength (seq));
Lisp_Object result = make_vector (len, Qnil);
struct gcpro gcpro1;
}
\f
/* base64 encode/decode functions.
- Based on code from GNU recode. */
-#define MIME_LINE_LENGTH 76
+ Originally based on code from GNU recode. Ported to FSF Emacs by
+ Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
+ subsequently heavily hacked by Hrvoje Niksic. */
+
+#define MIME_LINE_LENGTH 72
#define IS_ASCII(Character) \
((Character) < 128)
base64 characters. */
#define ADVANCE_INPUT(c, stream) \
- (ec = Lstream_get_emchar (stream), \
- ec == -1 ? 0 : \
+ ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
((ec > 255) ? \
- (error ("Non-ascii character detected in base64 input"), 0) \
- : (c = (Bufbyte)ec, 1)))
+ (signal_simple_error ("Non-ascii character in base64 input", \
+ make_char (ec)), 0) \
+ : (c = (Bufbyte)ec), 1))
static Bytind
base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
*e++ = base64_value_to_char[0x3f & c];
}
- /* Complete last partial line. */
- if (line_break)
- if (counter > 0)
- *e++ = '\n';
-
return e - to;
}
#undef ADVANCE_INPUT
-#define ADVANCE_INPUT(c, stream) \
- (ec = Lstream_get_emchar (stream), \
- ec == -1 ? 0 : (c = (Bufbyte)ec, 1))
-
-#define INPUT_EOF_P(stream) \
- (ADVANCE_INPUT (c2, stream) \
- ? (Lstream_unget_emchar (stream, (Emchar)c2), 0) \
- : 1)
-
-#define STORE_BYTE(pos, val) do { \
+/* Get next character from the stream, except that non-base64
+ characters are ignored. This is in accordance with rfc2045. EC
+ should be an Emchar, so that it can hold -1 as the value for EOF. */
+#define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
+ ec = Lstream_get_emchar (stream); \
+ ++streampos; \
+ /* IS_BASE64 may not be called with negative arguments so check for \
+ EOF first. */ \
+ if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
+ break; \
+} while (1)
+
+#define STORE_BYTE(pos, val, ccnt) do { \
pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
- ++*ccptr; \
+ ++ccnt; \
} while (0)
static Bytind
base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
{
- EMACS_INT counter = 0;
- Emchar ec;
+ Charcount ccnt = 0;
Bufbyte *e = to;
- unsigned long value;
+ EMACS_INT streampos = 0;
- *ccptr = 0;
while (1)
{
- Bufbyte c, c2;
-
- if (!ADVANCE_INPUT (c, istream))
- break;
-
- /* Accept wrapping lines, reversibly if at each 76 characters. */
- if (c == '\n')
- {
- if (!ADVANCE_INPUT (c, istream))
- break;
- if (INPUT_EOF_P (istream))
- break;
- /* FSF Emacs has this check, apparently inherited from
- recode. However, I see no reason to be this picky about
- line length -- why reject base64 with say 72-byte lines?
- (yes, there are programs that generate them.) */
- /*if (counter != MIME_LINE_LENGTH / 4) return -1;*/
- counter = 1;
- }
- else
- counter++;
+ Emchar ec;
+ unsigned long value;
/* Process first byte of a quadruplet. */
- if (!IS_BASE64 (c))
- return -1;
- value = base64_char_to_value[c] << 18;
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ break;
+ if (ec == '=')
+ signal_simple_error ("Illegal `=' character while decoding base64",
+ make_int (streampos));
+ value = base64_char_to_value[ec] << 18;
/* Process second byte of a quadruplet. */
- if (!ADVANCE_INPUT (c, istream))
- return -1;
-
- if (!IS_BASE64 (c))
- return -1;
- value |= base64_char_to_value[c] << 12;
-
- STORE_BYTE (e, value >> 16);
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
+ if (ec == '=')
+ signal_simple_error ("Illegal `=' character while decoding base64",
+ make_int (streampos));
+ value |= base64_char_to_value[ec] << 12;
+ STORE_BYTE (e, value >> 16, ccnt);
/* Process third byte of a quadruplet. */
- if (!ADVANCE_INPUT (c, istream))
- return -1;
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
- if (c == '=')
+ if (ec == '=')
{
- if (!ADVANCE_INPUT (c, istream))
- return -1;
- if (c != '=')
- return -1;
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
+ if (ec != '=')
+ signal_simple_error ("Padding `=' expected but not found while decoding base64",
+ make_int (streampos));
continue;
}
- if (!IS_BASE64 (c))
- return -1;
- value |= base64_char_to_value[c] << 6;
-
- STORE_BYTE (e, 0xff & value >> 8);
+ value |= base64_char_to_value[ec] << 6;
+ STORE_BYTE (e, 0xff & value >> 8, ccnt);
/* Process fourth byte of a quadruplet. */
- if (!ADVANCE_INPUT (c, istream))
- return -1;
-
- if (c == '=')
+ ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
+ if (ec < 0)
+ error ("Premature EOF while decoding base64");
+ if (ec == '=')
continue;
- if (!IS_BASE64 (c))
- return -1;
- value |= base64_char_to_value[c];
-
- STORE_BYTE (e, 0xff & value);
+ value |= base64_char_to_value[ec];
+ STORE_BYTE (e, 0xff & value, ccnt);
}
+ *ccptr = ccnt;
return e - to;
}
#undef ADVANCE_INPUT
-#undef INPUT_EOF_P
+#undef ADVANCE_INPUT_IGNORE_NONBASE64
+#undef STORE_BYTE
static Lisp_Object
free_malloced_ptr (Lisp_Object unwind_obj)
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 { \
- if ((len) > MAX_ALLOCA) \
+ size_t XOA_len = (len); \
+ if (XOA_len > MAX_ALLOCA) \
{ \
- ptr = (type *)xmalloc ((len) * sizeof (type)); \
- speccount = specpdl_depth (); \
+ ptr = xnew_array (type, XOA_len); \
record_unwind_protect (free_malloced_ptr, \
make_opaque_ptr ((void *)ptr)); \
} \
else \
- ptr = alloca_array (type, len); \
+ ptr = alloca_array (type, XOA_len); \
} while (0)
-#define XMALLOC_UNBIND(ptr, len) do { \
- if ((len) > MAX_ALLOCA) \
- unbind_to (speccount, Qnil); \
+#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", /*
struct buffer *buf = current_buffer;
Bufpos begv, zv, old_pt = BUF_PT (buf);
Lisp_Object input;
- int speccount;
+ 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
/* 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);
+ XMALLOC_UNBIND (encoded, allength, speccount);
buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
- /* Simulate FSF Emacs: if point was in the region, place it at the
- beginning. */
+ /* Simulate FSF Emacs implementation of this function: if point was
+ in the region, place it at the beginning. */
if (old_pt >= begv && old_pt < zv)
BUF_SET_PT (buf, begv);
return make_int (encoded_length);
}
-DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 1, 0, /*
+DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
Base64 encode STRING and return the result.
*/
- (string))
+ (string, no_line_break))
{
Charcount allength, length;
Bytind encoded_length;
Bufbyte *encoded;
Lisp_Object input, result;
- int speccount;
+ int speccount = specpdl_depth();
CHECK_STRING (string);
length = XSTRING_CHAR_LENGTH (string);
- allength = length + length/3 + 1 + 6;
+ 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, 0);
+ 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);
+ XMALLOC_UNBIND (encoded, allength, speccount);
return result;
}
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))
{
Bytind decoded_length;
Charcount length, cc_decoded_length;
Lisp_Object input;
- int speccount;
+ 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);
abort ();
Lstream_delete (XLSTREAM (input));
- if (decoded_length < 0)
- {
- /* The decoding wasn't possible. */
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
- return Qnil;
- }
-
/* Now we have decoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
BUF_SET_PT (buf, begv);
buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
+ XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
buffer_delete_range (buf, begv + cc_decoded_length,
zv + cc_decoded_length, 0);
- /* Simulate FSF Emacs: if point was in the region, place it at the
- beginning. */
+ /* Simulate FSF Emacs implementation of this function: if point was
+ in the region, place it at the beginning. */
if (old_pt >= begv && old_pt < zv)
BUF_SET_PT (buf, begv);
DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
Base64-decode STRING and return the result.
+Characters out of the base64 alphabet are ignored.
*/
(string))
{
Bytind decoded_length;
Charcount length, cc_decoded_length;
Lisp_Object input, result;
- int speccount;
+ int speccount = specpdl_depth();
CHECK_STRING (string);
abort ();
Lstream_delete (XLSTREAM (input));
- if (decoded_length < 0)
- {
- return Qnil;
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
- }
-
result = make_string (decoded, decoded_length);
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
+ XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
return result;
}
\f
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);
Used by `featurep' and `require', and altered by `provide'.
*/ );
Vfeatures = Qnil;
+
+ Fprovide (intern ("base64"));
}