changeset: 5273:799742b751c8 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Thu Sep 16 20:34:49 2010 +0100 files: lisp/cl-extra.el src/ChangeLog src/fns.c description: Accept circular lists where that is useful in #'mapcar*, #'map* and friends. src/ChangeLog addition: 2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net&gt; * fns.c (Flist_length): New, moved here from cl-extra.el, needed by the next function. (shortest_length_among_sequences): New. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into, Fsome, Fevery): Use shortest_length_among_sequences() when working out how many iterations to do, only giving circular list errors if all arguments are circular. diff -r 66dbef5f8076 -r 799742b751c8 lisp/cl-extra.el --- a/lisp/cl-extra.el Thu Sep 16 18:46:05 2010 +0100 +++ b/lisp/cl-extra.el Thu Sep 16 20:34:49 2010 +0100 ＠＠ -405,13 +405,6 ＠＠ "Equivalent to (nconc (nreverse X) Y)." (nconc (nreverse x) y)) -(defun list-length (list) - "Return the length of LIST. Return nil if LIST is circular." - (if (listp list) - (condition-case nil (length list) (circular-list)) - ;; Error on not-a-list: - (car list))) - (defun tailp (sublist list) "Return true if SUBLIST is a tail of LIST." (while (and (consp list) (not (eq sublist list))) diff -r 66dbef5f8076 -r 799742b751c8 src/ChangeLog --- a/src/ChangeLog Thu Sep 16 18:46:05 2010 +0100 +++ b/src/ChangeLog Thu Sep 16 20:34:49 2010 +0100 ＠＠ -1,3 +1,14 ＠＠ +2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * fns.c (Flist_length): New, moved here from cl-extra.el, needed + by the next function. + (shortest_length_among_sequences): New. + (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) + (Fmap_into, Fsome, Fevery): + Use shortest_length_among_sequences() when working out how many + iterations to do, only giving circular list errors if all + arguments are circular. + 2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net&gt; * fns.c (Fsubseq): diff -r 66dbef5f8076 -r 799742b751c8 src/fns.c --- a/src/fns.c Thu Sep 16 18:46:05 2010 +0100 +++ b/src/fns.c Thu Sep 16 20:34:49 2010 +0100 ＠＠ -337,6 +337,29 ＠＠ } return make_int (len); +} + +/* This is almost the above, but is defined by Common Lisp. We need it in C + for shortest_length_among_sequences(), below, for the various sequence + functions that can usefully operate on circular lists. */ + +DEFUN ("list-length", Flist_length, 1, 1, 0, /* +Return the length of LIST. Return nil if LIST is circular. +*/ + (list)) +{ + Lisp_Object hare, tortoise; + Elemcount len; + + for (hare = tortoise = list, len = 0; + CONSP (hare) && (! EQ (hare, tortoise) || len == 0); + hare = XCDR (hare), len++) + { + if (len & 1) + tortoise = XCDR (tortoise); + } + + return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len); } /*** string functions. ***/ ＠＠ -4458,6 +4481,42 ＠＠ UNGCPRO; } +/* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return + the length of the shortest sequence. Error if all are circular, or if any + one of them is not a sequence. */ +static Elemcount +shortest_length_among_sequences (int nsequences, Lisp_Object *sequences) +{ + Elemcount len = EMACS_INT_MAX; + Lisp_Object length; + int i; + + for (i = 0; i < nsequences; ++i) + { + if (CONSP (sequences[i])) + { + length = Flist_length (sequences[i]); + if (!NILP (length)) + { + len = min (len, XINT (length)); + } + } + else + { + CHECK_SEQUENCE (sequences[i]); + length = Flength (sequences[i]); + len = min (len, XINT (length)); + } + } + + if (NILP (length)) + { + signal_circular_list_error (sequences[0]); + } + + return len; +} + DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /* Call FUNCTION on each element of SEQUENCE, and concat results to a string. Between each pair of results, insert SEPARATOR. ＠＠ -4485,11 +4544,7 ＠＠ args[2] = sequence; args[1] = separator; - for (i = 2; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + len = shortest_length_among_sequences (nargs - 2, args + 2); if (len == 0) return build_ascstring (""); ＠＠ -4536,15 +4591,8 ＠＠ (int nargs, Lisp_Object *args)) { Lisp_Object function = args[0]; - Elemcount len = EMACS_INT_MAX; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); Lisp_Object *args0; - int i; - - for (i = 1; i < nargs; ++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, QmapcarX); ＠＠ -4567,18 +4615,10 ＠＠ (int nargs, Lisp_Object *args)) { Lisp_Object function = args[0]; - Elemcount len = EMACS_INT_MAX; - Lisp_Object result; - struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - - result = make_vector (len, Qnil); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object result = make_vector (len, Qnil); + + struct gcpro gcpro1; 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. */ ＠＠ -4602,21 +4642,13 ＠＠ */ (int nargs, Lisp_Object *args)) { - Lisp_Object function = args[0], *result; - Elemcount result_len = EMACS_INT_MAX; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - result_len = min (result_len, XINT (Flength (args[i]))); - } - - result = alloca_array (Lisp_Object, result_len); - mapcarX (result_len, result, Qnil, function, nargs - 1, args + 1, Qmapcan); + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); + Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len); + + mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan); /* #'nconc GCPROs its args in case of signals and error. */ - return Fnconc (result_len, result); + return Fnconc (len, result); } DEFUN ("mapc", Fmapc, 2, MANY, 0, /* ＠＠ -4637,17 +4669,9 ＠＠ */ (int nargs, Lisp_Object *args)) { - Elemcount len = EMACS_INT_MAX; + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); Lisp_Object sequence = args[1]; struct gcpro gcpro1; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } - /* 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. */ ＠＠ -4677,15 +4701,8 ＠＠ Lisp_Object function = args[1]; Lisp_Object result = Qnil; Lisp_Object *args0 = NULL; - Elemcount len = EMACS_INT_MAX; - int i; - struct gcpro gcpro1; - - for (i = 2; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2); + struct gcpro gcpro1; if (!NILP (type)) { ＠＠ -4742,19 +4759,14 ＠＠ */ (int nargs, Lisp_Object *args)) { - Elemcount len = EMACS_INT_MAX; + Elemcount len; Lisp_Object result_sequence = args[0]; Lisp_Object function = args[1]; - int i; args[0] = function; args[1] = result_sequence; - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + len = shortest_length_among_sequences (nargs - 1, args + 1); mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, Qmap_into); ＠＠ -4776,14 +4788,7 ＠＠ { Lisp_Object result = Qnil, result_ptr = STORE_VOID_IN_LISP ((void *) &result); - Elemcount len = EMACS_INT_MAX; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome); ＠＠ -4803,14 +4808,7 ＠＠ (int nargs, Lisp_Object *args)) { Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result); - Elemcount len = EMACS_INT_MAX; - int i; - - for (i = 1; i < nargs; ++i) - { - CHECK_SEQUENCE (args[i]); - len = min (len, XINT (Flength (args[i]))); - } + Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1); mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery); ＠＠ -6683,6 +6681,7 ＠＠ DEFSUBR (Frandom); DEFSUBR (Flength); DEFSUBR (Fsafe_length); + DEFSUBR (Flist_length); DEFSUBR (Fstring_equal); DEFSUBR (Fcompare_strings); DEFSUBR (Fstring_lessp); _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/mailman/listinfo/xemacs-patches