xemacs-beta: src/fns.c comparison

comparison src/fns.c @ 5253:b6a398dbb403

Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist() src/ChangeLog addition: 2010-09-01 Aidan Kehoe <kehoea@parhasard.net> * fns.c (list_merge, list_array_merge_into_list) (list_array_merge_into_array): Avoid algorithmic complexity surprises when checking for circularity in these functions. (Freduce): Fix some formatting, in passing. (mapcarX): Drop the SOME_OR_EVERY argument to this function; instead, take CALLER, a symbol reflecting the Lisp-visible function that called mapcarX(). Use CALLER with mapping_interaction_error() when sequences are modified illegally. Don't cons with #'some, #'every, not even a little. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into, Fsome, Fevery): Call mapcarX() with its new arguments. (Fmapcan): Don't unnecessarily complicate the nconc call. (maplist): Take CALLER, a symbol reflecting the Lisp-visible function that called maplist(), rather than having separate arguments to indicate mapl vs. mapcon. Avoid algorithmic complexity surprises when checking for circularity. In #'mapcon, check a given stretch of result for well-formedness once, which was not previously the case, despite what the comments said. (Fmaplist, Fmapl, Fmapcon): Call maplist() with its new arguments.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Wed, 01 Sep 2010 12:51:32 +0100
parents	d579d76f3dcc
children	b5611afbcc76

comparison

equal deleted inserted replaced

-:378a34562cbe
+:b6a398dbb403
 /* NOTE: This symbol is also used in lread.c */
 #define FEATUREP_SYNTAX
 Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill;
 Lisp_Object Qidentity;
-Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Qreduce, Q_from_end, Q_initial_value;
+Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value;
+Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into;
+Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce;
 Lisp_Object Qbase64_conversion_error;
 Lisp_Object Vpath_separator;
 {
 Lisp_Object value;
 Lisp_Object tail;
 Lisp_Object tem;
 Lisp_Object l1, l2;
-struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
+Lisp_Object tortoises[2];
+struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 int looped = 0;
 l1 = org_l1;
 l2 = org_l2;
 tail = Qnil;
 value = Qnil;
+tortoises[0] = org_l1;
+tortoises[1] = org_l2;
 if (NULL == c_predicate)
 {
 c_predicate = EQ (key_func, Qidentity) ?
 c_merge_predicate_nokey : c_merge_predicate_key;
 /* It is sufficient to protect org_l1 and org_l2.
 When l1 and l2 are updated, we copy the new values
 back into the org_ vars.  */
-GCPRO4 (org_l1, org_l2, predicate, value);
+GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
+gcpro5.nvars = 2;
 while (1)
 {
 if (NILP (l1))
 	{
 	value = tem;
 else
 	Fsetcdr (tail, tem);
 tail = tem;
-if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
+{
-/* Just check the lists aren't circular:*/
+if (looped & 1)
 {
-EXTERNAL_LIST_LOOP_1 (l1)
+tortoises[0] = XCDR (tortoises[0]);
-{
+tortoises[1] = XCDR (tortoises[1]);
 }
-}
-{
+if (EQ (org_l1, tortoises[0]))
-EXTERNAL_LIST_LOOP_1 (l2)
+{
-{
+signal_circular_list_error (org_l1);
 }
-}
+if (EQ (org_l2, tortoises[1]))
+{
+signal_circular_list_error (org_l2);
+}
+}
 }
 }
 static void
 array_merge (Lisp_Object *dest, Elemcount dest_len,
 Lisp_Object,
 Lisp_Object),
 Lisp_Object predicate, Lisp_Object key_func,
 Boolint reverse_order)
 {
-Lisp_Object tail = Qnil, value = Qnil;
+Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
-struct gcpro gcpro1, gcpro2, gcpro3;
+struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 Elemcount array_index = 0;
 int looped = 0;
-GCPRO3 (list, tail, value);
+GCPRO4 (list, tail, value, tortoise);
 while (1)
 {
 if (NILP (list))
 {
 tail = XCDR (tail);
 }
 ++array_index;
 }
-if (++looped % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
+{
-{
+if (looped & 1)
-EXTERNAL_LIST_LOOP_1 (list)
+{
-{
+tortoise = XCDR (tortoise);
 }
-}
+if (EQ (list, tortoise))
+{
+signal_circular_list_error (list);
+}
+}
 }
 }
 static void
 list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
 {
 if (NILP (list))
 {
 if (array_len - array_index != output_len - output_index)
 {
-invalid_state ("List length modified during merge", Qunbound);
+	      mapping_interaction_error (Qmerge, list);
 }
 while (array_index < array_len)
 {
 output [output_index++] = array [array_index++];
 If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons,
 mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them,
 so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off
 mapcarX.
-Otherwise, mapcarX signals a wrong-type-error if it encounters a
+Otherwise, mapcarX signals an invalid state error (see
-non-cons, non-array when traversing SEQUENCES.  Common Lisp specifies in
+mapping_interaction_error(), above) if it encounters a non-cons,
+non-array when traversing SEQUENCES.  Common Lisp specifies in
 MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION
 destructively modifies SEQUENCES in a way that might affect the ongoing
 traversal operation.
-If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple)
+CALLER is a symbol describing the Lisp-visible function that was called,
-values given by FUNCTION the first time it is non-nil, and abandon the
+and any errors thrown because SEQUENCES was modified will reflect it.
-iterations.  LISP_VALS must be a cons, and the return value will be
-stored in its car.  If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil
+If CALLER is Qsome, return the (possibly multiple) values given by
-in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it
+FUNCTION the first time it is non-nil, and abandon the iterations.
-alone. */
+LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address
+of a Lisp object, and the return value will be stored at that address.
-#define SOME_OR_EVERY_NEITHER 0
+If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp
-#define SOME_OR_EVERY_SOME    1
+object, and Qnil will be stored at that address if FUNCTION gives nil;
-#define SOME_OR_EVERY_EVERY   2
+otherwise it will be left alone. */
 static void
 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals,
 	 Lisp_Object function, int nsequences, Lisp_Object *sequences,
-	 int some_or_every)
+	 Lisp_Object caller)
 {
 Lisp_Object called, *args;
 struct gcpro gcpro1, gcpro2;
 int i, j;
-enum lrecord_type lisp_vals_type;
+assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1);
-assert (LRECORDP (lisp_vals));
-lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
 args = alloca_array (Lisp_Object, nsequences + 1);
 args[0] = function;
 for (i = 1; i <= nsequences; ++i)
 {
 	  vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args));
 	}
 }
 else
 {
+enum lrecord_type lisp_vals_type;
 Binbyte *sequence_types = alloca_array (Binbyte, nsequences);
 for (j = 0; j < nsequences; ++j)
 	{
 	  sequence_types[j] = XRECORD_LHEADER (sequences[j])->type;
 	}
+if (!EQ (caller, Qsome) && !EQ (caller, Qevery))
+{
+assert (LRECORDP (lisp_vals));
+lisp_vals_type
+= (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
+assert (NILP (lisp_vals) || lisp_vals_type != lrecord_type_symbol);
+}
 for (i = 0; i < call_count; ++i)
 	{
 	  for (j = 0; j < nsequences; ++j)
 	    {
 		{
 		case lrecord_type_cons:
 		  {
 		    if (!CONSP (sequences[j]))
 		      {
-			/* This means FUNCTION has probably messed
+			/* This means FUNCTION has messed around with a cons
-			   around with a cons in one of the sequences,
+			   in one of the sequences, since we checked the
-			   since we checked the type
+			   type (CHECK_SEQUENCE()) and the length and
-			   (CHECK_SEQUENCE()) and the length and
 			   structure (with Flength()) correctly in our
 			   callers. */
-			dead_wrong_type_argument (Qconsp, sequences[j]);
+mapping_interaction_error (caller, sequences[j]);
 		      }
 		    args[j + 1] = XCAR (sequences[j]);
 		    sequences[j] = XCDR (sequences[j]);
 		    break;
 		  }
 	  if (vals != NULL)
 	    {
 	      vals[i] = IGNORE_MULTIPLE_VALUES (called);
 	      gcpro2.nvars += 1;
 	    }
-	  else
+else if (EQ (Qsome, caller))
-	    {
+{
-	      switch (lisp_vals_type)
+if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
-		{
+{
-		case lrecord_type_symbol:
+Lisp_Object *result
-		  break;
+= (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals);
-		case lrecord_type_cons:
+*result = called;
-		  {
+UNGCPRO;
-		    if (SOME_OR_EVERY_NEITHER == some_or_every)
+return;
-		      {
+}
-			called = IGNORE_MULTIPLE_VALUES (called);
+}
-			if (!CONSP (lisp_vals))
+else if (EQ (Qevery, caller))
-			  {
+{
-			    /* If FUNCTION has inserted a non-cons non-nil
+	      if (NILP (IGNORE_MULTIPLE_VALUES (called)))
-			       cdr into the list before we've processed the
+{
-			       relevant part, error. */
+Lisp_Object *result
-			    dead_wrong_type_argument (Qconsp, lisp_vals);
+= (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals);
-			  }
+*result = Qnil;
+UNGCPRO;
-			XSETCAR (lisp_vals, called);
+return;
-			lisp_vals = XCDR (lisp_vals);
+}
-			break;
+}
-		      }
+else
+{
-		    if (SOME_OR_EVERY_SOME == some_or_every)
+called = IGNORE_MULTIPLE_VALUES (called);
-		      {
+switch (lisp_vals_type)
-			if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
+{
-			  {
+case lrecord_type_symbol:
-			    XCAR (lisp_vals) = called;
+		  /* This is #'mapc; the result of the funcall is
-			    UNGCPRO;
+		     discarded. */
-			    return;
+break;
-			  }
+case lrecord_type_cons:
-			break;
+{
-		      }
+if (!CONSP (lisp_vals))
+{
-		    if (SOME_OR_EVERY_EVERY == some_or_every)
+/* If FUNCTION has inserted a non-cons non-nil
-		      {
+cdr into the list before we've processed the
-			called = IGNORE_MULTIPLE_VALUES (called);
+relevant part, error. */
-			if (NILP (called))
+mapping_interaction_error (caller, lisp_vals);
-			  {
+}
-			    XCAR (lisp_vals) = Qnil;
+XSETCAR (lisp_vals, called);
-			    UNGCPRO;
+lisp_vals = XCDR (lisp_vals);
-			    return;
+break;
-			  }
+}
-			break;
+case lrecord_type_vector:
-		      }
+{
+i < XVECTOR_LENGTH (lisp_vals) ?
-		    goto bad_some_or_every_flag;
+(XVECTOR_DATA (lisp_vals)[i] = called) :
-		  }
+/* Let #'aset error. */
-		case lrecord_type_vector:
+Faset (lisp_vals, make_int (i), called);
-		  {
+break;
-		    called = IGNORE_MULTIPLE_VALUES (called);
+}
-		    i < XVECTOR_LENGTH (lisp_vals) ?
+case lrecord_type_string:
-		      (XVECTOR_DATA (lisp_vals)[i] = called) :
+{
-		      /* Let #'aset error. */
+/* If this ever becomes a code hotspot, we can keep
-		      Faset (lisp_vals, make_int (i), called);
+around pointers into the data of the string, checking
-		    break;
+each time that it hasn't been relocated. */
-		  }
+Faset (lisp_vals, make_int (i), called);
-		case lrecord_type_string:
+break;
-		  {
+}
-		    /* If this ever becomes a code hotspot, we can keep
+case lrecord_type_bit_vector:
-		       around pointers into the data of the string, checking
+{
-		       each time that it hasn't been relocated. */
+(BITP (called) &&
-		    called = IGNORE_MULTIPLE_VALUES (called);
+i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
-		    Faset (lisp_vals, make_int (i), called);
+set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
-		    break;
+XINT (called)) :
-		  }
+(void) Faset (lisp_vals, make_int (i), called);
-		case lrecord_type_bit_vector:
+break;
-		  {
+}
-		    called = IGNORE_MULTIPLE_VALUES (called);
+default:
-		    (BITP (called) &&
+{
-		     i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
+ABORT();
-		      set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
+break;
-					  XINT (called)) :
+}
-		      (void) Faset (lisp_vals, make_int (i), called);
+}
-		    break;
+}
-		  }
-		bad_some_or_every_flag:
-		default:
-		  {
-		    ABORT();
-		    break;
-		  }
-		}
-	    }
 	}
 }
 UNGCPRO;
 }
 	  sequence = XCDR (sequence);
 	}
 }
 else
 {
-mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
+mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat);
-	       SOME_OR_EVERY_NEITHER);
 }
 for (i = len - 1; i >= 0; i--)
 args0[i + i] = args0[i];
 CHECK_SEQUENCE (args[i]);
 len = min (len, XINT (Flength (args[i])));
 }
 args0 = alloca_array (Lisp_Object, len);
