commit: Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe
kehoea at parhasard.net
Sat Feb 6 07:28:45 EST 2010
changeset: 4997:8800b5350a13
user: Aidan Kehoe <kehoea at parhasard.net>
date: Wed Feb 03 20:26:47 2010 +0000
files: lisp/ChangeLog lisp/cl-extra.el lisp/cl-macs.el src/ChangeLog src/fns.c
description:
Move #'some, #'every to C, implementing them with mapcarX.
src/ChangeLog addition:
2010-02-03 Aidan Kehoe <kehoea at 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 at 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).
diff -r c17c857e20bf -r 8800b5350a13 lisp/ChangeLog
--- a/lisp/ChangeLog Wed Feb 03 20:18:53 2010 +0000
+++ b/lisp/ChangeLog Wed Feb 03 20:26:47 2010 +0000
@@ -1,3 +1,11 @@
+2010-02-03 Aidan Kehoe <kehoea at 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).
+
2010-02-03 Aidan Kehoe <kehoea at parhasard.net>
Delete a couple of XEmacs-specific functions that duplicate CL
diff -r c17c857e20bf -r 8800b5350a13 lisp/cl-extra.el
--- a/lisp/cl-extra.el Wed Feb 03 20:18:53 2010 +0000
+++ b/lisp/cl-extra.el Wed Feb 03 20:26:47 2010 +0000
@@ -225,34 +225,8 @@
;; (and (equal "" y) (equal #* x)))))
;; (t (equal x y)))))))
-;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon are now in C, together
-;; with #'map-into, which was never in this file.
-
-(defun some (cl-pred cl-seq &rest cl-rest)
- "Return true if PREDICATE is true of any element of SEQ or SEQs.
-If so, return the true (non-nil) value returned by PREDICATE."
- (if (or cl-rest (nlistp cl-seq))
- (catch 'cl-some
- (apply 'map nil
- (function (lambda (&rest cl-x)
- (let ((cl-res (apply cl-pred cl-x)))
- (if cl-res (throw 'cl-some cl-res)))))
- cl-seq cl-rest) nil)
- (let ((cl-x nil))
- (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
- cl-x)))
-
-(defun every (cl-pred cl-seq &rest cl-rest)
- "Return true if PREDICATE is true of every element of SEQ or SEQs."
- (if (or cl-rest (nlistp cl-seq))
- (catch 'cl-every
- (apply 'map nil
- (function (lambda (&rest cl-x)
- (or (apply cl-pred cl-x) (throw 'cl-every nil))))
- cl-seq cl-rest) t)
- (while (and cl-seq (funcall cl-pred (car cl-seq)))
- (setq cl-seq (cdr cl-seq)))
- (null cl-seq)))
+;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every
+;; are now in C, together with #'map-into, which was never in this file.
(defun notany (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of every element of SEQ or SEQs."
diff -r c17c857e20bf -r 8800b5350a13 lisp/cl-macs.el
--- a/lisp/cl-macs.el Wed Feb 03 20:18:53 2010 +0000
+++ b/lisp/cl-macs.el Wed Feb 03 20:26:47 2010 +0000
@@ -3545,6 +3545,12 @@
;; ;; byte-optimize.el).
;; (t form)))))
+(define-compiler-macro notany (&whole form &rest cl-rest)
+ (cons 'not (cons 'some (cdr cl-rest))))
+
+(define-compiler-macro notevery (&whole form &rest cl-rest)
+ (cons 'not (cons 'every (cdr cl-rest))))
+
(mapc
#'(lambda (y)
(put (car y) 'side-effect-free t)
@@ -3572,7 +3578,7 @@
(cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr)))
;;; Things that are inline.
-(proclaim '(inline acons map concatenate notany notevery
+(proclaim '(inline acons map concatenate
;; XEmacs omission: gethash is builtin
cl-set-elt revappend nreconc))
diff -r c17c857e20bf -r 8800b5350a13 src/ChangeLog
--- a/src/ChangeLog Wed Feb 03 20:18:53 2010 +0000
+++ b/src/ChangeLog Wed Feb 03 20:26:47 2010 +0000
@@ -1,3 +1,16 @@
+2010-02-03 Aidan Kehoe <kehoea at 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.
+
2010-02-03 Jerry James <james at xemacs.org>
* s/mach-bsd4-3.h: Add historical copyright and license information,
diff -r c17c857e20bf -r 8800b5350a13 src/fns.c
--- a/src/fns.c Wed Feb 03 20:18:53 2010 +0000
+++ b/src/fns.c Wed Feb 03 20:26:47 2010 +0000
@@ -3242,11 +3242,24 @@
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;
@@ -3350,7 +3363,7 @@
called = Ffuncall (nsequences + 1, args);
if (vals != NULL)
{
- vals[i] = called;
+ vals[i] = IGNORE_MULTIPLE_VALUES (called);
gcpro2.nvars += 1;
}
else
@@ -3361,20 +3374,50 @@
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
- into the list before we've processed the relevant
- part, error. */
- dead_wrong_type_argument (Qconsp, lisp_vals);
+ called = IGNORE_MULTIPLE_VALUES (called);
+ if (!CONSP (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);
- lisp_vals = XCDR (lisp_vals);
- break;
+ if (SOME_OR_EVERY_SOME == some_or_every)
+ {
+ 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. */
@@ -3386,11 +3429,13 @@
/* 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,
@@ -3398,6 +3443,7 @@
Faset (lisp_vals, make_int (i), called);
break;
}
+ bad_show_or_every_flag:
default:
{
ABORT();
@@ -3461,7 +3507,8 @@
}
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--)
@@ -3499,7 +3546,8 @@
}
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);
}
@@ -3534,7 +3582,8 @@
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;
@@ -3568,7 +3617,8 @@
}
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)
{
@@ -3623,7 +3673,8 @@
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);
}
@@ -3663,7 +3714,8 @@
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))
{
@@ -3727,9 +3779,72 @@
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
@@ -3793,7 +3908,7 @@
}
}
if (!continuing) break;
- funcalled = Ffuncall (nlists + 1, args);
+ funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args));
if (!maplp)
{
if (nconcp)
@@ -4639,6 +4754,8 @@
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);
More information about the XEmacs-Patches
mailing list