xemacs-beta: src/fns.c comparison

comparison src/fns.c @ 380:8626e4521993 r21-2-5

Import from CVS: tag r21-2-5

author	cvs
date	Mon, 13 Aug 2007 11:07:10 +0200
parents	d883f39b8495
children	bbff43aa5eb7

comparison

equal deleted inserted replaced

-:76b7d63099ad
+:8626e4521993
 #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"
 if (last != len)
 write_c_string ("...", printcharfun);
 }
 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 *v1 = XBIT_VECTOR (obj1);
-struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2);
+struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
 	  !memcmp (v1->bits, v2->bits,
 		   BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
 		   sizeof (long)));
 {
 if (!COMPILED_FUNCTIONP (seq))
 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 :
+return (f->flags.interactivep ? COMPILED_INTERACTIVE :
-	      b->flags.domainp      ? COMPILED_DOMAIN :
+	      f->flags.domainp      ? COMPILED_DOMAIN :
 	      COMPILED_DOC_STRING)
 	+ 1;
 }
 }
 retry:
 if (STRINGP (sequence))
 return make_int (XSTRING_CHAR_LENGTH (sequence));
 else if (CONSP (sequence))
 {
-Lisp_Object tail;
+int len;
-int i = 0;
+GET_EXTERNAL_LIST_LENGTH (sequence, len);
+return make_int (len);
-EXTERNAL_LIST_LOOP (tail, sequence)
-	{
-	  QUIT;
-	  i++;
-	}
-return make_int (i);
 }
 else if (VECTORP (sequence))
 return make_int (XVECTOR_LENGTH (sequence));
 else if (NILP (sequence))
 return Qzero;
 sequence = wrong_type_argument (Qsequencep, sequence);
 goto retry;
 }
 }
-/* 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,
 it returns 0.  If LIST is circular, it returns a finite value
 which is at least the number of distinct elements.
 */
 (list))
 {
-Lisp_Object halftail = list; /* Used to detect circular lists. */
+Lisp_Object hare, tortoise;
-Lisp_Object tail;
+int len;
-int len = 0;
+for (hare = tortoise = list, len = 0;
-for (tail = list; CONSP (tail); tail = XCDR (tail))
+CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
-{
+hare = XCDR (hare), len++)
-if (EQ (tail, halftail) && len != 0)
+{
-	break;
+if (len & 1)
-len++;
+	tortoise = XCDR (tortoise);
-if ((len & 1) == 0)
-	halftail = XCDR (halftail);
 }
 return make_int (len);
 }
 (int nargs, Lisp_Object *args))
 {
 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;
+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.
+*/
+(list))
+{
+again:
+if (NILP  (list)) return list;
+if (CONSP (list)) return copy_list (list);
+list = wrong_type_argument (Qlistp, list);
+goto again;
+}
 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
-Return a copy of a list, vector, bit vector or string.
+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.
+with the original. SEQUENCE may be a dotted list.
 */
-(arg))
+(sequence))
 {
 again:
-if (NILP (arg)) return arg;
+if (NILP        (sequence)) return sequence;
-/* We handle conses separately because concat() is big and hairy and
+if (CONSP       (sequence)) return copy_list (sequence);
-doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this
+if (STRINGP     (sequence)) return concat (1, &sequence, c_string,     0);
-than to fix concat() without worrying about breaking other things.
+if (VECTORP     (sequence)) return concat (1, &sequence, c_vector,     0);
-*/
+if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
-if (CONSP (arg))
-{
+check_losing_bytecode ("copy-sequence", sequence);
-Lisp_Object head = Fcons (XCAR (arg), XCDR (arg));
+sequence = wrong_type_argument (Qsequencep, sequence);
-Lisp_Object tail = head;
-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);
-check_losing_bytecode ("copy-sequence", arg);
-arg = wrong_type_argument (Qsequencep, arg);
 goto again;
 }
 struct merge_string_extents_struct
 {
 Charcount ccfr, ccto;
 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);
 bto = charcount_to_bytecount (XSTRING_DATA (string), ccto);
 #else
 /* This is The Way Mly and Cltl2 say It Should Be. */
 args_out_of_range (sequence, n);
 #endif
 }
