xemacs-beta: src/fns.c comparison

comparison src/fns.c @ 4997:8800b5350a13

Move #'some, #'every to C, implementing them with mapcarX. src/ChangeLog addition: 2010-02-03 Aidan Kehoe <kehoea@parhasard.net> * fns.c (mapcarX): Accept a new argument, indicating whether the function is being called from #'some or #'every. Implement it. Discard any multiple values where that is appropriate. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into): Pass the new flag to mapcarX. (Fsome, Fevery): Move these functions here from cl-extra.el; implement them in terms of mapcarX. (maplist): Discard multiple values where appropriate. lisp/ChangeLog addition: 2010-02-03 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (some, every): Move these functions to C. * cl-macs.el (notany, notevery): Add compiler macros for these functions, no longer proclaim them inline (which would involve specbinding that's not necessary with the compiler macros).

author	Aidan Kehoe <kehoea@parhasard.net>
date	Wed, 03 Feb 2010 20:26:47 +0000
parents	c17c857e20bf
children	b46c89ccbed3

comparison

equal deleted inserted replaced

-:c17c857e20bf
+:8800b5350a13
 Otherwise, mapcarX signals a wrong-type-error 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. */
+traversal operation.
+If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple)
+values given by FUNCTION the first time it is non-nil, and abandon the
+iterations.  LISP_VALS in this case must be an object created by
+make_opaque_ptr, dereferenced as pointing to a Lisp object. If
+SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil at the Lisp_Object
+pointer address provided by LISP_VALS if FUNCTION gives nil; otherwise
+leave it alone. */
+#define SOME_OR_EVERY_NEITHER 0
+#define SOME_OR_EVERY_SOME    1
+#define SOME_OR_EVERY_EVERY   2
 static void
 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals,
-	 Lisp_Object function, int nsequences, Lisp_Object *sequences)
+	 Lisp_Object function, int nsequences, Lisp_Object *sequences,
+	 int some_or_every)
 {
 Lisp_Object called, *args;
 struct gcpro gcpro1, gcpro2;
 int i, j;
 enum lrecord_type lisp_vals_type;
 		}
 	    }
 	  called = Ffuncall (nsequences + 1, args);
 	  if (vals != NULL)
 	    {
-	      vals[i] = called;
+	      vals[i] = IGNORE_MULTIPLE_VALUES (called);
 	      gcpro2.nvars += 1;
 	    }
 	  else
 	    {
 	      switch (lisp_vals_type)
 		{
 		case lrecord_type_symbol:
 		  break;
 		case lrecord_type_cons:
 		  {
-		    if (!CONSP (lisp_vals))
+		    if (SOME_OR_EVERY_NEITHER == some_or_every)
 		      {
-			/* If FUNCTION has inserted a non-cons non-nil cdr
+			called = IGNORE_MULTIPLE_VALUES (called);
-			   into the list before we've processed the relevant
+			if (!CONSP (lisp_vals))
-			   part, error. */
+			  {
-			dead_wrong_type_argument (Qconsp, lisp_vals);
+			    /* If FUNCTION has inserted a non-cons non-nil
+			       cdr into the list before we've processed the
+			       relevant part, error. */
+			    dead_wrong_type_argument (Qconsp, lisp_vals);
+			  }
+			XSETCAR (lisp_vals, called);
+			lisp_vals = XCDR (lisp_vals);
+			break;
 		      }
-		    XSETCAR (lisp_vals, called);
+		    if (SOME_OR_EVERY_SOME == some_or_every)
-		    lisp_vals = XCDR (lisp_vals);
+		      {
-		    break;
+			if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
+			  {
+			    XCAR (lisp_vals) = called;
+			    UNGCPRO;
+			    return;
+			  }
+			break;
+		      }
+		    if (SOME_OR_EVERY_EVERY == some_or_every)
+		      {
+			called = IGNORE_MULTIPLE_VALUES (called);
+			if (NILP (called))
+			  {
+			    XCAR (lisp_vals) = Qnil;
+			    UNGCPRO;
+			    return;
+			  }
+			break;
+		      }
+		    goto bad_show_or_every_flag;
 		  }
 		case lrecord_type_vector:
 		  {
+		    called = IGNORE_MULTIPLE_VALUES (called);
 		    i < XVECTOR_LENGTH (lisp_vals) ?
 		      (XVECTOR_DATA (lisp_vals)[i] = called) :
 		      /* Let #'aset error. */
 		      Faset (lisp_vals, make_int (i), called);
 		    break;
 		case lrecord_type_string:
 		  {
 		    /* If this ever becomes a code hotspot, we can keep
 		       around pointers into the data of the string, checking
 		       each time that it hasn't been relocated. */
+		    called = IGNORE_MULTIPLE_VALUES (called);
 		    Faset (lisp_vals, make_int (i), called);
 		    break;
 		  }
 		case lrecord_type_bit_vector:
 		  {
+		    called = IGNORE_MULTIPLE_VALUES (called);
 		    (BITP (called) &&
 		     i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
 		      set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
 					  XINT (called)) :
 		      Faset (lisp_vals, make_int (i), called);
 		    break;
 		  }
+		bad_show_or_every_flag:
 		default:
 		  {
 		    ABORT();
 		    break;
 		  }
 	  sequence = XCDR (sequence);
 	}
 }
 else
 {
-mapcarX (len, args0, Qnil, function, nargs - 2, args + 2);
+mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
+	       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,
+	   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);
+mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
+	   SOME_OR_EVERY_NEITHER);
 UNGCPRO;
 return result;
 }
 CHECK_SEQUENCE (args[i]);
 len = min (len, XINT (Flength (args[i])));
 }
 args0 = alloca_array (Lisp_Object, len + 1);
-mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1);
+mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1,
+	   SOME_OR_EVERY_NEITHER);
 if (len < 2)
 {
 return len ? args0[1] : Qnil;
 }
 /* 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,
+	   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,
+	   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);
+mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
+	   SOME_OR_EVERY_NEITHER);
 return result_sequence;
+}
+DEFUN ("some", Fsome, 2, MANY, 0, /*
+Return true if PREDICATE gives non-nil for an element of SEQUENCE.
+If so, return the value (possibly multiple) given by PREDICATE.
+With optional SEQUENCES, call PREDICATE each time with as many arguments as
+there are SEQUENCES (plus one for the element from SEQUENCE).
+arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
+*/
+(int nargs, Lisp_Object *args))
+{
+Lisp_Object result_box = Fcons (Qnil, Qnil);
+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,
+	   SOME_OR_EVERY_SOME);
+RETURN_UNGCPRO (XCAR (result_box));
+}
+DEFUN ("every", Fevery, 2, MANY, 0, /*
+Return true if PREDICATE is true of every element of SEQUENCE.
+With optional SEQUENCES, call PREDICATE each time with as many arguments as
+there are SEQUENCES (plus one for the element from SEQUENCE).
+In contrast to `some', `every' never returns multiple values.
+arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
+*/
+(int nargs, Lisp_Object *args))
+{
+Lisp_Object result_box = Fcons (Qt, Qnil);
+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,
+	   SOME_OR_EVERY_EVERY);
+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.
 	    {
 	      dead_wrong_type_argument (Qlistp, lists[j]);
 	    }
 	}
 if (!continuing) break;
-funcalled = Ffuncall (nlists + 1, args);
+funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args));
 if (!maplp)
 	{
 	  if (nconcp)
 	    {
 	      /* This order of calls means we check that each list is
 DEFSUBR (Fmapcan);
 DEFSUBR (Fmapc);
 DEFSUBR (Fmapconcat);
 DEFSUBR (Fmap);
 DEFSUBR (Fmap_into);
+DEFSUBR (Fsome);
+DEFSUBR (Fevery);
 Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc")));
 Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*")));
 DEFSUBR (Fmaplist);
 DEFSUBR (Fmapl);
 DEFSUBR (Fmapcon);

Mercurial > hg > xemacs-beta

comparison src/fns.c @ 4997:8800b5350a13