-mapcarX (len, args0, Qnil, function, nargs - 1, args + 1,
+mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX);
-	   SOME_OR_EVERY_NEITHER);
 return Flist ((int) len, args0);
 }
 DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /*
 result = make_vector (len, Qnil);
 GCPRO1 (result);
 /* Don't pass result as the lisp_object argument, we want mapcarX to protect
 a single list argument's elements from being garbage-collected. */
 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
-	   SOME_OR_EVERY_NEITHER);
+Qmapvector);
-UNGCPRO;
+RETURN_UNGCPRO (result);
-return result;
 }
 DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /*
 Call FUNCTION on each element of SEQUENCE; chain the results together.
 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
 */
 (int nargs, Lisp_Object *args))
 {
-Lisp_Object function = args[0], nconcing;
+Lisp_Object function = args[0], *result;
-Elemcount len = EMACS_INT_MAX;
+Elemcount result_len = EMACS_INT_MAX;
-Lisp_Object *args0;
-struct gcpro gcpro1;
 int i;
 for (i = 1; i < nargs; ++i)
 {
 CHECK_SEQUENCE (args[i]);
-len = min (len, XINT (Flength (args[i])));
+result_len = min (result_len, XINT (Flength (args[i])));
 }
-args0 = alloca_array (Lisp_Object, len + 1);
+result = alloca_array (Lisp_Object, result_len);
-mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1,
+mapcarX (result_len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
-	   SOME_OR_EVERY_NEITHER);
+/* #'nconc GCPROs its args in case of signals and error. */
-if (len < 2)
+return Fnconc (result_len, result);
-{
-return len ? args0[1] : Qnil;
-}
-/* bytecode_nconc2 can signal and return, we need to GCPRO the args, since
-mapcarX is no longer doing this for us. */
-args0[0] = Fcons (Qnil, Qnil);
-GCPRO1 (args0[0]);
-gcpro1.nvars = len + 1;
-for (i = 0; i < len; ++i)
-{
-nconcing = bytecode_nconc2 (args0 + i);
-args0[i + 1] = nconcing;
-}
-RETURN_UNGCPRO (XCDR (nconcing));
 }
 DEFUN ("mapc", Fmapc, 2, MANY, 0, /*
 Call FUNCTION on each element of SEQUENCE.
 /* We need to GCPRO sequence, because mapcarX will modify the
 elements of the args array handed to it, and this may involve
 elements of sequence getting garbage collected. */
 GCPRO1 (sequence);
-mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1,
+mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc);
-	   SOME_OR_EVERY_NEITHER);
 RETURN_UNGCPRO (sequence);
 }
 DEFUN ("map", Fmap, 3, MANY, 0, /*
 Map FUNCTION across one or more sequences, returning a sequence.
 if (!NILP (type))
 {
 args0 = alloca_array (Lisp_Object, len);
 }
-mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
+mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap);
-	   SOME_OR_EVERY_NEITHER);
 if (EQ (type, Qnil))
 {
 return result;
 }
 CHECK_SEQUENCE (args[i]);
 len = min (len, XINT (Flength (args[i])));
 }
 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
-	   SOME_OR_EVERY_NEITHER);
+Qmap_into);
 return result_sequence;
 }
 DEFUN ("some", Fsome, 2, MANY, 0, /*
 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
 */
 (int nargs, Lisp_Object *args))
 {
-Lisp_Object result_box = Fcons (Qnil, Qnil);
+Lisp_Object result = Qnil,
-struct gcpro gcpro1;
+result_ptr = STORE_VOID_IN_LISP ((void *) &result);
 Elemcount len = EMACS_INT_MAX;
 int i;
-GCPRO1 (result_box);
 for (i = 1; i < nargs; ++i)
 {
 CHECK_SEQUENCE (args[i]);
 len = min (len, XINT (Flength (args[i])));
 }
-mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1,
+mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome);
-	   SOME_OR_EVERY_SOME);
+return result;
-RETURN_UNGCPRO (XCAR (result_box));
 }
 DEFUN ("every", Fevery, 2, MANY, 0, /*
 Return true if PREDICATE is true of every element of SEQUENCE.
 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
 */
 (int nargs, Lisp_Object *args))
 {
-Lisp_Object result_box = Fcons (Qt, Qnil);
+Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result);
-struct gcpro gcpro1;
 Elemcount len = EMACS_INT_MAX;
 int i;