-else if (STRINGP (sequence)
+else if (STRINGP     (sequence) ||
-|| VECTORP (sequence)
+VECTORP     (sequence) ||
-|| BIT_VECTORP (sequence))
+BIT_VECTORP (sequence))
 return Faref (sequence, n);
 #ifdef LOSING_BYTECODE
 else if (COMPILED_FUNCTIONP (sequence))
 {
 int idx = XINT (n);
 lose:
 args_out_of_range (sequence, n);
 }
 /* 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;
+return compiled_function_arglist (f);
-case COMPILED_BYTECODE:
+case COMPILED_INSTRUCTIONS:
-return b->bytecodes;
+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)
+	    if (f->flags.interactivep)
-	      return compiled_function_interactive (b);
+	      return compiled_function_interactive (f);
 	    /* if we return nil, can't tell interactive with no args
 	       from noninteractive. */
 	    goto lose;
 default:
 goto lose;
 sequence = wrong_type_argument (Qsequencep, sequence);
 goto retry;
 }
 }
+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;
+Lisp_Object list_elt, tail;
-LIST_LOOP (tail, list)
+EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
 {
-CONCHECK_CONS (tail);
+if (internal_equal (elt, list_elt, 0))
-if (internal_equal (elt, XCAR (tail), 0))
 return tail;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
 This function is provided only for byte-code compatibility with v19.
 Do not use it.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object list_elt, tail;
-LIST_LOOP (tail, list)
+EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
 {
-CONCHECK_CONS (tail);
+if (internal_old_equal (elt, list_elt, 0))
-if (internal_old_equal (elt, XCAR (tail), 0))
 return tail;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("memq", Fmemq, 2, 2, 0, /*
 Return non-nil if ELT is an element of LIST.  Comparison done with `eq'.
 The value is actually the tail of LIST whose car is ELT.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object list_elt, tail;
-LIST_LOOP (tail, list)
+EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
 {
-REGISTER Lisp_Object tem;
+if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
-CONCHECK_CONS (tail);
-if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
 return tail;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
 This function is provided only for byte-code compatibility with v19.
 Do not use it.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object list_elt, tail;
-LIST_LOOP (tail, list)
+EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
 {
-REGISTER Lisp_Object tem;
+if (HACKEQ_UNSAFE (elt, list_elt))
-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)
 {
-REGISTER Lisp_Object tail;
+Lisp_Object list_elt, tail;
-for (tail = list; CONSP (tail); tail = XCDR (tail))
+LIST_LOOP_3 (list_elt, list, tail)
 {
-REGISTER Lisp_Object tem;
+if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
-if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
 return tail;
 }
 return Qnil;
 }
 The value is actually the element of LIST whose car equals KEY.
 */
 (key, list))
 {
 /* This function can GC. */
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt;
+if (internal_equal (key, elt_car, 0))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && internal_equal (XCAR (elt), key, 0))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
 The value is actually the element of LIST whose car equals KEY.
 */
 (key, list))
 {
 /* This function can GC. */
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt;
+if (internal_old_equal (key, elt_car, 0))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 Lisp_Object
 The value is actually the element of LIST whose car is KEY.
 Elements of LIST that are not conses are ignored.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt, tem;
+if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
 This function is provided only for byte-code compatibility with v19.
 Do not use it.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt, tem;
+if (HACKEQ_UNSAFE (key, elt_car))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem)))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 /* Like Fassq but never report an error and do not allow quits.
 Lisp_Object
 assq_no_quit (Lisp_Object key, Lisp_Object list)
 {
 /* This cannot GC. */
-REGISTER Lisp_Object tail;
+Lisp_Object elt;
-for (tail = list; CONSP (tail); tail = XCDR (tail))
+LIST_LOOP_2 (elt, list)
 {
-REGISTER Lisp_Object tem, elt;
+Lisp_Object elt_car = XCAR (elt);
-elt = XCAR (tail);
+if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
-if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+	return elt;
-	  return elt;
 }
 return Qnil;
 }
 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
 The value is actually the element of LIST whose cdr equals KEY.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt;
+if (internal_equal (key, elt_cdr, 0))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && internal_equal (XCDR (elt), key, 0))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
 The value is actually the element of LIST whose cdr equals KEY.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt;
+if (internal_old_equal (key, elt_cdr, 0))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("rassq", Frassq, 2, 2, 0, /*
 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
 The value is actually the element of LIST whose cdr is KEY.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt, tem;
+if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
-CONCHECK_CONS (tail);
-elt = XCAR (tail);
-if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
 	return elt;
-QUIT;
 }
 return Qnil;
 }
 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
 The value is actually the element of LIST whose cdr is KEY.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt, elt_car, elt_cdr;
-LIST_LOOP (tail, list)
+EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
 {
-REGISTER Lisp_Object elt, tem;
+if (HACKEQ_UNSAFE (key, elt_cdr))
-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)
 {
-REGISTER Lisp_Object tail;
+Lisp_Object elt;
-for (tail = list; CONSP (tail); tail = XCDR (tail))
+LIST_LOOP_2 (elt, list)
 {
-REGISTER Lisp_Object elt, tem;
+Lisp_Object elt_cdr = XCDR (elt);
-elt = XCAR (tail);
+if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
-if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
 	return elt;
 }
 return Qnil;
 }
 of changing the value of `foo'.
 Also see: `remove'.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object list_elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+				(internal_equal (elt, list_elt, 0)));
-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;
 }
 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
 Delete by side effect any occurrences of ELT as a member of LIST.
 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
 of changing the value of `foo'.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object list_elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+				(internal_old_equal (elt, list_elt, 0)));
-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;
 }
 DEFUN ("delq", Fdelq, 2, 2, 0, /*
 Delete by side effect any occurrences of ELT as a member of LIST.
 effect; therefore, write `(setq foo (delq element foo))' to be sure of
 changing the value of `foo'.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object list_elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+				(EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
-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;
 }
 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
 Delete by side effect any occurrences of ELT as a member of LIST.
 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
 changing the value of `foo'.
 */
 (elt, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object list_elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+				(HACKEQ_UNSAFE (elt, list_elt)));
-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;
 }