-GCPRO1 (result_box);
 for (i = 1; i < nargs; ++i)
 {
 CHECK_SEQUENCE (args[i]);
 len = min (len, XINT (Flength (args[i])));
 }
-mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1,
+mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery);
-	   SOME_OR_EVERY_EVERY);
+return result;
-RETURN_UNGCPRO (XCAR (result_box));
 }
 /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument
 corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]),
 until that #'nthcdr expression gives nil for some element of LISTS.
-If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return
+CALLER is a symbol reflecting the Lisp-visible function that was called,
-values from FUNCTION; if NCONCP is non-zero, nconc them together.
+and any errors thrown because SEQUENCES was modified will reflect it.
+If CALLER is Qmapl, return LISTS[0]. Otherwise, return a list of the
+return values from FUNCTION; if caller is Qmapcan, nconc them together.
 In contrast to mapcarX, we don't require our callers to check LISTS for
 well-formedness, we signal wrong-type-argument if it's not a list, or
 circular-list if it's circular. */
 static Lisp_Object
-maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp,
+maplist (Lisp_Object function, int nlists, Lisp_Object *lists,
-	 int nconcp)
+Lisp_Object caller)
 {
-Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled;
+Lisp_Object nconcing[2], accum = Qnil, *args, *tortoises, funcalled;
-Lisp_Object nconcing[2], accum = result, *args;
+Lisp_Object result = EQ (caller, Qmapl) ? lists[0] : Qnil;
-struct gcpro gcpro1, gcpro2, gcpro3;
+struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 int i, j, continuing = (nlists > 0), called_count = 0;
 args = alloca_array (Lisp_Object, nlists + 1);
 args[0] = function;
 for (i = 1; i <= nlists; ++i)
 {
 args[i] = Qnil;
 }
-if (nconcp)
+tortoises = alloca_array (Lisp_Object, nlists);
-{
+memcpy (tortoises, lists, nlists * sizeof (Lisp_Object));
-nconcing[0] = result;
+if (EQ (caller, Qmapcon))
+{
+nconcing[0] = Qnil;
 nconcing[1] = Qnil;
-GCPRO3 (args[0], nconcing[0], result);
+GCPRO4 (args[0], nconcing[0], tortoises[0], result);
 gcpro1.nvars = 1;
 gcpro2.nvars = 2;
+gcpro3.nvars = nlists;
 }
 else
 {
-GCPRO2 (args[0], result);
+GCPRO3 (args[0], tortoises[0], result);
 gcpro1.nvars = 1;
+gcpro2.nvars = nlists;
 }
 while (continuing)
 {
 for (j = 0; j < nlists; ++j)
 	      continuing = 0;
 	      break;
 	    }
 	  else
 	    {
-	      dead_wrong_type_argument (Qlistp, lists[j]);
+	      lists[j] = wrong_type_argument (Qlistp, lists[j]);
 	    }
 	}
 if (!continuing) break;
 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args));