-/* 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;
+Lisp_Object list_elt;
-REGISTER Lisp_Object prev = Qnil;
+LIST_LOOP_DELETE_IF (list_elt, list,
+		       (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
-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;
 }
 /* Be VERY careful with this.  This is like delq_no_quit() but
 also calls free_cons() on the removed conses.  You must be SURE
 Lisp_Object
 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object 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);
-REGISTER Lisp_Object tem;
+if (EQ (elt, 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);
-	  cons_to_free = XCONS (tail);
+	  tail = XCDR (tail);
+	  free_cons (XCONS (cons_to_free));
 	}
 else
-	prev = tail;
+	{
-tail = XCDR (tail);
+	  prev = tail;
-if (cons_to_free)
+	  tail = XCDR (tail);
-	{
-	  free_cons (cons_to_free);
-	  cons_to_free = NULL;
 	}
 }
 return list;
 }
 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
 the value of `foo'.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+				(CONSP (elt) &&
-while (!NILP (tail))
+				 internal_equal (key, XCAR (elt), 0)));
-{
-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;
 }
 Lisp_Object
 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
 therefore, write `(setq foo (remassq key foo))' to be sure of changing
 the value of `foo'.
 */
 (key, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+				(CONSP (elt) &&
-while (!NILP (tail))
+				 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
-{
-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;
 }
 /* no quit, no errors; be careful */
 Lisp_Object
 remassq_no_quit (Lisp_Object key, Lisp_Object list)
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object elt;
-REGISTER Lisp_Object prev = Qnil;
+LIST_LOOP_DELETE_IF (elt, list,
+		       (CONSP (elt) &&
-while (CONSP (tail))
+			EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
-{
-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.
 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
 the value of `foo'.
 */
 (value, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+				(CONSP (elt) &&
-while (!NILP (tail))
+				 internal_equal (value, XCDR (elt), 0)));
-{
-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;
 }
 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
 the value of `foo'.
 */
 (value, list))
 {
-REGISTER Lisp_Object tail = list;
+Lisp_Object elt;
-REGISTER Lisp_Object prev = Qnil;
+EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+				(CONSP (elt) &&
-while (!NILP (tail))
+				 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
-{
-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;
-}
 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;
+Lisp_Object elt;
-REGISTER Lisp_Object prev = Qnil;
+LIST_LOOP_DELETE_IF (elt, list,
+		       (CONSP (elt) &&
-while (CONSP (tail))
+			EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
-{
-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);
-}
 return list;
 }
 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
 Reverse LIST by destructively modifying cdr pointers.
 /* We gcpro our args; see `nconc' */
 GCPRO2 (prev, tail);
 while (!NILP (tail))
 {
 REGISTER Lisp_Object next;
-QUIT;
 CONCHECK_CONS (tail);
 next = XCDR (tail);
 XCDR (tail) = prev;
 prev = tail;
 tail = next;
 Reverse LIST, copying.  Return the beginning of the reversed list.
 See also the function `nreverse', which is used more often.
 */
 (list))
 {
-REGISTER Lisp_Object tail;
+Lisp_Object reversed_list = Qnil;
-Lisp_Object new = Qnil;
+Lisp_Object elt;
+EXTERNAL_LIST_LOOP_2 (elt, list)
-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;
 }
 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
 Lisp_Object lisp_arg,
 int (*pred_fn) (Lisp_Object, Lisp_Object,
 */
 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 (XCAR (tail), property))
-if (EQ (c->car, property))
+	return XCAR (XCDR (tail));
-	return XCAR (c->cdr);
 }
 return Qunbound;
 }
 }
 int
 internal_remprop (Lisp_Object *plist, Lisp_Object property)
 {
-Lisp_Object tail = *plist;
+Lisp_Object tail, prev;
-if (NILP (tail))
+for (tail = *plist, prev = Qnil;
-return 0;
+!NILP (tail);
-if (EQ (XCAR (tail), property))
-{
-*plist = XCDR (XCDR (tail));
-return 1;
-}
-for (tail = XCDR (tail); !NILP (XCDR (tail));
 tail = XCDR (XCDR (tail)))
 {
-struct Lisp_Cons *c = XCONS (tail);
+if (EQ (XCAR (tail), property))
-if (EQ (XCAR (c->cdr), property))
+	{
-	{
+	  if (NILP (prev))
-	  c->cdr = XCDR (XCDR (c->cdr));
+	    *plist = XCDR (XCDR (tail));
+	  else
+	    XCDR (XCDR (prev)) = XCDR (XCDR (tail));
 	  return 1;
 	}
+else
+	prev = tail;
 }
 return 0;
 }
 {
 int i;
 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++)
 {
 /* This is a standard iteration of a defensive-loop-checking
 one of the properties on the list.
 */
 (plist, prop, default_))
 {
 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
-if (UNBOUNDP (val))
+return UNBOUNDP (val) ? default_ : val;
-return default_;
-return val;
 }
 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
 Change value in PLIST of PROP to VAL.
 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
 Return t if PROP has a value specified in PLIST.
 */
 (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, /*
 Given a plist, signal an error if there is anything wrong with it.
 This means that it's a malformed or circular plist.
 	  continue;
 	}
 /* 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);
 }
 return head;
 }
 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
 Extract a value from a lax property list.
 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where 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.
 */
 (lax_plist, prop, default_))
 }
 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
 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
 use the new value.  The LAX-PLIST is modified by side effects.
 }
 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.
 */
 (lax_plist, prop))
 }
 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))
 {
 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
 	  continue;
 	}
 /* 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);
 }
 return head;
 }
 \(which defaults to `nil').  OBJECT can be a symbol, face, extent,
 or string.  See also `put', `remprop', and `object-plist'.
 */
 (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
+CONST struct lrecord_implementation *imp
-	*imp = XRECORD_LHEADER_IMPLEMENTATION (object);
+	= XRECORD_LHEADER_IMPLEMENTATION (object);
-if (imp->getprop)
+if (!imp->getprop)
-	{
-	  val = (imp->getprop) (object, propname);
-	  if (UNBOUNDP (val))
-	    val = default_;
-	}
-else
 	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, /*
 Store OBJECT's PROPNAME property with value VALUE.
 It can be retrieved with `(get OBJECT PROPNAME)'.  OBJECT can be a
 return Qnil;
 }
 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 (CONSP (obj1))
 {
-if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
+if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1))
 return 0;
-o1 = XCDR (o1);
+obj1 = XCDR (obj1);
-o2 = XCDR (o2);
+obj2 = XCDR (obj2);
 goto do_cdr;
 }
 #endif
 #ifndef LRECORD_VECTOR
-else if (VECTORP (o1))
+if (VECTORP (obj1))
 {
-Lisp_Object *v1 = XVECTOR_DATA (o1);
+Lisp_Object *v1 = XVECTOR_DATA (obj1);
-Lisp_Object *v2 = XVECTOR_DATA (o2);
+Lisp_Object *v2 = XVECTOR_DATA (obj2);
-int len = XVECTOR_LENGTH (o1);
+int len = XVECTOR_LENGTH (obj1);
-if (len != XVECTOR_LENGTH (o2))
+if (len != XVECTOR_LENGTH (obj2))
 	return 0;
 while (len--)
 	if (!internal_equal (*v1++, *v2++, depth + 1))
 	  return 0;
 return 1;
 }
 #endif
 #ifndef LRECORD_STRING
-else if (STRINGP (o1))
+if (STRINGP (obj1))
 {
 Bytecount len;
-return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
+return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
-	      !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
+	      !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
 }
 #endif
-else if (LRECORDP (o1))
+if (LRECORDP (obj1))
 {
 CONST struct lrecord_implementation
-	*imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
+	*imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
-	*imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
+	*imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
-if (imp1 != imp2)
-	return 0;
+return (imp1 == imp2) &&
-else if (imp1->equal == 0)
 	/* EQ-ness of the objects was noticed above */
-	return 0;
+	(imp1->equal && (imp1->equal) (obj1, obj2, depth));
-else
-	return (imp1->equal) (o1, o2, depth);
 }
 return 0;
 }
 internal_equal() (instead of internal_old_equal()).  Oh well.
 We will get an Ebola note if there's any possibility of confusion,
 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 (CONSP (obj1))
 {
-if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1))
+if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1))
 return 0;
-o1 = XCDR (o1);
+obj1 = XCDR (obj1);
-o2 = XCDR (o2);
+obj2 = XCDR (obj2);
 goto do_cdr;
 }
 #endif
 #ifndef LRECORD_VECTOR
-else if (VECTORP (o1))
+if (VECTORP (obj1))
 {
-int indice;
+Lisp_Object *v1 = XVECTOR_DATA (obj1);
-int len = XVECTOR_LENGTH (o1);
+Lisp_Object *v2 = XVECTOR_DATA (obj2);
-if (len != XVECTOR_LENGTH (o2))
+int len = XVECTOR_LENGTH (obj1);
+if (len != XVECTOR_LENGTH (obj2))
 	return 0;
-for (indice = 0; indice < len; indice++)
+while (len--)
-	{
+	if (!internal_old_equal (*v1++, *v2++, depth + 1))
-	  if (!internal_old_equal (XVECTOR_DATA (o1) [indice],
+	  return 0;
-				   XVECTOR_DATA (o2) [indice],
-				   depth + 1))
-return 0;
-	}
 return 1;
 }
 #endif
-#ifndef LRECORD_STRING
-else if (STRINGP (o1))
+return internal_equal (obj1, obj2, depth);
-{
-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;
 }
 DEFUN ("equal", Fequal, 2, 2, 0, /*
 Return t if two Lisp objects have similar structure and contents.
 They must have the same data type.
 Conses are compared by comparing the cars and the cdrs.
 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, /*
 Return t if two Lisp objects have similar structure and contents.
 They must have the same data type.
 this is known as the "char-int confoundance disease." See `eq' and
 `old-eq'.)
 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;
 }
 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
 Store each element of ARRAY with ITEM.
 }
 return array;
 }
 Lisp_Object
-nconc2 (Lisp_Object s1, Lisp_Object s2)
+nconc2 (Lisp_Object arg1, Lisp_Object arg2)
 {
 Lisp_Object args[2];
-args[0] = s1;
+struct gcpro gcpro1;
-args[1] = s2;
+args[0] = arg1;
-return Fnconc (2, args);
+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, /*
 Concatenate any number of lists by altering them.
 Only the last argument is not altered, and need not be a list.
 while (argnum < nargs)
 {
 Lisp_Object val = args[argnum];
 if (CONSP (val))
 	{
-	  /* Found the first cons, which will be our return value.  */
+	  /* `val' is the first cons, which will be our return value.  */
-	  Lisp_Object last = val;
+	  /* `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:
 	      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);
+		      if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
-		      QUIT;
+		      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))
 		{
 		  continue;
 		}
 	      else
 		{
 		  next = wrong_type_argument (next, Qlistp);
-		  goto redo;
+		  goto retry;
 		}
 	    }
 	  RETURN_UNGCPRO (val);
 }
 else if (NILP (val))
 /* 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 {			\
-if ((len) > MAX_ALLOCA)					\
+size_t XOA_len = (len);					\
+if (XOA_len > MAX_ALLOCA)					\
 {								\
-ptr = (type *)xmalloc ((len) * sizeof (type));		\
+ptr = xnew_array (type, XOA_len);				\
-speccount = specpdl_depth ();				\
 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 {		\
+#define XMALLOC_UNBIND(ptr, len, speccount) do {		\
-if ((len) > MAX_ALLOCA)			\
+if ((len) > MAX_ALLOCA)					\
-unbind_to (speccount, Qnil);		\
+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.
 Bytind encoded_length;
 Charcount allength, length;
 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
 characters, and then we round up. */
 length = zv - begv;
 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);
+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.  */
 if (old_pt >= begv && old_pt < zv)
 {
 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;
 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, 0);
 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;
 }
 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
 Base64-decode the region between BEG and END.
 Bufpos begv, zv, old_pt = BUF_PT (buf);
 Bufbyte *decoded;
 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);
 /* We need to allocate enough room for decoding the text. */
 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
 Lstream_delete (XLSTREAM (input));
 if (decoded_length < 0)
 {
 /* The decoding wasn't possible. */
-XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
+XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
 return Qnil;
 }
 /* Now we have decoded the region, so we insert the new contents
 and delete the old.  (Insert first in order to preserve markers.)  */
 BUF_SET_PT (buf, begv);
 buffer_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.  */
 {
 Bufbyte *decoded;
 Bytind decoded_length;
 Charcount length, cc_decoded_length;
 Lisp_Object input, result;
-int speccount;
+int speccount = specpdl_depth();
 CHECK_STRING (string);
 length = XSTRING_CHAR_LENGTH (string);
 /* We need to allocate enough room for decoding the text. */
 abort ();
 Lstream_delete (XLSTREAM (input));
 if (decoded_length < 0)
 {
+/* The decoding wasn't possible. */
+XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
 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;
 }
 Lisp_Object Qyes_or_no_p;
 DEFSUBR (Fstring_modified_tick);
 DEFSUBR (Fappend);
 DEFSUBR (Fconcat);
 DEFSUBR (Fvconcat);
 DEFSUBR (Fbvconcat);
+DEFSUBR (Fcopy_list);
 DEFSUBR (Fcopy_sequence);
 DEFSUBR (Fcopy_alist);
 DEFSUBR (Fcopy_tree);
 DEFSUBR (Fsubstring);
 DEFSUBR (Fsubseq);
 DEFSUBR (Fnthcdr);
 DEFSUBR (Fnth);
 DEFSUBR (Felt);
+DEFSUBR (Flast);
+DEFSUBR (Fbutlast);
+DEFSUBR (Fnbutlast);
 DEFSUBR (Fmember);
 DEFSUBR (Fold_member);
 DEFSUBR (Fmemq);
 DEFSUBR (Fold_memq);
 DEFSUBR (Fassoc);

Mercurial > hg > xemacs-beta

comparison src/fns.c @ 380:8626e4521993 r21-2-5