-if (!maplp)
+if (EQ (caller, Qmapl))
 	{
-	  if (nconcp)
+DO_NOTHING;
-	    {
+}
-	      /* This order of calls means we check that each list is
+else if (EQ (caller, Qmapcon))
-		 well-formed once and once only. The last result does
+{
-		 not have to be a list. */
+nconcing[1] = funcalled;
-	      nconcing[1] = funcalled;
+accum = bytecode_nconc2 (nconcing);
-	      nconcing[0] = bytecode_nconc2 (nconcing);
+if (NILP (result))
-	    }
+{
-	  else
+result = accum;
-	    {
+}
-	      /* Add to the end, avoiding the need to call nreverse
+/* Only check a given stretch of result for well-formedness
-		 once we're done: */
+once: */
-	      XSETCDR (accum, Fcons (funcalled, Qnil));
+nconcing[0] = funcalled;
-	      accum = XCDR (accum);
+}
-	    }
+else if (NILP (accum))
+{
+accum = result = Fcons (funcalled, Qnil);
+}
+else
+{
+/* Add to the end, avoiding the need to call nreverse
+once we're done: */
+XSETCDR (accum, Fcons (funcalled, Qnil));
+accum = XCDR (accum);
 	}
-if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+if (++called_count > CIRCULAR_LIST_SUSPICION_LENGTH)
+{
-for (j = 0; j < nlists; ++j)
+if (called_count & 1)
-	{
+{
-	  EXTERNAL_LIST_LOOP_1 (lists[j])
+for (j = 0; j < nlists; ++j)
-	    {
+{
-	      /* Just check the lists aren't circular, using the
+tortoises[j] = XCDR (tortoises[j]);
-		 EXTERNAL_LIST_LOOP_1 macro. */
+if (EQ (lists[j], tortoises[j]))
-	    }
+{
-	}
+signal_circular_list_error (lists[j]);
 }
+}
-if (!maplp)
+}
-{
+else
-result = XCDR (result);
+{
+for (j = 0; j < nlists; ++j)
+{
+if (EQ (lists[j], tortoises[j]))
+{
+signal_circular_list_error (lists[j]);
+}
+}
+}
+}
 }
 RETURN_UNGCPRO (result);
 }
 arguments: (FUNCTION LIST &rest LISTS)
 */
 (int nargs, Lisp_Object *args))
 {
-return maplist (args[0], nargs - 1, args + 1, 0, 0);
+return maplist (args[0], nargs - 1, args + 1, Qmaplist);
 }
 DEFUN ("mapl", Fmapl, 2, MANY, 0, /*
 Like `maplist', but do not accumulate values returned by the function.
 arguments: (FUNCTION LIST &rest LISTS)
 */
 (int nargs, Lisp_Object *args))
 {
-return maplist (args[0], nargs - 1, args + 1, 1, 0);
+return maplist (args[0], nargs - 1, args + 1, Qmapl);
 }
 DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /*
 Like `maplist', but chains together the values returned by FUNCTION.
 arguments: (FUNCTION LIST &rest LISTS)
 */
 (int nargs, Lisp_Object *args))
 {
-return maplist (args[0], nargs - 1, args + 1, 0, 1);
+return maplist (args[0], nargs - 1, args + 1, Qmapcon);
 }
 /* Extra random functions */
 DEFUN ("reduce", Freduce, 2, MANY, 0, /*
 Boolint need_accum = 0;
 Lisp_Object *subsequence = NULL;
 Elemcount counting = 0, len = 0;
 	  struct gcpro gcpro1;
-if (ending - starting && starting < ending && EMACS_INT_MAX == ending)
+if (ending - starting && starting < ending
+	      && EMACS_INT_MAX == ending)
 {
 ending = XINT (Flength (sequence));
 }
 /* :from-end with a list; make an alloca copy of the relevant list
 DEFSYMBOL (Qstring);
 DEFSYMBOL (Qlist);
 DEFSYMBOL (Qbit_vector);
 defsymbol (&QsortX, "sort*");
 DEFSYMBOL (Qreduce);
+DEFSYMBOL (Qmapconcat);
+defsymbol (&QmapcarX, "mapcar*");
+DEFSYMBOL (Qmapvector);
+DEFSYMBOL (Qmapcan);
+DEFSYMBOL (Qmapc);
+DEFSYMBOL (Qmap);
+DEFSYMBOL (Qmap_into);
+DEFSYMBOL (Qsome);
+DEFSYMBOL (Qevery);
+DEFSYMBOL (Qmaplist);
+DEFSYMBOL (Qmapl);
+DEFSYMBOL (Qmapcon);
 DEFKEYWORD (Q_from_end);
 DEFKEYWORD (Q_initial_value);
 DEFSYMBOL (Qyes_or_no_p);

Mercurial > hg > xemacs-beta

comparison src/fns.c @ 5253:b6a398dbb403